content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  -- | Generate an Ersatz problem definition for the regexp grid.
  
  module RegexpGrid.Problem (problem) where
  
  import Prelude hiding ((&&), (||), not, and, or, all, any)
  
  import Control.Applicative
  import qualified Control.Monad.Fail as Fail
  import Control.Monad (guard)
  import Control.Monad.Reader (MonadReader(..), ReaderT(..))
  import Control.Monad.RWS.Strict (RWST, evalRWST)
  import Control.Monad.Trans (MonadTrans(..))
  import Control.Monad.Writer.Strict (MonadWriter(..))
  import Control.Lens
  import qualified Data.Foldable as F (asum)
  import Data.Map (Map)
  import qualified Data.Map as Map
  #if !(MIN_VERSION_base(4,11,0))
  import Data.Semigroup (Semigroup(..))
  #endif
  import Data.Sequence (Seq)
  import qualified Data.Sequence as Seq
  import Ersatz
  
  import RegexpGrid.Regexp
  import RegexpGrid.Types
  
  type ReBit = RWST () ReBitResult ReBitState []
  
  -- | The state threaded through 'reBit'.
  data ReBitState = ReBitState
    { _rbsFields    :: Seq Field  -- ^ The fields against whom to apply the regexp.
    , _rbsLastGroup :: Integer    -- ^ The latest captured group.
    , _rbsGroups    :: Map Integer (Seq Field)  -- ^ The groups captured so far.
    }
    deriving Show
  
  -- | The result value of 'reBit'.
  data ReBitResult = ReBitResult
    { _rbrCurrentGroup :: Seq Field  -- ^ The fields in the current group. Used by backreferences.
    , _rbrResultBit    :: Bit        -- ^ The accumulated result 'Bit'.
    }
    deriving Show
  
  makeLenses ''ReBitState
  makeLenses ''ReBitResult
  
  instance Semigroup ReBitResult where
    ReBitResult fieldsA bitA <> ReBitResult fieldsB bitB =
      ReBitResult (fieldsA <> fieldsB) (bitA && bitB)
    {-# INLINE (<>) #-}
  
  instance Monoid ReBitResult where
    mempty = ReBitResult mempty true
    {-# INLINE mempty #-}
  #if !(MIN_VERSION_base(4,11,0))
    mappend = (<>)
    {-# INLINE mappend #-}
  #endif
  
  problem :: (Applicative m, Fail.MonadFail m, MonadSAT s m)
          => m (Map Pos Field)
  problem = do
    -- Allocate a literal for each field.
    fieldMap <- Map.fromList <$> mapM (\pos -> (pos,) <$> exists) [minBound..]
    runReaderT problem' fieldMap
    return fieldMap
  
  problem' :: (Fail.MonadFail m, MonadSAT s m)
           => ReaderT (Map Pos Field) m ()
  problem' = do
    r [P00,P01,P02,P03,P04,P05,P06] ".*H.*H.*"
    r [P10,P11,P12,P13,P14,P15,P16,P17] "(DI|NS|TH|OM)*"
    r [P20,P21,P22,P23,P24,P25,P26,P27,P28] "F.*[AO].*[AO].*"
    r [P30,P31,P32,P33,P34,P35,P36,P37,P38,P39] "(O|RHH|MM)*"
    r [P40,P41,P42,P43,P44,P45,P46,P47,P48,P49,P4a] ".*"
    r [P50,P51,P52,P53,P54,P55,P56,P57,P58,P59,P5a,P5b] "C*MC(CCC|MM)*"
    r [P60,P61,P62,P63,P64,P65,P66,P67,P68,P69,P6a,P6b,P6c] "[^C]*[^R]*III.*"
    r [P70,P71,P72,P73,P74,P75,P76,P77,P78,P79,P7a,P7b] "(...?)\\1*"
    r [P80,P81,P82,P83,P84,P85,P86,P87,P88,P89,P8a] "([^X]|XCC)*"
    r [P90,P91,P92,P93,P94,P95,P96,P97,P98,P99] "(RR|HHH)*.?"
    r [Pa0,Pa1,Pa2,Pa3,Pa4,Pa5,Pa6,Pa7,Pa8] "N.*X.X.X.*E"
    r [Pb0,Pb1,Pb2,Pb3,Pb4,Pb5,Pb6,Pb7] "R*D*M*"
    r [Pc0,Pc1,Pc2,Pc3,Pc4,Pc5,Pc6] ".(C|HH)*"
  
    r [P00,P10,P20,P30,P40,P50,P60] "(ND|ET|IN)[^X]*"
    r [P01,P11,P21,P31,P41,P51,P61,P70] "[CHMNOR]*I[CHMNOR]*"
    r [P02,P12,P22,P32,P42,P52,P62,P71,P80] "P+(..)\\1.*"
    r [P03,P13,P23,P33,P43,P53,P63,P72,P81,P90] "(E|CR|MN)*"
    r [P04,P14,P24,P34,P44,P54,P64,P73,P82,P91,Pa0] "([^MC]|MM|CC)*"
    r [P05,P15,P25,P35,P45,P55,P65,P74,P83,P92,Pa1,Pb0] "[AM]*CM(RC)*R?"
    r [P06,P16,P26,P36,P46,P56,P66,P75,P84,P93,Pa2,Pb1,Pc0] ".*"
    r [P17,P27,P37,P47,P57,P67,P76,P85,P94,Pa3,Pb2,Pc1] ".*PRR.*DDC.*"
    r [P28,P38,P48,P58,P68,P77,P86,P95,Pa4,Pb3,Pc2] "(HHX|[^HX])*"
    r [P39,P49,P59,P69,P78,P87,P96,Pa5,Pb4,Pc3] "([^EMC]|EM)*"
    r [P4a,P5a,P6a,P79,P88,P97,Pa6,Pb5,Pc4] ".*OXR.*"
    r [P5b,P6b,P7a,P89,P98,Pa7,Pb6,Pc5] ".*LR.*RL.*"
    r [P6c,P7b,P8a,P99,Pa8,Pb7,Pc6] ".*SE.*UE.*"
  
    r [Pc0,Pb0,Pa0,P90,P80,P70,P60] ".*G.*V.*H.*"
    r [Pc1,Pb1,Pa1,P91,P81,P71,P61,P50] "[CR]*"
    r [Pc2,Pb2,Pa2,P92,P82,P72,P62,P51,P40] ".*XEXM*"
    r [Pc3,Pb3,Pa3,P93,P83,P73,P63,P52,P41,P30] ".*DD.*CCM.*"
    r [Pc4,Pb4,Pa4,P94,P84,P74,P64,P53,P42,P31,P20] ".*XHCR.*X.*"
    r [Pc5,Pb5,Pa5,P95,P85,P75,P65,P54,P43,P32,P21,P10] ".*(.)(.)(.)(.)\\4\\3\\2\\1.*"
    r [Pc6,Pb6,Pa6,P96,P86,P76,P66,P55,P44,P33,P22,P11,P00] ".*(IN|SE|HI)"
    r [Pb7,Pa7,P97,P87,P77,P67,P56,P45,P34,P23,P12,P01] "[^C]*MMM[^C]*"
    r [Pa8,P98,P88,P78,P68,P57,P46,P35,P24,P13,P02] ".*(.)C\\1X\\1.*"
    r [P99,P89,P79,P69,P58,P47,P36,P25,P14,P03] "[CEIMU]*OH[AEMOR]*"
    r [P8a,P7a,P6a,P59,P48,P37,P26,P15,P04] "(RX|[^R])*"
    r [P7b,P6b,P5a,P49,P38,P27,P16,P05] "[^M]*M[^M]*"
    r [P6c,P5b,P4a,P39,P28,P17,P06] "(S|MM|HHH)*"
  
  r :: (Fail.MonadFail m, MonadSAT s m)
    => [Pos] -> String -> ReaderT (Map Pos Field) m ()
  r poss regexpStr = do
    fieldMap <- ask
    let fields = (fieldMap Map.!) <$> Seq.fromList poss
  
    regexp <- either (fail . show) return
            $ parseRegexp "RegexpGrid.Problem" regexpStr
  
    lift . assert $ runReBit regexp fields
  
  runReBit :: Regexp -> Seq Field -> Bit
  runReBit regexp fields =
    or (evalRWST go () initState ^.. folded . _2 . rbrResultBit)
    where
      initState = ReBitState fields 0 Map.empty
  
      go = reBit regexp <* endOfFields
      -- Make sure all the fields have been consumed.
      endOfFields = guard . Seq.null =<< use rbsFields
  
  reBit :: Regexp -> ReBit ()
  
  -- The end of the regexp. Nothing to do.
  reBit Nil = return ()
  
  -- Any character. Advance a field, assert just true.
  reBit (AnyCharacter next) = do
    withNextField $ const true
    reBit next
  
  -- The character c. Advance a field and assert that it matches c.
  reBit (Character c next) = do
    withNextField $ \f -> f === encode c
    reBit next
  
  -- The character group cs. Advance a field and assert that it matches any one
  -- of cs.
  reBit (Accept cs next) = do
    withNextField $ \f -> any (\c -> f === encode c) cs
    reBit next
  
  -- The character group ^cs. Advance a field and assert that it does not match
  -- any of cs.
  reBit (Reject cs next) = do
    withNextField $ \f -> all (\c -> f /== encode c) cs
    reBit next
  
  -- A choice of regexps. The 'Alternative' sum of all of them.
  reBit (Choice res next) = do
    F.asum (map reBit res)
    reBit next
  
  -- Capture a group.
  reBit (Group re' next) = do
    ((), groupResult) <- listen (reBit re')
  
    -- Allocate a new group ID and add the group to the group map.
    gid <- rbsLastGroup <+= 1
    rbsGroups . at gid ?= (groupResult ^. rbrCurrentGroup)
  
    reBit next
  
  -- Repetition {_,0}: Just skip to the next part of the regexp.
  reBit (Repeat _ (Just 0) _ next) =
    reBit next
  
  -- Repetition {0,_}: Branch to the alternatives:
  -- • skip to the next part (zero instances)
  -- • at least one instance ({1,_}).
  reBit (Repeat 0 mj re' next) =
    reBit next <|> reBit (Repeat 1 mj re' next)
  
  -- Repetition {i,j} where i > 0 and j > 0: At least one instance followed by
  -- {i−1,j−1}.
  reBit (Repeat i mj re' next) = do
    reBit re'
    reBit (Repeat (i-1) (subtract 1 <$> mj) re' next)
  
  -- Backreference.
  reBit (Backreference n next) = do
    -- The fields of the group referred to.
    Just refFields <- use (rbsGroups . at n)
    -- Advance an equivalent number of fields.
    fields <- traverse (const nextField) refFields
    -- Assert that the field sequences match each other.
    tell $ ReBitResult fields (and (Seq.zipWith (===) refFields fields))
    reBit next
  
  -- Advance a field and build a Bit based on it.
  withNextField :: (Field -> Bit) -> ReBit ()
  withNextField func = do
    f <- nextField
    tell $ ReBitResult (Seq.singleton f) (func f)
  
  -- Advance a field.
  nextField :: ReBit Field
  nextField = do
    -- Pop the first field from the state. Fails if there are none left.
    Just (f, fs) <- preuse (rbsFields . _Cons)
    rbsFields .= fs
    return f
  