{-# Language QuasiQuotes, TemplateHaskell, ImportQualifiedPost, DeriveFunctor #-}
{-|
Module      : Main
Description : Day 25 solution
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

<http://adventofcode.com/2017/day/25>

Implement a Turing Machine.

-}
module Main where

import Advent (format, stageTH)
import Advent.Fix (Fix(Fix), anaFromMap)
import Control.Applicative (many, some, (<|>))
import Data.IntSet (IntSet)
import Data.IntSet qualified as IntSet
import Data.Map qualified as Map

data D = Dleft | Dright
  deriving Int -> D -> ShowS
[D] -> ShowS
D -> String
(Int -> D -> ShowS) -> (D -> String) -> ([D] -> ShowS) -> Show D
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> D -> ShowS
showsPrec :: Int -> D -> ShowS
$cshow :: D -> String
show :: D -> String
$cshowList :: [D] -> ShowS
showList :: [D] -> ShowS
Show

stageTH

-- | Print the solution to the task. Input file can be overridden via
-- command-line arguments.
main :: IO ()
IO ()
main =
 do (Char
start, Int
iter, [(Char, Int, D, Char, Int, D, Char)]
rules) <- [format|2017 25
      Begin in state %c.%n
      Perform a diagnostic checksum after %d steps.%n
      (%n
      In state %c:%n
        If the current value is 0:%n
          - Write the value %d.%n
          - Move one slot to the @D.%n
          - Continue with state %c.%n
        If the current value is 1:%n
          - Write the value %d.%n
          - Move one slot to the @D.%n
          - Continue with state %c.%n)*|]

    let dirInt :: D -> a
dirInt D
Dleft = -a
1
        dirInt D
Dright = a
1
        writeBool :: a -> Bool
writeBool a
x = a
0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
x
        toRule :: (a, a, D, a, a, D, a) -> (a, Rule a)
toRule (a
s, a
w0, D
d0, a
s0, a
w1, D
d1, a
s1) =
          (a
s, Action a -> Action a -> Rule a
forall a. Action a -> Action a -> Rule a
Rule (Bool -> Int -> a -> Action a
forall a. Bool -> Int -> a -> Action a
Action (a -> Bool
forall {a}. (Eq a, Num a) => a -> Bool
writeBool a
w0) (D -> Int
forall {a}. Num a => D -> a
dirInt D
d0) a
s0) (Bool -> Int -> a -> Action a
forall a. Bool -> Int -> a -> Action a
Action (a -> Bool
forall {a}. (Eq a, Num a) => a -> Bool
writeBool a
w1) (D -> Int
forall {a}. Num a => D -> a
dirInt D
d1) a
s1))

    let program :: Fix Rule
program          = [(Char, Rule Char)] -> Char -> Fix Rule
buildProgram (((Char, Int, D, Char, Int, D, Char) -> (Char, Rule Char))
-> [(Char, Int, D, Char, Int, D, Char)] -> [(Char, Rule Char)]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Int, D, Char, Int, D, Char) -> (Char, Rule Char)
forall {a} {a} {a} {a}.
(Eq a, Eq a, Num a, Num a) =>
(a, a, D, a, a, D, a) -> (a, Rule a)
toRule [(Char, Int, D, Char, Int, D, Char)]
rules) Char
start
        machine :: Machine
machine          = IntSet -> Int -> Fix Rule -> Machine
Machine IntSet
forall a. Monoid a => a
mempty Int
0 Fix Rule
program
        Machine IntSet
tape Int
_ Fix Rule
_ = Int -> Machine -> Machine
steps Int
iter Machine
machine
        checksum :: Int
checksum         = IntSet -> Int
IntSet.size IntSet
tape

    Int -> IO ()
forall a. Show a => a -> IO ()
print Int
checksum

-- | Step a machine multiple iterations.
steps :: Int {- ^ iterations -} -> Machine -> Machine
steps :: Int -> Machine -> Machine
steps Int
0 Machine
m = Machine
m
steps Int
n Machine
m = Int -> Machine -> Machine
steps (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Machine -> Machine) -> Machine -> Machine
forall a b. (a -> b) -> a -> b
$! Machine -> Machine
step Machine
m

-- | Advance the tape machine a single step.
step :: Machine -> Machine
step :: Machine -> Machine
step (Machine IntSet
tape Int
cursor (Fix (Rule Action (Fix Rule)
a0 Action (Fix Rule)
a1))) =
  let Action Bool
