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
  14 import Control.Monad.Reader
  15 import Control.Monad.Writer
  16 import Control.Monad.RWS.Strict
  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   } deriving (Ord, Eq)
  32 makeLenses ''SynacorState
  33
  34 instance Show SynacorState
  35   where
  36     show state =
  37           intercalate ", "
  38             [ "SynacorState"
  39             , (show (length (state ^. ssMachines)) ++ " machines")
  40             , "inputs " ++ (intercalate ":" $ state ^. ssInputs)
  41             , "outputs " ++ (intercalate ":" $ fmap (take 20) $ state ^. ssOutputs)
  42             , "conts " ++ (show $ state ^. ssContinue)
  43             , "unsaved " ++ (show $ state ^. ssUnsaved)
  44             , "states " ++ (show $ state ^. ssState)
  45             ]
  46
  47 main :: IO ()
  48 main =
  49   do  -- mem <- getMemory
  50       -- print $ [(n, showHex (mem ! n) "") | n <- [0..5] ]
  51       -- machineInput <- readFile "adventure_input.txt"
  52       -- let mInp = wordify machineInput
  53       -- let machine = makeMachine mem
  54       -- let (exState, _machine, output) = runMachine mInp machine
  55       -- print exState
  56       -- putStrLn $ showOutput output
  57
  58       state0 <- emptyState
  59       let state1 = runWithoutInput state0
  60       let newOutput = head $ state1 ^. ssOutputs
  61       putStrLn newOutput
  62       -- let state1 = runOneInput state "take tablet"
  63       -- print state0
  64       -- print state
  65       -- print state1
  66
  67       stateF <- adventureHarness state1
  68       return ()
  69       -- print $ stateF ^. ssInputs
  70       -- print $ stateF ^. ssOutputs
  71       -- print $ stateF ^. ssState
  72       -- let machs = stateF ^. ssMachines
  73       -- let machPairs = zipWith (==) machs $ tail machs
  74       -- print $ machPairs
  75
  76 emptyState :: IO SynacorState
  77 emptyState =
  78   do  mem <- getMemory
  79       let machine = makeMachine mem
  80       return $ SynacorState [machine] [] [] True False [Runnable]
  81
  82 adventureHarness :: SynacorState -> IO SynacorState
  83 adventureHarness state =
  84   do command <- prompt "> "
  85      state' <- handleCommand command state
  86      let newOutput = head $ state' ^. ssOutputs
  87      putStrLn newOutput
  88      if (state' ^. ssContinue)
  89         then (adventureHarness state')
  90         else return state'
  91
  92
  93 handleCommand :: String -> SynacorState -> IO SynacorState
  94 handleCommand ":quit" state = return $ state & ssContinue .~ False
  95 handleCommand ":save" state =
  96   do  filename <- prompt "Save as? "
  97       let inputs = unlines $ tail $ reverse $ state ^. ssInputs
  98       writeFile filename inputs
  99       return $ state & ssUnsaved .~ True
 100 handleCommand ":load" state =
 101   do  filename <- prompt "From? "
 102       machineInput <- readFile filename
 103       let inputs = lines machineInput
 104       initialState <- emptyState
 105       let nonComments = filter (\i -> head i == '#') inputs
 106       let state = foldl' runOneInput initialState ("" : nonComments)
 107       return $ state & ssUnsaved .~ False
 108 handleCommand ":undo" state =
 109       return $ state & ssMachines %~ tail
 110                      & ssInputs %~ tail
 111                      & ssOutputs %~ tail
 112                      & ssContinue .~ True
 113                      & ssUnsaved .~ True
 114                      & ssState %~ tail
 115 handleCommand ":recap" state =
 116   do let inputs = take 3 $ state ^. ssInputs
 117      let outputs = "" : (tail $ take 3 $ state ^. ssOutputs)
 118      let inOuts = reverse $ zip inputs outputs
 119      forM_ inOuts (\(i, o) ->
 120         do putStrLn ("#> " ++ i)
 121            putStrLn o
 122         )
 123      return state
 124 handleCommand command state = return $ runOneInput state command
 125
 126
 127 runWithoutInput :: SynacorState -> SynacorState
 128 runWithoutInput state = state & ssMachines %~ (machine' :)
 129                                 -- & ssInputs %~ (input :)
 130                                 & ssOutputs %~ ((showOutput output) :)
 131                                 & ssContinue .~ True
 132                                 & ssUnsaved .~ True
 133                                 & ssState %~ (exState :)
 134   where machine = head $ state ^. ssMachines
 135         (exState, machine', output) = runMachine [] (machine & inputIndex .~ 0)
 136
 137 runOneInput :: SynacorState -> String -> SynacorState
 138 runOneInput state input = state & ssMachines %~ (machine' :)
 139                                 & ssInputs %~ (input :)
 140                                 & ssOutputs %~ ((showOutput output) :)
 141                                 & ssContinue .~ True
 142                                 & ssUnsaved .~ True
 143                                 & ssState %~ (exState :)
 144   where machine = head $ state ^. ssMachines
 145         inputW = wordify (input ++ "\n")
 146         (exState, machine', output) = runMachine inputW (machine & inputIndex .~ 0)
 147         -- output' = trace ("runone " ++ (show (machine == machine')) ++ " " ++ (show exState) ++ " " ++ (showOutput output)) output
 148
 149
 150 prompt :: String -> IO String
 151 prompt text = do
 152     putStr text
 153     hFlush stdout
 154     getLine
 155
 156 wordify :: String -> [Word16]
 157 wordify cs = fmap (fromIntegral . ord) cs
 158
 159 showOutput :: [Word16] -> String
 160 showOutput output = fmap (chr . fromInteger . fromIntegral) output
 161
 162 getMemory :: IO Memory
 163 getMemory = do
 164   input <- BL.readFile "challenge.bin"
 165   let cells = runGet getCells input
 166   return $ M.fromList $ zip [0..] cells
 167
 168 getCells :: Get [Word16]
 169 getCells = do
 170   empty <- isEmpty
 171   if empty
 172     then return []
 173     else do cell <- getWord16le
 174             cells <- getCells
 175             return (cell:cells)
 176
 177