Pattern match checker iteration limit exceeded

2017-18.hs

type Register = Char

data RValue = Reg Register | Imm Int
  deriving Show

data Instruction
  = Snd RValue
  | Set Register RValue
  | Add Register RValue
  | Mul Register RValue
  | Mod Register RValue
  | Rcv RValue
  | Jgz RValue RValue
  deriving Show

data CPU = CPU
  { lastFreq :: Maybe Int
  , program :: ListZipper Instruction
  , registers :: HM.HashMap Register Int }
  deriving Show

makeCPU :: [Instruction] -> CPU
makeCPU is = CPU
  { lastFreq = Nothing
  , program = LZ.fromList is
  , registers = HM.empty }

nextInstr :: CPU -> Maybe CPU
nextInstr c = (\p -> c { program = p }) <$> zipperNext (program c)

readValue :: RValue -> CPU -> Int
readValue (Reg r) c = HM.lookupDefault 0 r (registers c)
readValue (Imm n) _ = n

modifyReg :: (Int -> Int) -> Register -> CPU -> CPU
modifyReg f r c = c { registers = HM.alter (Just . f . fromMaybe 0) r (registers c) }

runInstruction :: CPU -> Maybe CPU
runInstruction c =
  case zipperHead (program c) of
    Just (Snd rv) -> nextInstr $ c { lastFreq = Just (readValue rv c) }
    Just (Set r rv) -> nextInstr $ modifyReg (const (readValue rv c)) r c
    Just (Add r rv) -> nextInstr $ modifyReg (+ (readValue rv c)) r c
    Just (Mul r rv) -> nextInstr $ modifyReg (* (readValue rv c)) r c
    Just (Mod r rv) -> nextInstr $ modifyReg (`mod` (readValue rv c)) r c
    Just (Rcv rv)
      | Just fr <- lastFreq c
      , readValue rv c /= 0
        -> error ("rcv called with value " ++ show fr)
      | otherwise -> nextInstr $ c
    Just (Jgz rv1 rv2)
      | readValue rv1 c > 0 -> (\p -> c { program = p }) <$> moveZipper (readValue rv2 c) (program c)
      | otherwise -> nextInstr c
    Nothing -> Nothing

parseProgram :: String -> [Instruction]
parseProgram is = map ((\(w:ws) -> parseInstr w ws) . words) (lines is)
  where
    parseRValue :: String -> RValue
    parseRValue [r] | isAlpha r = Reg r
    parseRValue n = Imm (read n)
    
    instr1 :: (RValue -> Instruction) -> [String] -> Instruction
    instr1 f [rv] = f (parseRValue rv)
    
    instr2 :: (Register -> RValue -> Instruction) -> [String] -> Instruction
    instr2 f [[r], rv] = f r (parseRValue rv)
    
    instr2' :: (RValue -> RValue -> Instruction) -> [String] -> Instruction
    instr2' f [rv1, rv2] = f (parseRValue rv1) (parseRValue rv2)
    
    parseInstr "snd" = instr1 Snd
    parseInstr "set" = instr2 Set
    parseInstr "add" = instr2 Add
    parseInstr "mul" = instr2 Mul
    parseInstr "mod" = instr2 Mod
    parseInstr "rcv" = instr1 Rcv
    parseInstr "jgz" = instr2' Jgz

runCPU :: CPU -> [CPU]
runCPU c = takeJusts $ iterate (>>= runInstruction) (Just c)
  where
    takeJusts (Just x:xs) = x:takeJusts xs
    takeJusts (Nothing:_) = []
    takeJusts [] = []

part1 :: String -> Maybe CPU
part1 s = foldl' (flip (const . Just)) Nothing $ runCPU $ makeCPU $ parseProgram s

data ProgramPair = ProgramPair
  { cpu0 :: Maybe CPU
  , cpu1 :: Maybe CPU
  , rcv0 :: Seq Int
  , rcv1 :: Seq Int }

