Completed puzzle

[synacor-challenge.git] / src / OrbMaze.hs

diff --git a/src/OrbMaze.hs b/src/OrbMaze.hs
new file mode 100644 (file)
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"