From 3836f842a8794a2d25cc5f8558d70becae8b7396 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Thu, 3 Aug 2023 14:25:59 +0100 Subject: [PATCH 1/1] Completed puzzle --- codes_found.md | 3 ++ full_solution.txt | 15 ++++++ src/Main.hs | 23 ++++---- src/OrbMaze.hs | 125 +++++++++++++++++++++++++++++++++++++++++++ src/SynacorEngine.hs | 16 +++--- synacor.cabal | 21 ++++++-- 6 files changed, 180 insertions(+), 23 deletions(-) create mode 100644 src/OrbMaze.hs diff --git a/codes_found.md b/codes_found.md index 0cb6907..e8e1ae5 100644 --- a/codes_found.md +++ b/codes_found.md @@ -16,3 +16,6 @@ Lighting the lantern in the cavern ## Using the teleporter > PLqwUDZxwKuh + +## After the orb maze +"qiwTT8UxHYxp" or mirrored to qxYHxU8TTwip diff --git a/full_solution.txt b/full_solution.txt index ea1511d..cbf3da8 100644 --- a/full_solution.txt +++ b/full_solution.txt @@ -86,3 +86,18 @@ west north north take orb +north +east +east +north +west +south +east +east +west +north +north +east +vault +take mirror +use mirror diff --git a/src/Main.hs b/src/Main.hs index d7ad6f3..101714e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,19 +1,19 @@ import SynacorEngine -import Debug.Trace +-- import Debug.Trace -import Numeric +-- import Numeric import System.IO import Data.Char import Data.List import qualified Data.Map.Strict as M -import Data.Map.Strict ((!)) +-- import Data.Map.Strict ((!)) import Control.Lens -- hiding ((<|), (|>), (:>), (:<), indices) -import Control.Monad.State.Strict -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.RWS.Strict +import Control.Monad.State.Strict hiding (state) +-- import Control.Monad.Reader +-- import Control.Monad.Writer +-- import Control.Monad.RWS.Strict hiding (state) -- import Data.Bits import Data.Word @@ -69,6 +69,7 @@ main = -- print state1 stateF <- adventureHarness state1 + print stateF return () -- print $ stateF ^. ssInputs -- print $ stateF ^. ssOutputs @@ -98,17 +99,17 @@ adventureHarness state = do command <- prompt "> " state' <- handleCommand command state let traceAndOutput = head $ state' ^. ssOutputs - let (newOutput, tracing) = spliceOut traceAndOutput + let (newOutput, traces) = spliceOut traceAndOutput putStrLn newOutput when (state' ^. ssTracing) - (appendFile (state' ^. ssDumpFile) $ unlines tracing) + (appendFile (state' ^. ssDumpFile) $ unlines traces) if (state' ^. ssContinue) then (adventureHarness state') else return state' spliceOut :: String -> (String, [String]) -spliceOut s = doingOut s "" [] +spliceOut st = doingOut st "" [] where doingOut s out traces | null s = (reverse out, reverse traces) | ">> " `isPrefixOf` s = doingTrace (drop 3 s) out traces "" @@ -125,7 +126,7 @@ handleCommand ":save" state = let inputs = unlines $ tail $ reverse $ state ^. ssInputs writeFile filename inputs return $ state & ssUnsaved .~ True -handleCommand ":load" state = +handleCommand ":load" _state = do filename <- prompt "From? " machineInput <- readFile filename let inputs = lines machineInput diff --git a/src/OrbMaze.hs b/src/OrbMaze.hs new file mode 100644 index 0000000..b9888da --- /dev/null +++ b/src/OrbMaze.hs @@ -0,0 +1,125 @@ + +import qualified Debug.Trace as DT + +import Data.List +import Data.Maybe +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import Linear +import Control.Lens + +-- type Position = V2 Int -- x, y, origin bottom left +newtype Position = Pos (V2 Int) -- x, y, origin bottom left + deriving (Show, Eq, Ord) + + +instance Semigroup Position where + (Pos p) <> (Pos q) = Pos $ p ^+^ q + +instance Monoid Position where + mempty = Pos (V2 0 0) + +data Operator = Times | Divide | Plus | Minus + deriving (Show, Eq, Ord) + +data Cell = Literal Int | Op Operator + deriving (Show, Eq, Ord) + +type Grid = M.Map Position Cell + +data SearchState = SearchState + { _path :: [Position] + , _value :: Int + , _operator :: Maybe Operator + } + deriving (Show, Eq, Ord) +makeLenses ''SearchState + +main :: IO () +main = + do -- print grid + let s = initialSearchState + -- print s + -- print $ neighbours s + let ps = bfs [s] + print ps + print $ presentPath $ (fromMaybe s ps) ^. path + +grid :: Grid +grid = M.fromList $ fmap (\(p, v) -> (Pos p, v)) + [ (V2 0 3, Op Times), (V2 1 3, Literal 8), (V2 2 3, Op Minus), (V2 3 3, Literal 1) + , (V2 0 2, Literal 4), (V2 1 2, Op Times), (V2 2 2, Literal 11), (V2 3 2, Op Times) + , (V2 0 1, Op Plus), (V2 1 1, Literal 4), (V2 2 1, Op Minus), (V2 3 1, Literal 18) + , (V2 0 0, Literal 22), (V2 1 0, Op Minus), (V2 2 0, Literal 9), (V2 3 0, Op Times) + ] + +initialSearchState :: SearchState +initialSearchState = SearchState {_path = [], _value = 22, _operator = Nothing} + +deltas :: [Position] +deltas = fmap Pos [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1] + +-- adjacents :: Position -> Grid -> [Position] +-- adjacents here grid = filter (flip M.member grid) $ fmap (here <>) deltas + +neighbours :: SearchState -> [SearchState] +neighbours state = catMaybes $ fmap (step state) deltas + -- where here = mconcat $ state ^. path + +step :: SearchState -> Position -> Maybe SearchState +step state d = + do d' <- notStart state d + destination <- M.lookup ((currentPosition state) <> d') grid + state' <- addTerm state destination + return $ state' & path %~ (d' : ) + + +notStart :: SearchState -> Position -> Maybe Position +notStart state delta + | (mconcat (state ^. path)) <> delta == mempty = Nothing + | otherwise = Just delta + +bfs :: [SearchState] -> Maybe SearchState +-- bfs a | DT.trace (show a) False = undefined +bfs [] = Nothing +bfs (s:agenda) + | isGoal s = Just s + | currentPosition s == Pos (V2 3 3) = bfs agenda + | length (s ^. path) == 15 = bfs agenda + | s ^. value < 0 = bfs agenda + | s ^. value > (2 ^ 16) = bfs agenda + | otherwise = bfs (agenda ++ nexts) + where nexts = neighbours s + + +isGoal :: SearchState -> Bool +isGoal s = (currentPosition s == Pos (V2 3 3)) && (s ^. value == 30) + +currentPosition :: SearchState -> Position +currentPosition s = mconcat $ s ^. path + +currentValue :: SearchState -> Maybe Int +currentValue s + | (s ^. operator) == Nothing = Just $ s ^. value + | otherwise = Nothing + +addTerm :: SearchState -> Cell -> Maybe SearchState +-- addTerm s c | DT.trace (show (s, c)) False = undefined +addTerm s (Literal i) = + go (s ^. operator) i s + where + go Nothing _ _ = Nothing + go (Just Times) i s = Just $ s & value %~ (* i) & operator .~ Nothing + go (Just Divide) i s = Just $ s & value %~ (`div` i) & operator .~ Nothing + go (Just Plus) i s = Just $ s & value %~ (+ i) & operator .~ Nothing + go (Just Minus) i s = Just $ s & value %~ (+ (-i)) & operator .~ Nothing +addTerm s (Op op) + | (s ^. operator) == Nothing = Just $ s & operator .~ (Just op) + | otherwise = Nothing + +presentPath ps = fmap presentStep $ reverse ps + where + presentStep (Pos (V2 0 1)) = "north" + presentStep (Pos (V2 0 -1)) = "south" + presentStep (Pos (V2 1 0)) = "east" + presentStep (Pos (V2 -1 0)) = "west" diff --git a/src/SynacorEngine.hs b/src/SynacorEngine.hs index 757bd5f..63fb20c 100644 --- a/src/SynacorEngine.hs +++ b/src/SynacorEngine.hs @@ -1,6 +1,6 @@ module SynacorEngine where -import Debug.Trace +-- import Debug.Trace -- import System.Environment import Data.Bits @@ -12,7 +12,7 @@ import Data.Map.Strict ((!)) import Control.Lens import Data.List import Data.Char -import Numeric +-- import Numeric import Control.Monad.State.Strict import Control.Monad.Reader @@ -44,11 +44,11 @@ runMachine inputs machine = runRWS (runAll (10 ^ 6)) inputs machine makeMachine :: Memory -> Machine -makeMachine memory = Machine +makeMachine mem = Machine { _ip = 0 , _inputIndex = 0 , _registers = M.fromList [ (r, 0) | r <- [0..7] ] - , _memory = memory + , _memory = mem , _stack = [] , _tracing = False } @@ -275,10 +275,10 @@ traceMachine = do when isTracing do cip <- gets _ip (l, _) <- dissembleInstruction cip - registers <- gets _registers - let regVals = intercalate "; " $ fmap show $ M.elems registers - stack <- gets _stack - let stackVals = intercalate "; " $ fmap show $ take 10 stack + regs <- gets _registers + let regVals = intercalate "; " $ fmap show $ M.elems regs + stk <- gets _stack + let stackVals = intercalate "; " $ fmap show $ take 10 stk tell $ fmap (fromIntegral . ord) (">> " ++ l ++ " : r> " ++ regVals ++ " : s> " ++ stackVals ++ "<<") runDissemble :: Word16 -> Int -> Machine -> [String] diff --git a/synacor.cabal b/synacor.cabal index 60ac8f5..196d3f4 100644 --- a/synacor.cabal +++ b/synacor.cabal @@ -72,7 +72,7 @@ common common-extensions common build-directives build-depends: base >=4.16 - default-language: Haskell2010 + default-language: GHC2021 hs-source-dirs: ., app, src other-modules: SynacorEngine ghc-options: -O2 @@ -93,7 +93,7 @@ executable synacor -- other-extensions: build-depends: containers, binary, bytestring, mtl, lens hs-source-dirs: app, src - default-language: Haskell2010 + default-language: GHC2021 executable ackermann import: common-extensions @@ -101,7 +101,7 @@ executable ackermann main-is: Ackermann.hs build-depends: base >=4.16, containers, mtl, parallel hs-source-dirs: app, src - default-language: Haskell2010 + default-language: GHC2021 hs-source-dirs: ., app, src ghc-options: -O2 -Wall @@ -115,7 +115,20 @@ executable coinsolver main-is: CoinSolver.hs build-depends: base >=4.16, containers hs-source-dirs: app, src - default-language: Haskell2010 + default-language: GHC2021 + hs-source-dirs: ., app, src + ghc-options: -O2 + -Wall + -threaded + -rtsopts "-with-rtsopts=-N" + +executable orbmaze + import: common-extensions + main-is: Main.hs + main-is: OrbMaze.hs + build-depends: base >=4.16, containers, linear, lens + hs-source-dirs: app, src + default-language: GHC2021 hs-source-dirs: ., app, src ghc-options: -O2 -Wall -- 2.34.1