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"