runInstruction2 :: ProgramPair -> Maybe ProgramPair
runInstruction2 p@(ProgramPair c0 c1 r0 r1) =
  case (c0 >>= (zipperHead . program), c1 >>= (zipperHead . program)) of
    -- Run sends before receives so that we don't get stuck
    (Just (Snd rv), _) -> Just p
        { cpu0 = c0 >>= nextInstr
        , rcv1 = r1 S.|> readValue rv (fromJust c0) }
    (_, Just (Snd rv)) -> Just p
        { cpu1 = c1 >>= nextInstr
        , rcv0 = r0 S.|> readValue rv (fromJust c1) }
    -- The type of rcv was initially an rvalue, but in part 2 it was
    -- revealed to be a register; keeping it as an rvalue simplifies
    -- part 1's code and doesn't impose an undue burden here (we only
    -- have to assert that it is in fact a register)
    (Just (Rcv (Reg r)), _)
      | val :<| r0' <- r0 -> Just p
            { cpu0 = nextInstr $ modifyReg (const val) r (fromJust c0)
            , rcv0 = r0' }
    (_, Just (Rcv (Reg r)))
      | val :<| r1' <- r1 -> Just p
            { cpu1 = nextInstr $ modifyReg (const val) r (fromJust c1)
            , rcv1 = r1' }
    -- If this case is reached, there is either a deadlock or an
    -- illegal rcv instruction with an immediate operand, so we will
    -- terminate.
    (Just (Rcv _), Just (Rcv _)) -> Nothing
    -- If a CPU is blocked on rcv and the other has terminated, this
    -- is a deadlock; stop processing.
    (Just (Rcv _), Nothing) -> Nothing
    (Nothing, Just (Rcv _)) -> Nothing
    -- If one CPU is blocked on rcv, execute the instruction on the
    -- other (which is guaranteed by this point not to be snd or rcv,
    -- so we can use runInstruction).
    (Just (Rcv _), _) -> Just p { cpu1 = c1 >>= runInstruction }
    (_, Just (Rcv _)) -> Just p { cpu0 = c0 >>= runInstruction }
    -- If both CPUs have terminated, terminate the whole thing
    (Nothing, Nothing) -> Nothing
    -- This case only occurs when there are no snd or rcv instructions
    -- present, in which case we can fall back to runInstruction.
    _ -> Just p
      { cpu0 = c0 >>= runInstruction
      , cpu1 = c1 >>= runInstruction }

ListZipper.hs

module ListZipper
  ( ListZipper(..)
  , fromList
  , zipperNext
  , zipperPrev
  , zipperHead
  , replaceHead
  , moveZipper
  ) where

data ListZipper a = ListZipper ![a] ![a]
  deriving Show

fromList :: [a] -> ListZipper a
fromList l = ListZipper [] l

zipperNext :: ListZipper a -> Maybe (ListZipper a)
zipperNext (ListZipper _ []) = Nothing
zipperNext (ListZipper left (x:right)) = Just (ListZipper (x:left) right)

zipperPrev :: ListZipper a -> Maybe (ListZipper a)
zipperPrev (ListZipper [] _) = Nothing
zipperPrev (ListZipper (x:left) right) = Just (ListZipper left (x:right))

zipperHead :: ListZipper a -> Maybe a
zipperHead (ListZipper _ []) = Nothing
zipperHead (ListZipper _ (x:_)) = Just x

-- Note: Technically not total, but that would only complicate this
-- implementation.
replaceHead :: a -> ListZipper a -> ListZipper a
replaceHead new (ListZipper left (_:right)) = ListZipper left (new:right)

moveZipper :: Int -> ListZipper a -> Maybe (ListZipper a)
moveZipper n
  | n >= 0 = advance n
  | n < 0 = retract (-n)
  where
    advance 0 zipper = Just zipper
    advance n zipper = (zipperNext zipper) >>= advance (n - 1)
    retract 0 zipper = Just zipper
    retract n zipper = (zipperPrev zipper) >>= retract (n - 1)