b9888da5c9c14a4df208c52d48d8c3304abccfca
[synacor-challenge.git] / src / OrbMaze.hs
1
2 import qualified Debug.Trace as DT
3
4 import Data.List
5 import Data.Maybe
6 import qualified Data.Map.Strict as M
7 import Data.Map.Strict ((!))
8 import Linear
9 import Control.Lens
10
11 -- type Position = V2 Int -- x, y, origin bottom left
12 newtype Position = Pos (V2 Int) -- x, y, origin bottom left
13 deriving (Show, Eq, Ord)
14
15
16 instance Semigroup Position where
17 (Pos p) <> (Pos q) = Pos $ p ^+^ q
18
19 instance Monoid Position where
20 mempty = Pos (V2 0 0)
21
22 data Operator = Times | Divide | Plus | Minus
23 deriving (Show, Eq, Ord)
24
25 data Cell = Literal Int | Op Operator
26 deriving (Show, Eq, Ord)
27
28 type Grid = M.Map Position Cell
29
30 data SearchState = SearchState
31 { _path :: [Position]
32 , _value :: Int
33 , _operator :: Maybe Operator
34 }
35 deriving (Show, Eq, Ord)
36 makeLenses ''SearchState
37
38 main :: IO ()
39 main =
40 do -- print grid
41 let s = initialSearchState
42 -- print s
43 -- print $ neighbours s
44 let ps = bfs [s]
45 print ps
46 print $ presentPath $ (fromMaybe s ps) ^. path
47
48 grid :: Grid
49 grid = M.fromList $ fmap (\(p, v) -> (Pos p, v))
50 [ (V2 0 3, Op Times), (V2 1 3, Literal 8), (V2 2 3, Op Minus), (V2 3 3, Literal 1)
51 , (V2 0 2, Literal 4), (V2 1 2, Op Times), (V2 2 2, Literal 11), (V2 3 2, Op Times)
52 , (V2 0 1, Op Plus), (V2 1 1, Literal 4), (V2 2 1, Op Minus), (V2 3 1, Literal 18)
53 , (V2 0 0, Literal 22), (V2 1 0, Op Minus), (V2 2 0, Literal 9), (V2 3 0, Op Times)
54 ]
55
56 initialSearchState :: SearchState
57 initialSearchState = SearchState {_path = [], _value = 22, _operator = Nothing}
58
59 deltas :: [Position]
60 deltas = fmap Pos [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1]
61
62 -- adjacents :: Position -> Grid -> [Position]
63 -- adjacents here grid = filter (flip M.member grid) $ fmap (here <>) deltas
64
65 neighbours :: SearchState -> [SearchState]
66 neighbours state = catMaybes $ fmap (step state) deltas
67 -- where here = mconcat $ state ^. path
68
69 step :: SearchState -> Position -> Maybe SearchState
70 step state d =
71 do d' <- notStart state d
72 destination <- M.lookup ((currentPosition state) <> d') grid
73 state' <- addTerm state destination
74 return $ state' & path %~ (d' : )
75
76
77 notStart :: SearchState -> Position -> Maybe Position
78 notStart state delta
79 | (mconcat (state ^. path)) <> delta == mempty = Nothing
80 | otherwise = Just delta
81
82 bfs :: [SearchState] -> Maybe SearchState
83 -- bfs a | DT.trace (show a) False = undefined
84 bfs [] = Nothing
85 bfs (s:agenda)
86 | isGoal s = Just s
87 | currentPosition s == Pos (V2 3 3) = bfs agenda
88 | length (s ^. path) == 15 = bfs agenda
89 | s ^. value < 0 = bfs agenda
90 | s ^. value > (2 ^ 16) = bfs agenda
91 | otherwise = bfs (agenda ++ nexts)
92 where nexts = neighbours s
93
94
95 isGoal :: SearchState -> Bool
96 isGoal s = (currentPosition s == Pos (V2 3 3)) && (s ^. value == 30)
97
98 currentPosition :: SearchState -> Position
99 currentPosition s = mconcat $ s ^. path
100
101 currentValue :: SearchState -> Maybe Int
102 currentValue s
103 | (s ^. operator) == Nothing = Just $ s ^. value
104 | otherwise = Nothing
105
106 addTerm :: SearchState -> Cell -> Maybe SearchState
107 -- addTerm s c | DT.trace (show (s, c)) False = undefined
108 addTerm s (Literal i) =
109 go (s ^. operator) i s
110 where
111 go Nothing _ _ = Nothing
112 go (Just Times) i s = Just $ s & value %~ (* i) & operator .~ Nothing
113 go (Just Divide) i s = Just $ s & value %~ (`div` i) & operator .~ Nothing
114 go (Just Plus) i s = Just $ s & value %~ (+ i) & operator .~ Nothing
115 go (Just Minus) i s = Just $ s & value %~ (+ (-i)) & operator .~ Nothing
116 addTerm s (Op op)
117 | (s ^. operator) == Nothing = Just $ s & operator .~ (Just op)
118 | otherwise = Nothing
119
120 presentPath ps = fmap presentStep $ reverse ps
121 where
122 presentStep (Pos (V2 0 1)) = "north"
123 presentStep (Pos (V2 0 -1)) = "south"
124 presentStep (Pos (V2 1 0)) = "east"
125 presentStep (Pos (V2 -1 0)) = "west"