-- |
-- Module      : AOC.Challenge.Day08
-- License     : BSD3
--
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 8.  See "AOC.Solver" for the types used in this module!

module AOC.Challenge.Day08 (
    day08a
  , day08b
  ) where

import           AOC.Common               (perturbationsBy, CharParser, parseLines, pDecimal)
import           AOC.Solver               ((:~>)(..))
import           Control.DeepSeq          (NFData)
import           Control.Lens             (_1, Ixed(..), Index, IxValue, (^?))
import           Data.IntSet              (IntSet)
import           Data.Maybe               (listToMaybe)
import           Data.Vector              (Vector)
import           GHC.Generics             (Generic)
import qualified Data.Functor.Foldable    as R
import qualified Data.Functor.Foldable.TH as R
import qualified Data.IntSet              as IS
import qualified Data.Vector              as V
import qualified Text.Megaparsec          as P
import qualified Text.Megaparsec.Char     as P

data Instr = NOP | ACC | JMP
  deriving ((forall x. Instr -> Rep Instr x)
-> (forall x. Rep Instr x -> Instr) -> Generic Instr
forall x. Rep Instr x -> Instr
forall x. Instr -> Rep Instr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Instr x -> Instr
$cfrom :: forall x. Instr -> Rep Instr x
Generic, Instr -> Instr -> Bool
(Instr -> Instr -> Bool) -> (Instr -> Instr -> Bool) -> Eq Instr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Instr -> Instr -> Bool
$c/= :: Instr -> Instr -> Bool
== :: Instr -> Instr -> Bool
$c== :: Instr -> Instr -> Bool
Eq, Eq Instr
Eq Instr
-> (Instr -> Instr -> Ordering)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Instr)
-> (Instr -> Instr -> Instr)
-> Ord Instr
Instr -> Instr -> Bool
Instr -> Instr -> Ordering
Instr -> Instr -> Instr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Instr -> Instr -> Instr
$cmin :: Instr -> Instr -> Instr
max :: Instr -> Instr -> Instr
$cmax :: Instr -> Instr -> Instr
>= :: Instr -> Instr -> Bool
$c>= :: Instr -> Instr -> Bool
> :: Instr -> Instr -> Bool
$c> :: Instr -> Instr -> Bool
<= :: Instr -> Instr -> Bool
$c<= :: Instr -> Instr -> Bool
< :: Instr -> Instr -> Bool
$c< :: Instr -> Instr -> Bool
compare :: Instr -> Instr -> Ordering
$ccompare :: Instr -> Instr -> Ordering
Ord, Int -> Instr -> ShowS
[Instr] -> ShowS
Instr -> String
(Int -> Instr -> ShowS)
-> (Instr -> String) -> ([Instr] -> ShowS) -> Show Instr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instr] -> ShowS
$cshowList :: [Instr] -> ShowS
show :: Instr -> String
$cshow :: Instr -> String
showsPrec :: Int -> Instr -> ShowS
$cshowsPrec :: Int -> Instr -> ShowS
Show)
instance NFData Instr

type Command = (Instr, Int)

instrParser :: CharParser Instr
instrParser :: CharParser Instr
instrParser = [CharParser Instr] -> CharParser Instr
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
    [ Instr
NOP Instr -> ParsecT Void String Identity String -> CharParser Instr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string String
Tokens String
"nop"
    , Instr
ACC Instr -> ParsecT Void String Identity String -> CharParser Instr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string String
Tokens String
"acc"
    , Instr
JMP Instr -> ParsecT Void String Identity String -> CharParser Instr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string String
Tokens String
"jmp"
    ]

commandParser :: CharParser Command
commandParser :: CharParser Command
commandParser = (,) (Instr -> Int -> Command)
-> CharParser Instr
-> ParsecT Void String Identity (Int -> Command)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CharParser Instr
instrParser CharParser Instr
-> ParsecT Void String Identity () -> CharParser Instr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
P.space) ParsecT Void String Identity (Int -> Command)
-> ParsecT Void String Identity Int -> CharParser Command
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void String Identity Int
forall s e a.
(Stream s, Token s ~ Char, Ord e, Num a) =>
Parsec e s a
pDecimal

-- RIP explicit state

-- data CState = CS { csPtr :: !Int, csAcc :: !Int }
--   deriving (Generic, Show)
-- instance NFData CState

-- initialCS :: CState
-- initialCS = CS 0 0

-- runCommand
--     :: (Ixed t, Index t ~ Int, IxValue t ~ (Instr, Int))
--     => t
--     -> CState
--     -> Maybe CState
-- runCommand cmds cs = (cmds ^? ix (csPtr cs)) <&> \case
--     (NOP, _) -> cs & #csPtr +~ 1
--     (ACC, i) -> cs & #csPtr +~ 1
--                    & #csAcc +~ i
--     (JMP, i) -> cs & #csPtr +~ i

