Now using the RWS monad stack

diff --git a/advent05/package.yaml b/advent05/package.yaml
index 1d04271b5fedc42f29c0cb94928dd6d1ba1c0444..20dde1143aa992244bd6b3935b3de6bb9f8f40d4 100644 (file)
--- a/advent05/package.yaml
+++ b/advent05/package.yaml
@@ -59,3 +59,13 @@ executables:
     - megaparsec
     - containers
     - mtl
+
+  advent05rws:
+    main: advent05rws.hs
+    source-dirs: src
+    dependencies:
+    - base >= 2 && < 6
+    - text
+    - megaparsec
+    - containers
+    - mtl

diff --git a/advent05/src/advent05.hs b/advent05/src/advent05.hs
index 36ba4995b8537ae37a566eab328353284dc7095d..2368edbdad7b38ca544d9046d582dd298bc41a15 100644 (file)
--- a/advent05/src/advent05.hs
+++ b/advent05/src/advent05.hs
@@ -69,7 +69,7 @@ runStep =
     do mem <- gets _memory
        ip <- gets _ip
        let opcode = (mem!ip) `mod` 100
-       let modes = parameterModes  ((mem!ip) `div` 100)
+       let modes = parameterModes ((mem!ip) `div` 100)
        fetchInput opcode
        putOutput opcode modes
        mem' <- gets _memory

diff --git a/advent05/src/advent05rws.hs b/advent05/src/advent05rws.hs
new file mode 100644 (file)
index 0000000..b82bbf7
--- /dev/null
+++ b/advent05/src/advent05rws.hs
@@ -0,0 +1,170 @@
+import Debug.Trace
+
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+
+import Data.Void (Void)
+
+import Text.Megaparsec hiding (State)
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import qualified Control.Applicative as CA
+
+import Control.Monad (unless)
+import Control.Monad.State.Strict
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.RWS.Strict
+
+
+import qualified Data.IntMap.Strict as M
+import Data.IntMap.Strict ((!))
+import Data.List
+
+type Memory = M.IntMap Int
+
+data Machine = Machine { _memory :: Memory
+                       , _ip :: Int
+                       , _inputIndex :: Int
+                       } 
+               deriving (Show, Eq)
+
+type ProgrammedMachine = RWS [Int] [Int] Machine ()
+
+data ParameterMode = Position | Immediate deriving (Ord, Eq, Show)
+
+
+main :: IO ()
+main = do 
+        text <- TIO.readFile "data/advent05.txt"
+        let mem = successfulParse text
+        print $ findMachineOutput [1] mem
+        print $ findMachineOutput [5] mem
+
+findMachineOutput :: [Int] -> [Int] -> Int
+findMachineOutput inputs program = last output
+    where (_machine, output) = execRWS runAll inputs (makeMachine program)
+
+
+makeMachine :: [Int] -> Machine
+makeMachine memory = Machine    {_ip = 0, _inputIndex = 0
+                                , _memory = M.fromList $ zip [0..] memory
+                                }
+
+
+runAll :: ProgrammedMachine
+runAll = do mem <- gets _memory
+            ip <- gets _ip
+            unless (mem!ip == 99)
+                do runStep
+                   runAll
+
+runStep :: ProgrammedMachine
+runStep = 
+    do mem <- gets _memory
+       ip <- gets _ip
+       let opcode = (mem!ip) `mod` 100
+       let modes = parameterModes ((mem!ip) `div` 100)
+       fetchInput opcode
+       putOutput opcode modes
+       mem' <- gets _memory
+       let (mem'', ip') = perform opcode ip modes mem'
+       modify (\m -> m {_ip = ip', _memory = mem''})
+
+
+-- fetchInput opcode | trace ("Input with opcode " ++ show opcode) False = undefined
+fetchInput 3 =
+    do mem <- gets _memory
+       ip <- gets _ip
+       inputIndex <- gets _inputIndex
+       inputs <- ask 
+       let mem' = iInsert (ip + 1) (inputs!!inputIndex) mem
+       modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
+fetchInput _ = return ()
+
+
+-- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
+putOutput 4 modes =
+    do mem <- gets _memory
+       ip <- gets _ip
+       let v = getMemoryValue (ip + 1) (modes!!0) mem
+       tell [v]
+putOutput _ _ = return ()       
+
+
+perform :: Int -> Int -> [ParameterMode] -> Memory -> (Memory, Int)
+-- perform instr ip modes mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined
+perform 1 ip modes mem = (iInsert (ip + 3) (a + b) mem, ip + 4)
+    where a = getMemoryValue (ip + 1) (modes!!0) mem
+          b = getMemoryValue (ip + 2) (modes!!1) mem
+perform 2 ip modes mem = (iInsert (ip + 3) (a * b) mem, ip + 4)
+    where a = getMemoryValue (ip + 1) (modes!!0) mem
+          b = getMemoryValue (ip + 2) (modes!!1) mem
+perform 3 ip _ mem = (mem, ip + 2)
+perform 4 ip _ mem = (mem, ip + 2)
+perform 5 ip modes mem = (mem, ip')
+    where a = getMemoryValue (ip + 1) (modes!!0) mem
+          b = getMemoryValue (ip + 2) (modes!!1) mem
+          ip' = if a /= 0 then b else ip + 3
+perform 6 ip modes mem = (mem, ip')
+    where a = getMemoryValue (ip + 1) (modes!!0) mem
+          b = getMemoryValue (ip + 2) (modes!!1) mem
+          ip' = if a == 0 then b else ip + 3
+perform 7 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
+    where a = getMemoryValue (ip + 1) (modes!!0) mem
+          b = getMemoryValue (ip + 2) (modes!!1) mem
+          res = if a < b then 1 else 0
+perform 8 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
+    where a = getMemoryValue (ip + 1) (modes!!0) mem
+          b = getMemoryValue (ip + 2) (modes!!1) mem
+          res = if a == b then 1 else 0
+perform _ ip _ mem = (mem, ip)
+
+
+getMemoryValue loc Position mem = mem!>loc
+getMemoryValue loc Immediate mem = mem!loc
+
+
+parameterModes :: Int -> [ParameterMode]
+parameterModes modeCode = unfoldr generateMode modeCode
+
+generateMode :: Int -> Maybe (ParameterMode, Int)
+generateMode modeCode = Just (mode, modeCode `div` 10)
+    where mode = case (modeCode `mod` 10) of 
+                    0 -> Position
+                    1 -> Immediate
+
+
+-- Some IntMap utility functions, for syntactic sugar
+
+-- prefix version of (!)
+lkup k m = m!k
+
+-- indirect lookup
+(!>) m k = m!(m!k)
+
+-- indirect insert
+iInsert k v m = M.insert (m!k) v m
+
+
+
+-- Parse the input file
+type Parser = Parsec Void Text
+
+sc :: Parser ()
+sc = L.space (skipSome spaceChar) CA.empty CA.empty
+-- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
+
+lexeme  = L.lexeme sc
+integer = lexeme L.decimal
+signedInteger = L.signed sc integer
+symb = L.symbol sc
+comma = symb ","
+
+memoryP = signedInteger `sepBy` comma
+
+successfulParse :: Text -> [Int]
+successfulParse input = 
+        case parse memoryP "input" input of
+                Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
+                Right memory -> memory
\ No newline at end of file