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