data EndType = Halt | Loop
  deriving ((forall x. EndType -> Rep EndType x)
-> (forall x. Rep EndType x -> EndType) -> Generic EndType
forall x. Rep EndType x -> EndType
forall x. EndType -> Rep EndType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EndType x -> EndType
$cfrom :: forall x. EndType -> Rep EndType x
Generic, EndType -> EndType -> Bool
(EndType -> EndType -> Bool)
-> (EndType -> EndType -> Bool) -> Eq EndType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EndType -> EndType -> Bool
$c/= :: EndType -> EndType -> Bool
== :: EndType -> EndType -> Bool
$c== :: EndType -> EndType -> Bool
Eq, Eq EndType
Eq EndType
-> (EndType -> EndType -> Ordering)
-> (EndType -> EndType -> Bool)
-> (EndType -> EndType -> Bool)
-> (EndType -> EndType -> Bool)
-> (EndType -> EndType -> Bool)
-> (EndType -> EndType -> EndType)
-> (EndType -> EndType -> EndType)
-> Ord EndType
EndType -> EndType -> Bool
EndType -> EndType -> Ordering
EndType -> EndType -> EndType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EndType -> EndType -> EndType
$cmin :: EndType -> EndType -> EndType
max :: EndType -> EndType -> EndType
$cmax :: EndType -> EndType -> EndType
>= :: EndType -> EndType -> Bool
$c>= :: EndType -> EndType -> Bool
> :: EndType -> EndType -> Bool
$c> :: EndType -> EndType -> Bool
<= :: EndType -> EndType -> Bool
$c<= :: EndType -> EndType -> Bool
< :: EndType -> EndType -> Bool
$c< :: EndType -> EndType -> Bool
compare :: EndType -> EndType -> Ordering
$ccompare :: EndType -> EndType -> Ordering
Ord, Int -> EndType -> ShowS
[EndType] -> ShowS
EndType -> String
(Int -> EndType -> ShowS)
-> (EndType -> String) -> ([EndType] -> ShowS) -> Show EndType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EndType] -> ShowS
$cshowList :: [EndType] -> ShowS
show :: EndType -> String
$cshow :: EndType -> String
showsPrec :: Int -> EndType -> ShowS
$cshowsPrec :: Int -> EndType -> ShowS
Show)
instance NFData EndType

data AccStream = EndAcc EndType | Step AccStream | Acc Int AccStream
R.makeBaseFunctor ''AccStream

-- | Unfold an 'AccStream' over a program bank (@t@), given a seen-items
-- list and the current instruction pointer.
vmStreamCoalg
    :: (Ixed t, Index t ~ Int, IxValue t ~ (Instr, Int))
    => t
    -> (IntSet, Int)
    -> AccStreamF (IntSet, Int)
vmStreamCoalg :: forall t.
(Ixed t, Index t ~ Int, IxValue t ~ Command) =>
t -> (IntSet, Int) -> AccStreamF (IntSet, Int)
vmStreamCoalg t
cmds (!IntSet
seen, !Int
i)
    | Int
i Int -> IntSet -> Bool
`IS.member` IntSet
seen = EndType -> AccStreamF (IntSet, Int)
forall r. EndType -> AccStreamF r
EndAccF EndType
Loop
    | Bool
otherwise          = case t
cmds t -> Getting (First Command) t Command -> Maybe Command
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index t -> Traversal' t (IxValue t)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index t
i of
        Maybe Command
Nothing  -> EndType -> AccStreamF (IntSet, Int)
forall r. EndType -> AccStreamF r
EndAccF EndType
Halt
        Just Command
