+
+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"
projects / synacor-challenge.git / commitdiff