v Int
d Fix Rule
p = if Int -> IntSet -> Bool
IntSet.member Int
cursor IntSet
tape then Action (Fix Rule)
a1 else Action (Fix Rule)
a0
  in IntSet -> Int -> Fix Rule -> Machine
Machine (Bool -> Int -> IntSet -> IntSet
updateSet Bool
v Int
cursor IntSet
tape) (Int
cursor Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) Fix Rule
p

-- | When the argument is 'True', insert the given number into the set,
-- otherwise remove it from the set.
updateSet :: Bool -> Int -> IntSet -> IntSet
updateSet :: Bool -> Int -> IntSet -> IntSet
updateSet Bool
True  = Int -> IntSet -> IntSet
IntSet.insert
updateSet Bool
False = Int -> IntSet -> IntSet
IntSet.delete

-- | The state of a machine: tape, cursor address, current program
data Machine = Machine !IntSet !Int !(Fix Rule)

-- | Transform a list of named rules into a single program.
buildProgram :: [(Char, Rule Char)] -> Char -> Fix Rule
buildProgram :: [(Char, Rule Char)] -> Char -> Fix Rule
buildProgram = Map Char (Rule Char) -> Char -> Fix Rule
forall k (f :: * -> *).
(Ord k, Functor f) =>
Map k (f k) -> k -> Fix f
anaFromMap (Map Char (Rule Char) -> Char -> Fix Rule)
-> ([(Char, Rule Char)] -> Map Char (Rule Char))
-> [(Char, Rule Char)]
-> Char
-> Fix Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Char, Rule Char)] -> Map Char (Rule Char)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

-- | A rule defines a single state. The first action is used when the
-- current value of the tape is 0, The second action is used when the
-- current value of the tape is 1. Actions are parameterized by the
-- type of program to jump to.
data Rule a = Rule (Action a) (Action a) deriving (Int -> Rule a -> ShowS
[Rule a] -> ShowS
Rule a -> String
(Int -> Rule a -> ShowS)
-> (Rule a -> String) -> ([Rule a] -> ShowS) -> Show (Rule a)
forall a. Show a => Int -> Rule a -> ShowS
forall a. Show a => [Rule a] -> ShowS
forall a. Show a => Rule a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Rule a -> ShowS
showsPrec :: Int -> Rule a -> ShowS
$cshow :: forall a. Show a => Rule a -> String
show :: Rule a -> String
$cshowList :: forall a. Show a => [Rule a] -> ShowS
showList :: [Rule a] -> ShowS
Show, (forall a b. (a -> b) -> Rule a -> Rule b)
-> (forall a b. a -> Rule b -> Rule a) -> Functor Rule
forall a b. a -> Rule b -> Rule a
forall a b. (a -> b) -> Rule a -> Rule b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Rule a -> Rule b
fmap :: forall a b. (a -> b) -> Rule a -> Rule b
$c<$ :: forall a b. a -> Rule b -> Rule a
<$ :: forall a b. a -> Rule b -> Rule a
Functor)

-- | An update action for a rule containing: the new tape value, an
-- offset to the cursor, and the next program state. Actions are
-- parameterized by the type of program to jump to.
data Action a = Action !Bool !Int a deriving (Int -> Action a -> ShowS
[Action a] -> ShowS
Action a -> String
(Int -> Action a -> ShowS)
-> (Action a -> String) -> ([Action a] -> ShowS) -> Show (Action a)
forall a. Show a => Int -> Action a -> ShowS
forall a. Show a => [Action a] -> ShowS
forall a. Show a => Action a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Action a -> ShowS
showsPrec :: Int -> Action a -> ShowS
$cshow :: forall a. Show a => Action a -> String
show :: Action a -> String
$cshowList :: forall a. Show a => [Action a] -> ShowS
showList :: [Action a] -> ShowS
Show, (forall a b. (a -> b) -> Action a -> Action b)
-> (forall a b. a -> Action b -> Action a) -> Functor Action
forall a b. a -> Action b -> Action a
forall a b. (a -> b) -> Action a -> Action b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Action a -> Action b
fmap :: forall a b. (a -> b) -> Action a -> Action b
$c<$ :: forall a b. a -> Action b -> Action a
<$ :: forall a b. a -> Action b -> Action a
Functor)