cmd -> case Command
cmd of
          (Instr
NOP, Int
_) -> (IntSet, Int) -> AccStreamF (IntSet, Int)
forall r. r -> AccStreamF r
StepF  (IntSet
seen', Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          (Instr
ACC, Int
n) -> Int -> (IntSet, Int) -> AccStreamF (IntSet, Int)
forall r. Int -> r -> AccStreamF r
AccF Int
n (IntSet
seen', Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          (Instr
JMP, Int
n) -> (IntSet, Int) -> AccStreamF (IntSet, Int)
forall r. r -> AccStreamF r
StepF  (IntSet
seen', Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)
  where
    seen' :: IntSet
seen' = Int
i Int -> IntSet -> IntSet
`IS.insert` IntSet
seen

-- | Collapse an 'AccStream' to get the sum and the end state.
sumStreamAlg
    :: AccStreamF (EndType, Int)
    -> (EndType, Int)
sumStreamAlg :: AccStreamF (EndType, Int) -> (EndType, Int)
sumStreamAlg = \case
    EndAccF EndType
es      -> (EndType
es, Int
0)
    StepF (EndType, Int)
a         -> (EndType, Int)
a
    AccF Int
n (EndType
es, !Int
x) -> (EndType
es, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

exhaustVM
    :: (Ixed t, Index t ~ Int, IxValue t ~ (Instr, Int))
    => t
    -> (EndType, Int)
exhaustVM :: forall t.
(Ixed t, Index t ~ Int, IxValue t ~ Command) =>
t -> (EndType, Int)
exhaustVM t
cmds = (AccStreamF (EndType, Int) -> (EndType, Int))
-> ((IntSet, Int) -> AccStreamF (IntSet, Int))
-> (IntSet, Int)
-> (EndType, Int)
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
R.hylo AccStreamF (EndType, Int) -> (EndType, Int)
sumStreamAlg (t -> (IntSet, Int) -> AccStreamF (IntSet, Int)
forall t.
(Ixed t, Index t ~ Int, IxValue t ~ Command) =>
t -> (IntSet, Int) -> AccStreamF (IntSet, Int)
vmStreamCoalg t
cmds) (IntSet
IS.empty, Int
0)

day08a :: Vector Command :~> Int
day08a :: Vector Command :~> Int
day08a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (Vector Command)
sParse = ([Command] -> Vector Command)
-> Maybe [Command] -> Maybe (Vector Command)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Command] -> Vector Command
forall a. [a] -> Vector a
V.fromList (Maybe [Command] -> Maybe (Vector Command))
-> (String -> Maybe [Command]) -> String -> Maybe (Vector Command)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharParser Command -> String -> Maybe [Command]
forall a. Parsec Void String a -> String -> Maybe [a]
parseLines CharParser Command
commandParser
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => Vector Command -> Maybe Int
sSolve = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> (Vector Command -> Int) -> Vector Command -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EndType, Int) -> Int
forall a b. (a, b) -> b
snd ((EndType, Int) -> Int)
-> (Vector Command -> (EndType, Int)) -> Vector Command -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Command -> (EndType, Int)
forall t.
(Ixed t, Index t ~ Int, IxValue t ~ Command) =>
t -> (EndType, Int)
exhaustVM
    }

day08b :: Vector Command :~> Int
day08b :: Vector Command :~> Int
day08b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (Vector Command)
sParse = ([Command] -> Vector Command)
-> Maybe [Command] -> Maybe (Vector Command)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Command] -> Vector Command
forall a. [a] -> Vector a
V.fromList (Maybe [Command] -> Maybe (Vector Command))
-> (String -> Maybe [Command]) -> String -> Maybe (Vector Command)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharParser Command -> String -> Maybe [Command]
forall a. Parsec Void String a -> String -> Maybe [a]
parseLines CharParser Command
commandParser
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => Vector Command -> Maybe Int
sSolve = \Vector Command
cmds0 -> [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [
          Int
i
        | Vector Command
cmds <- Over
  (->)
  (Bazaar (->) Instr Instr)
  (Vector Command)
  (Vector Command)
  Instr
  Instr
-> (Instr -> [Instr]) -> Vector Command -> [Vector Command]
forall (p :: * -> * -> *) a s t.
Conjoined p =>
Over p (Bazaar p a a) s t a a -> (a -> [a]) -> s -> [t]
perturbationsBy ((Command -> Bazaar (->) Instr Instr Command)
-> Vector Command -> Bazaar (->) Instr Instr (Vector Command)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Command -> Bazaar (->) Instr Instr Command)
 -> Vector Command -> Bazaar (->) Instr Instr (Vector Command))
-> ((Instr -> Bazaar (->) Instr Instr Instr)
    -> Command -> Bazaar (->) Instr Instr Command)
-> Over
     (->)
     (Bazaar (->) Instr Instr)
     (Vector Command)
     (Vector Command)
     Instr
     Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instr -> Bazaar (->) Instr Instr Instr)
-> Command -> Bazaar (->) Instr Instr Command
forall s t a b. Field1 s t a b => Lens s t a b
_1) Instr -> [Instr]
perturbs Vector Command
cmds0
        , let (EndType
es, Int
i) = Vector Command -> (EndType, Int)
forall t.
(Ixed t, Index t ~ Int, IxValue t ~ Command) =>
t -> (EndType, Int)
exhaustVM Vector Command
cmds
        , EndType
es EndType -> EndType -> Bool
forall a. Eq a => a -> a -> Bool
== EndType
Halt
        ]
    }
  where
    perturbs :: Instr -> [Instr]
perturbs = \case
      Instr
NOP -> [Instr
JMP]
      Instr
ACC -> []
      Instr
JMP -> [Instr
NOP]