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
  71
  72 valid :: String -> Bool
  73 valid output = all (\p -> fst p == snd p) $ zip target output
  74
  75 evalMachine :: Machine -> Int -> String
  76 evalMachine machine0 input = evalState (runReaderT (runMachine "") config) m
  77     where m = machine0 {a = input}
  78           config = AppConfig {cfgMaxRun = 500000}
  79
  80 runMachine :: String -> App
  81 runMachine output =
  82     do  cfg <- ask
  83         m <- get
  84         if (pc m) >= (length $ instructions m) || execCount m > cfgMaxRun cfg
  85             then return output
  86             else do thisOutput <- executeStep
  87                     runMachine (output ++ thisOutput)
  88
  89
  90 executeStep :: App
  91 executeStep =
  92     do  m <- get
  93         let i = (instructions m)!!(pc m)
  94         let output = generateOutput i m
  95         put (executeInstructionPeep i m) {execCount = (execCount m) + 1}
  96         -- put (executeInstruction i m) {execCount = (execCount m) + 1}
  97         return output
  98
  99 generateOutput :: Instruction -> Machine -> String
 100 generateOutput (Out a) m = show $ evaluate m a
 101 generateOutput _ _ = ""
 102
 103 executeInstructionPeep :: Instruction -> Machine -> Machine
 104 executeInstructionPeep i m =
 105     if sample == sampleTarget
 106         -- then trace ("Peeping 1 " ++ (show m) ++ " to " ++ (show m1)) m1
 107         then m1
 108         else executeInstruction i m
 109     where sample = take (length sampleTarget) $ drop (pc m) $ instructions m
 110           sampleTarget = [  Inc (Register 'd')
 111                           , Dec (Register 'b')
 112                           , Jnz (Register 'b') (Literal (-2))
 113                           , Dec (Register 'c')
 114                           , Jnz (Register 'c') (Literal (-5)) ]
 115           m1 = m {d = d m + c m * b m, c = 0, b = 0, pc = pc m + (length sample)}
 116
 117
 118 executeInstruction :: Instruction -> Machine -> Machine
 119 executeInstruction (Inc r@(Register _)) m = m' {pc=pc1}
 120     where pc1 = (pc m) + 1
 121           v = evaluate m r
 122           m' = writeValue m r (v+1)
 123 executeInstruction (Inc (Literal _)) m = m {pc=pc1}
 124     where pc1 = (pc m) + 1
 125 executeInstruction (Dec r@(Register _)) m = m' {pc=pc1}
 126     where pc1 = (pc m) + 1
 127           v = evaluate m r
 128           m' = writeValue m r (v-1)
 129 executeInstruction (Dec (Literal _)) m = m {pc=pc1}
 130     where pc1 = (pc m) + 1
 131 executeInstruction (Cpy s d@(Register _)) m = m' {pc=pc1}
 132     where pc1 = (pc m) + 1
 133           v = evaluate m s
 134           m' = writeValue m d v
 135 executeInstruction (Cpy s (Literal _)) m = m {pc=pc1}
 136     where pc1 = (pc m) + 1
 137 executeInstruction (Jnz s d) m
 138     | v == 0 = m {pc=pc1}
 139     | otherwise = m {pc=pcj}
 140     where pc1 = (pc m) + 1
 141           ed = evaluate m d
 142           pcj = (pc m) + ed
 143           v = evaluate m s
 144 executeInstruction (Tgl a) m
 145     | v < (length $ instructions m) = m {instructions = (replace (instructions m) i' v),
 146                                        pc=pc1}
 147     | otherwise = m {pc=pc1}
 148     where pc1 = pc m + 1
 149           v = evaluate m a + pc m
 150           i = (instructions m)!!v
 151           i' = case i of
 152                   Inc x -> Dec x
 153                   Dec x -> Inc x
 154                   Tgl x -> Inc x
 155                   Cpy x y -> Jnz x y
 156                   Jnz x y -> Cpy x y
 157           replace xs x i = take i xs ++ [x] ++ drop (i+1) xs
 158 executeInstruction (Out _) m = m {pc = pc m + 1}
 159
 160
 161 evaluate :: Machine -> Location -> Int
 162 evaluate _ (Literal i) = i
 163 evaluate m (Register r) =
 164     case r of
 165         'a' -> (a m)
 166         'b' -> (b m)
 167         'c' -> (c m)
 168         'd' -> (d m)
 169
 170 writeValue :: Machine -> Location -> Int -> Machine
 171 writeValue m (Literal i) _ = m
 172 writeValue m (Register r) v =
 173     case r of
 174         'a' -> m {a=v}
 175         'b' -> m {b=v}
 176         'c' -> m {c=v}
 177         'd' -> m {d=v}
 178
 179
 180 instructionFile = instructionLine `sepEndBy` newline
 181 instructionLine = incL <|> decL <|> cpyL <|> jnzL <|> tglL <|> outL
 182
 183 incL = Inc <$> (string "inc" *> spaces *> register)
 184 decL = Dec <$> (string "dec" *> spaces *> register)
 185 cpyL = Cpy <$> (string "cpy" *> spaces *> location) <*> (spaces *> register)
 186 jnzL = Jnz <$> (string "jnz" *> spaces *> location) <*> (spaces *> location)
 187 tglL = Tgl <$> (string "tgl" *> spaces *> location)
 188 outL = Out <$> (string "out" *> spaces *> location)
 189
 190 location = (Literal <$> int) <|> register
 191 register = Register <$> (oneOf "abcd")
 192
 193 parseIfile :: String -> Either ParseError [Instruction]
 194 parseIfile input = parse instructionFile "(unknown)" input
 195
 196 parseIline :: String -> Either ParseError Instruction
 197 parseIline input = parse instructionLine "(unknown)" input
 198
 199 successfulParse :: Either ParseError [a] -> [a]
 200 successfulParse (Left _) = []
 201 successfulParse (Right a) = a