adventofcode1625/app/advent25.hs

   1 module Main(main) where
   2
   3 import Text.Parsec hiding (State)
   4 import Text.ParserCombinators.Parsec.Number
   5 import Control.Monad.State.Lazy
   6
   7 -- import Control.Monad.Writer
   8 import Control.Monad.Reader
   9 import Debug.Trace
  10
  11 data Location = Literal Int | Register Char deriving (Show, Eq)
  12 data Instruction =   Cpy Location Location
  13                    | Inc Location
  14                    | Dec Location
  15                    | Jnz Location Location
  16                    | Tgl Location
  17                    | Out Location
  18                    deriving (Show, Eq)
  19
  20 data Machine = Machine { a :: Int
  21                        , b :: Int
  22                        , c :: Int
  23                        , d :: Int
  24                        , pc :: Int
  25                        , instructions :: [Instruction]
  26                        , execCount :: Int
  27                        }
  28                deriving (Show, Eq)
  29
  30 data AppConfig = AppConfig { cfgMaxRun :: Int } deriving (Show)
  31
  32
  33 type App = ReaderT AppConfig (State Machine) String
  34
  35
  36 testInstructions1 = "\
  37 \cpy 5 d\n\
  38 \cpy 7 c\n\
  39 \cpy 362 b\n\
  40 \inc d\n\
  41 \dec b\n\
  42 \jnz b -2\n\
  43 \dec c\n\
  44 \jnz c -5\n\
  45 \out d"
  46
  47 testInstructions2 = "jnz 1 0"
  48
  49 target :: String
  50 target = cycle "01"
  51
  52 emptyMachine :: Machine
  53 emptyMachine = Machine {a=0, b=0, c=0, d=0, pc=0, instructions=[], execCount=0}
  54
  55 main :: IO ()
  56 main = do
  57     text <- readFile "data/advent25.txt"
  58     -- let text = testInstructions1
  59     let instructions = successfulParse $ parseIfile text
  60     part1 instructions
  61
  62
  63 part1 :: [Instruction] -> IO ()
  64 part1 instrs =
  65     print $ head validInputs
  66     where m0 = emptyMachine {instructions=instrs}
  67           inputs = [0..]
  68           validInputs = filter (validMachine) inputs
  69           validMachine i = valid $ evalMachine m0 i
  70     -- let config = AppConfig {cfgMaxRun = 500000}
  71     --     m0 = emptyMachine {instructions=instrs}
  72     --     -- res = runState (runReaderT (runMachine "") config) st
  73     --     res = evalState (runReaderT (runMachine "") config) m0
  74     -- in print res -- (signal, st')
  75
  76
  77 valid :: String -> Bool
  78 valid output = all (\p -> fst p == snd p) $ zip target output
  79
  80 evalMachine :: Machine -> Int -> String
  81 evalMachine machine0 input = evalState (runReaderT (runMachine "") config) m
  82     where m = machine0 {a = input}
  83           config = AppConfig {cfgMaxRun = 500000}
  84
  85 runMachine :: String -> App -- State Machine String
  86 runMachine output =
  87     do  cfg <- ask
  88         m <- get
  89         if (pc m) >= (length $ instructions m) || execCount m > cfgMaxRun cfg
  90             then return output
  91             else do thisOutput <- executeStep
  92                     runMachine (output ++ thisOutput)
  93
  94
  95 executeStep :: App -- State Machine String
  96 executeStep =
  97     do  m <- get
  98         let i = (instructions m)!!(pc m)
  99         let output = generateOutput i m
 100         put (executeInstructionPeep i m) {execCount = (execCount m) + 1}
 101         -- put (executeInstruction i m) {execCount = (execCount m) + 1}
 102         return output
 103
 104 generateOutput :: Instruction -> Machine -> String
 105 generateOutput (Out a) m = show $ evaluate m a
 106 generateOutput _ _ = ""
 107
 108 executeInstructionPeep :: Instruction -> Machine -> Machine
 109 executeInstructionPeep i m =
 110     if sample == sampleTarget
 111         -- then trace ("Peeping 1 " ++ (show m) ++ " to " ++ (show m1)) m1
 112         then m1
 113         else executeInstruction i m
 114     where sample = take (length sampleTarget) $ drop (pc m) $ instructions m
 115           sampleTarget = [  Inc (Register 'd')
 116                           , Dec (Register 'b')
 117                           , Jnz (Register 'b') (Literal (-2))
 118                           , Dec (Register 'c')
 119                           , Jnz (Register 'c') (Literal (-5)) ]
 120           m1 = m {d = d m + c m * b m, c = 0, b = 0, pc = pc m + (length sample)}
 121
 122
 123 executeInstruction :: Instruction -> Machine -> Machine
 124 executeInstruction (Inc r@(Register _)) m = m' {pc=pc1}
 125     where pc1 = (pc m) + 1
 126           v = evaluate m r
 127           m' = writeValue m r (v+1)
 128 executeInstruction (Inc (Literal _)) m = m {pc=pc1}
 129     where pc1 = (pc m) + 1
 130 executeInstruction (Dec r@(Register _)) m = m' {pc=pc1}
 131     where pc1 = (pc m) + 1
 132           v = evaluate m r
 133           m' = writeValue m r (v-1)
 134 executeInstruction (Dec (Literal _)) m = m {pc=pc1}
 135     where pc1 = (pc m) + 1
 136 executeInstruction (Cpy s d@(Register _)) m = m' {pc=pc1}
 137     where pc1 = (pc m) + 1
 138           v = evaluate m s
 139           m' = writeValue m d v
 140 executeInstruction (Cpy s (Literal _)) m = m {pc=pc1}
 141     where pc1 = (pc m) + 1
 142 executeInstruction (Jnz s d) m
 143     | v == 0 = m {pc=pc1}
 144     | otherwise = m {pc=pcj}
 145     where pc1 = (pc m) + 1
 146           ed = evaluate m d
 147           pcj = (pc m) + ed
 148           v = evaluate m s
 149 executeInstruction (Tgl a) m
 150     | v < (length $ instructions m) = m {instructions = (replace (instructions m) i' v),
 151                                        pc=pc1}
 152     | otherwise = m {pc=pc1}
 153     where pc1 = pc m + 1
 154           v = evaluate m a + pc m
 155           i = (instructions m)!!v
 156           i' = case i of
 157                   Inc x -> Dec x
 158                   Dec x -> Inc x
 159                   Tgl x -> Inc x
 160                   Cpy x y -> Jnz x y
 161                   Jnz x y -> Cpy x y
 162           replace xs x i = take i xs ++ [x] ++ drop (i+1) xs
 163 executeInstruction (Out _) m = m {pc = pc m + 1}
 164
 165
 166 evaluate :: Machine -> Location -> Int
 167 evaluate _ (Literal i) = i
 168 evaluate m (Register r) =
 169     case r of
 170         'a' -> (a m)
 171         'b' -> (b m)
 172         'c' -> (c m)
 173         'd' -> (d m)
 174
 175 writeValue :: Machine -> Location -> Int -> Machine
 176 writeValue m (Literal i) _ = m
 177 writeValue m (Register r) v =
 178     case r of
 179         'a' -> m {a=v}
 180         'b' -> m {b=v}
 181         'c' -> m {c=v}
 182         'd' -> m {d=v}
 183
 184
 185 instructionFile = instructionLine `sepEndBy` newline
 186 instructionLine = incL <|> decL <|> cpyL <|> jnzL <|> tglL <|> outL
 187
 188 incL = Inc <$> (string "inc" *> spaces *> register)
 189 decL = Dec <$> (string "dec" *> spaces *> register)
 190 cpyL = Cpy <$> (string "cpy" *> spaces *> location) <*> (spaces *> register)
 191 jnzL = Jnz <$> (string "jnz" *> spaces *> location) <*> (spaces *> location)
 192 tglL = Tgl <$> (string "tgl" *> spaces *> location)
 193 outL = Out <$> (string "out" *> spaces *> location)
 194
 195 location = (Literal <$> int) <|> register
 196 register = Register <$> (oneOf "abcd")
 197
 198 parseIfile :: String -> Either ParseError [Instruction]
 199 parseIfile input = parse instructionFile "(unknown)" input
 200
 201 parseIline :: String -> Either ParseError Instruction
 202 parseIline input = parse instructionLine "(unknown)" input
 203
 204 successfulParse :: Either ParseError [a] -> [a]
 205 successfulParse (Left _) = []
 206 successfulParse (Right a) = a