101714e0bae87028fab082b2e55f4cbd4ca45f01
[synacor-challenge.git] / src / Main.hs
1 import SynacorEngine
2
3 -- import Debug.Trace
4
5 -- import Numeric
6 import System.IO
7 import Data.Char
8 import Data.List
9 import qualified Data.Map.Strict as M
10 -- import Data.Map.Strict ((!))
11 import Control.Lens -- hiding ((<|), (|>), (:>), (:<), indices)
12
13 import Control.Monad.State.Strict hiding (state)
14 -- import Control.Monad.Reader
15 -- import Control.Monad.Writer
16 -- import Control.Monad.RWS.Strict hiding (state)
17
18 -- import Data.Bits
19 import Data.Word
20 import Data.Binary.Get
21 import qualified Data.ByteString.Lazy as BL
22
23
24 data SynacorState = SynacorState
25 { _ssMachines :: [Machine]
26 , _ssInputs :: [String]
27 , _ssOutputs :: [String]
28 , _ssContinue :: Bool
29 , _ssUnsaved :: Bool
30 , _ssState :: [ExecutionState]
31 , _ssTracing :: Bool
32 , _ssDumpFile :: String
33 } deriving (Ord, Eq)
34 makeLenses ''SynacorState
35
36 instance Show SynacorState
37 where
38 show state =
39 intercalate ", "
40 [ "SynacorState"
41 , (show (length (state ^. ssMachines)) ++ " machines")
42 , "inputs " ++ (intercalate ":" $ state ^. ssInputs)
43 , "outputs " ++ (intercalate ":" $ fmap (take 20) $ state ^. ssOutputs)
44 , "conts " ++ (show $ state ^. ssContinue)
45 , "unsaved " ++ (show $ state ^. ssUnsaved)
46 , "states " ++ (show $ state ^. ssState)
47 , "tracing " ++ (show $ state ^. ssTracing)
48 , "dumping to " ++ (state ^. ssDumpFile)
49 ]
50
51 main :: IO ()
52 main =
53 do -- mem <- getMemory
54 -- print $ [(n, showHex (mem ! n) "") | n <- [0..5] ]
55 -- machineInput <- readFile "adventure_input.txt"
56 -- let mInp = wordify machineInput
57 -- let machine = makeMachine mem
58 -- let (exState, _machine, output) = runMachine mInp machine
59 -- print exState
60 -- putStrLn $ showOutput output
61
62 state0 <- emptyState
63 let state1 = runWithoutInput state0
64 let newOutput = head $ state1 ^. ssOutputs
65 putStrLn newOutput
66 -- let state1 = runOneInput state "take tablet"
67 -- print state0
68 -- print state
69 -- print state1
70
71 stateF <- adventureHarness state1
72 print stateF
73 return ()
74 -- print $ stateF ^. ssInputs
75 -- print $ stateF ^. ssOutputs
76 -- print $ stateF ^. ssState
77 -- let machs = stateF ^. ssMachines
78 -- let machPairs = zipWith (==) machs $ tail machs
79 -- print $ machPairs
80
81 emptyState :: IO SynacorState
82 emptyState =
83 do mem <- getMemory
84 let machine = makeMachine mem
85 return $ SynacorState
86 { _ssMachines = [machine]
87 , _ssInputs = []
88 , _ssOutputs = []
89 , _ssContinue = True
90 , _ssUnsaved = False
91 , _ssState = [Runnable]
92 , _ssTracing = False
93 , _ssDumpFile = ""
94 }
95 -- [machine] [] [] True False [Runnable]
96
97 adventureHarness :: SynacorState -> IO SynacorState
98 adventureHarness state =
99 do command <- prompt "> "
100 state' <- handleCommand command state
101 let traceAndOutput = head $ state' ^. ssOutputs
102 let (newOutput, traces) = spliceOut traceAndOutput
103 putStrLn newOutput
104 when (state' ^. ssTracing)
105 (appendFile (state' ^. ssDumpFile) $ unlines traces)
106 if (state' ^. ssContinue)
107 then (adventureHarness state')
108 else return state'
109
110
111 spliceOut :: String -> (String, [String])
112 spliceOut st = doingOut st "" []
113 where doingOut s out traces
114 | null s = (reverse out, reverse traces)
115 | ">> " `isPrefixOf` s = doingTrace (drop 3 s) out traces ""
116 | otherwise = doingOut (tail s) (head s : out) traces
117 doingTrace s out traces tr
118 | "<<" `isPrefixOf` s = doingOut (drop 2 s) out (reverse tr : traces)
119 | otherwise = doingTrace (tail s) out traces (head s : tr)
120
121
122 handleCommand :: String -> SynacorState -> IO SynacorState
123 handleCommand ":quit" state = return $ state & ssContinue .~ False
124 handleCommand ":save" state =
125 do filename <- prompt "Save as? "
126 let inputs = unlines $ tail $ reverse $ state ^. ssInputs
127 writeFile filename inputs
128 return $ state & ssUnsaved .~ True
129 handleCommand ":load" _state =
130 do filename <- prompt "From? "
131 machineInput <- readFile filename
132 let inputs = lines machineInput
133 initialState <- emptyState
134 let nonComments = filter (\i -> head i /= '#') inputs
135 let state = foldl' runOneInput initialState ("" : nonComments)
136 return $ state & ssUnsaved .~ False
137 handleCommand ":undo" state =
138 return $ state & ssMachines %~ tail
139 & ssInputs %~ tail
140 & ssOutputs %~ tail
141 & ssContinue .~ True
142 & ssUnsaved .~ True
143 & ssState %~ tail
144 handleCommand ":recap" state =
145 do let inputs = take 3 $ state ^. ssInputs
146 let outputs = "" : (tail $ take 3 $ state ^. ssOutputs)
147 let inOuts = reverse $ zip inputs outputs
148 forM_ inOuts (\(i, o) ->
149 do putStrLn ("#> " ++ i)
150 putStrLn o
151 )
152 return state
153 handleCommand ":trace" state =
154 do filename <- prompt "Dump to? "
155 return $ state & ssTracing .~ True & ssDumpFile .~ filename
156 handleCommand ":untrace" state =
157 return $ state & ssTracing .~ False & ssDumpFile .~ ""
158 handleCommand ":poke8" state =
159 do let machines = state ^. ssMachines
160 let machine = head machines
161 let machine' = machine & registers . ix 7 .~ 25734
162 & memory . ix 5489 .~ 21
163 & memory . ix 5490 .~ 21
164 & memory . ix 5495 .~ 7
165 -- let machine' = machine & memory . ix 5451 .~ 7
166 return $ state & ssMachines .~ (machine' : (tail machines))
167 handleCommand command state = return $ runOneInput state command
168
169
170 runWithoutInput :: SynacorState -> SynacorState
171 runWithoutInput state = state & ssMachines %~ (machine' :)
172 -- & ssInputs %~ (input :)
173 & ssOutputs %~ ((showOutput output) :)
174 & ssContinue .~ True
175 & ssUnsaved .~ True
176 & ssState %~ (exState :)
177 where machine = head $ state ^. ssMachines
178 (exState, machine', output) = runMachine [] (machine & inputIndex .~ 0)
179
180 runOneInput :: SynacorState -> String -> SynacorState
181 runOneInput state ":poke8" = state & ssMachines .~ ssMAchinesNew
182 where machine0 = head $ state ^. ssMachines
183 machine = machine0 & registers . ix 7 .~ 25734
184 & memory . ix 5489 .~ 21
185 & memory . ix 5490 .~ 21
186 & memory . ix 5495 .~ 7
187 ssMAchinesNew = machine : (tail $ state ^. ssMachines)
188
189 runOneInput state input = state & ssMachines %~ (machine' :)
190 & ssInputs %~ (input :)
191 & ssOutputs %~ ((showOutput output) :)
192 & ssContinue .~ True
193 & ssUnsaved .~ True
194 & ssState %~ (exState :)
195 where machine0 = head $ state ^. ssMachines
196 machine = if (state ^. ssTracing)
197 then machine0 & tracing .~ True
198 else machine0 & tracing .~ False
199 inputW = wordify (input ++ "\n")
200 (exState, machine', output) = runMachine inputW (machine & inputIndex .~ 0)
201 -- output' = trace ("runone " ++ (show (machine == machine')) ++ " " ++ (show exState) ++ " " ++ (showOutput output)) output
202
203
204 prompt :: String -> IO String
205 prompt text = do
206 putStr text
207 hFlush stdout
208 getLine
209
210 wordify :: String -> [Word16]
211 wordify cs = fmap (fromIntegral . ord) cs
212
213 showOutput :: [Word16] -> String
214 showOutput output = fmap (chr . fromInteger . fromIntegral) output
215
216 getMemory :: IO Memory
217 getMemory = do
218 input <- BL.readFile "challenge.bin"
219 let cells = runGet getCells input
220 return $ M.fromList $ zip [0..] cells
221
222 getCells :: Get [Word16]
223 getCells = do
224 empty <- isEmpty
225 if empty
226 then return []
227 else do cell <- getWord16le
228 cells <- getCells
229 return (cell:cells)
230
231