astar-monad 0.2.1.0 → 0.3.0.0

raw patch · 5 files changed

+225/−158 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +52/−32
• astar-monad.cabal +2/−2
• src/Control/Monad/AStar.hs +83/−81
• src/Control/Monad/AStar/Class.hs +8/−6
• test/Spec.hs +80/−37

@@ -5,13 +5,17 @@  **Caveat Emptor**; this hasn't been *battle-tested* yet; it should work, but make sure to test it out if you're doing anything serious. -Easily do A\* searches with use of arbitrary monadic effects!+Easily do [A\* searches](https://en.wikipedia.org/wiki/A*_search_algorithm) with use of arbitrary monadic effects! +> A* Search is widely used in pathfinding and graph traversal, which is the process of finding a path between multiple points, called "nodes".+> A* can be used to find optimal paths for any problem with an appropriate heuristic cost-measure.+ ## Basics  * Use `<|>` or `asum` (anything using `Alternative`) to branch into multiple possible choices.-* Use `updateCost myCost` to set the value of your 'heuristic' function whenever you've done enough work to change your estimate.  Remember that A\* heuristics should always be pessimistic (e.g. can over-estimate cost, but shouldn't UNDER estimate). -* Every call to `updateCost` creates a branch; Branches with LOWER costs will run before those with higher costs.+* Use `estimate myCost` to **set** the value of your 'heuristic' function for the current branch. Do this whenever you've done enough work to change your estimate.  Remember that A\* heuristics should always be pessimistic (e.g. can over-estimate cost, but shouldn't UNDER estimate). +* Use `spend myCost` to **add** a cost to the branch's CUMULATIVE cost. Do this when some cost has been incurred, e.g. we've moved the state from one node to another.+* Every call to `spend` or `estimate` creates a branch; Branches with LOWER costs will run before those with higher costs. Note that this branching is expensive, so try to consolidate calls to these functions in your actions when possible. * Call `done mySolution` to short circuit ALL running branches and immediately return your result. * `AStarT` has a built-in State monad which can store branch-local states for you. You can store your current branch's solution-space for instance, or the path you've followed to get to the current solution; or both! @@ -22,40 +26,50 @@ data Move = U | D | L | R     deriving (Show, Eq) --- Track our current position, the goal we're moving towards, and the moves we've taken so far.+-- Track our current position, the goal we're moving towards, and the locations we've crossed along the way. data Context =-    Context { _currentPos :: (Int, Int)-            , _goal    :: (Int, Int)-            , _moves   :: [Move]+    Context { _current   :: (Int, Int)+            , _goal      :: (Int, Int)+            , _locations :: [(Int, Int)]             }     deriving (Show, Eq) makeLenses ''Context --- The Manhattan distance between two points--- This is our A* heuristic+-- The Manhattan distance between two points serves as our heuristic estimate.+-- It's *conservative*; it may cost MORE than this, but it won't cost LESS distanceTo :: (Int, Int) -> (Int, Int) -> Int distanceTo (x, y) (x', y') = abs (x - x') + abs (y - y') +-- To make things more interesting we'll say that moving through coordinates+-- where either 'x' or 'y' are divisible by the other is 3X more expensive!+addCost :: MonadAStar (Sum Int) r m => (Int, Int) -> m ()+-- Don't divide by zero!+addCost (0, _) = spend 1+addCost (_, 0) = spend 1+addCost (x, y)+    | mod x y == 0 || mod y x == 0 = spend 3+addCost _ = spend 1+ -- Move around the space looking for the destination point.-findPoint :: AStar Context Int () ()-findPoint = do-    c <- use currentPos+mineField :: AStar Context (Sum Int) (Int, Int) ()+mineField = do+    -- Get the current position+    (x, y) <- use current+    -- Add the current location to our list+    locations <>= [(x, y)]+    -- If we're at the goal we're done!     gl <- use goal-    -- I could return the moves we took, -    -- but our State is automatically returned when we run AStar-    when (c == gl) $ done ()-    -- We have more work to do, we should update the cost estimate and continue-    updateCost $ distanceTo gl c-    if c == gl -       then done ()-       else updateCost $ distanceTo gl c-    -- Non-deterministically choose a direction to move, -    -- store that move in our state, and edit our current position.+    when ((x, y) == gl)+      $ done gl+    -- Add the cost of the current position+    addCost (x, y)+    -- Estimate steps to completion+    estimate . Sum $ distanceTo gl (x, y)     asum-        [ moves <>= [R] >> currentPos . _1 += 1 >> findPoint-        , moves <>= [L] >> currentPos . _1 -= 1 >> findPoint-        , moves <>= [D] >> currentPos . _2 += 1 >> findPoint-        , moves <>= [U] >> currentPos . _2 -= 1 >> findPoint+        [ move L >> mineField+        , move R >> mineField+        , move U >> mineField+        , move D >> mineField         ]  -- We only care about the ending state, so we use `execAStar`@@ -68,10 +82,16 @@                      , _moves   = []                      } --- run it to see if we found a solution; it returns the state of the the 'winning' branch.->>> run -Just (Context { _current = (7, 4)-              , _goal    = (7, 4)-              , _moves   = [U, R, R]-              })+-- Execute it to see if we found a solution; +-- We only care about the state, so we use 'execAStar' it returns the state of the the 'winning' branch.+--+-- We can see from the results that the optimal path with these costs involves a bit of moving around to avoid coordinates which divide each other!+>>> execAStar mineField (context (1, 1) (3, 4))+Just (Context+      { _current   = (3, 4)+      , _goal      = (3, 4)+      , _locations = +          [(1, 1), (0, 1), (0, 2), (0, 3), (0, 4), (0, 5), (1, 5), (2, 5), (3, 5), (3, 4)]+      })+ ```

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 485ec3b8546276e4d3f4a788bf628028e40cf0033dd80f364306d09bedea6f45+-- hash: 7460bc421588132be13b6817bff684eef35d40e33ca2e5eec46b73dad51a222e  name:           astar-monad-version:        0.2.1.0+version:        0.3.0.0 description:    Please see the README on GitHub at <https://github.com/ChrisPenner/astar-monad#readme> homepage:       https://github.com/ChrisPenner/astar-monad#readme bug-reports:    https://github.com/ChrisPenner/astar-monad/issues

@@ -14,11 +14,13 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-} module Control.Monad.AStar     (     -- * Types       AStar     , AStarT+    , BranchState (..)      -- * Methods     , MonadAStar(..)@@ -26,15 +28,15 @@     , failure      -- * Executing Search+    , runAStar     , runAStarT-    , execAStarT+    , evalAStar     , evalAStarT-    , runAStar     , execAStar-    , evalAStar+    , execAStarT -    , tryWhile-    , tryWhileT+    -- , tryWhile+    -- , tryWhileT     )     where @@ -47,9 +49,19 @@ import Data.Functor.Identity import Data.Maybe -data Step c r a = Pure a | Weighted c | Solved r+data Step r a = Pure a | Checkpoint | Solved r     deriving (Show, Functor, Eq) +data BranchState s c =+    BranchState { branchState      :: s+                , cumulativeCost   :: c+                , estimateTillDone :: c+                }+    deriving (Show, Eq)++totalCost :: Semigroup c => BranchState s c -> c+totalCost bs = cumulativeCost bs <> estimateTillDone bs+ -- | Non-transformer version of 'AStarT' type AStar s c r a = AStarT s c r Identity a @@ -60,8 +72,10 @@ -- @s@: State; keep anything you want in here, it will stay coherent across -- branch switches. ----- @c@: Cost measure: The type you'll use for determining the estimated cost of following a given--- branch. Usually requires 'Ord'.+-- @c@: Cost measure: The type you'll use for both your heuristic estimate and for your+-- accumulated total cost.+-- Usually requires 'Ord' (for comparing branch costs) and 'Monoid' (for appending and+-- instantiating cumulative costs). -- -- @r@: Result type, this is often redundant to State but is provided for convenience. -- This is the type you pass to 'done' when you've found a solution.@@ -71,62 +85,50 @@ -- Be wary that effects will be run in seemingly non-deterministic ordering as we switch -- chaotically between branches. newtype AStarT s c r m a =-    AStarT { unAStarT :: StateT s (LogicT m) (Step c r a)+    AStarT { unAStarT :: StateT (BranchState s c) (LogicT m) (Step r a)           } deriving stock Functor --- mapResult :: (r -> r') -> AStarT s c r m a -> AStarT s c r' m a--- mapResult f (AStarT m) = AStarT $ fmap go m---   where---     go (Pure a) = Pure a---     go (Weighted c) = Weighted c---     go (Solved r) = Solved $ f r- instance MonadTrans (AStarT s c r) where   lift m = AStarT . lift . lift $ (Pure <$> m) -instance (MonadIO m, Ord c) => MonadIO (AStarT s c r m) where+instance (MonadIO m, Semigroup c, Ord c) => MonadIO (AStarT s c r m) where   liftIO io = lift $ liftIO io -instance (Monad m, Ord c) => Applicative (AStarT s c r m) where+instance (Monad m, Semigroup c, Ord c) => Applicative (AStarT s c r m) where   pure = return   (<*>) = ap -instance (Ord c, Monad m) => MonadPlus (AStarT s c r m) where+instance (Ord c, Semigroup c, Monad m) => MonadPlus (AStarT s c r m) where   mzero = empty   mplus = (<|>) -instance (Ord c, Monad m) => MonadFail (AStarT s c r m) where+instance (Ord c, Semigroup c, Monad m) => MonadFail (AStarT s c r m) where   fail _ = empty -instance (Ord c, Monad m) => MonadState s (AStarT s c r m) where-  get = AStarT $ Pure <$> get-  put s = AStarT $ Pure <$> put s+instance (Ord c, Semigroup c, Monad m) => MonadState s (AStarT s c r m) where+  get = AStarT $ Pure . branchState <$> get+  put s = AStarT $ Pure <$> modify (\bs -> bs{branchState=s}) -instance (Monad m, Ord c) => Monad (AStarT s c r m) where+instance (Monad m, Semigroup c, Ord c) => Monad (AStarT s c r m) where   return = AStarT . return . Pure   AStarT m >>= f = AStarT $ do-      msplit m >>= \case-        Nothing -> empty-        Just (Pure a, continue) -> unAStarT $ (f a) `weightedInterleave` (AStarT continue >>= f)-        Just (Solved r, _) -> pure $ Solved r-        Just (Weighted c, continue) -> do-            reflect $ Just (Weighted c, unAStarT $ AStarT continue >>= f)---- instance (Ord c, Monad m) => MonadLogic (AStarT s c r m) where---   msplit (AStarT (StateT m)) = AStarT . StateT $ \s -> do---       msplit (m s) >>= \case---         (Just ((Weighted w, s), continue)) -> return (Weighted w, s)---         (Just ((stp, s), continue)) -> return (_, s)---         Nothing -> return $ (Pure Nothing, s)+      next <- msplit m+      case next of+          Nothing -> empty+          (Just (Solved r, _)) -> pure (Solved r)+          -- Should I interleave these instead?+          (Just (Pure a, continue)) -> (unAStarT $ f a) <|> unAStarT (AStarT continue >>= f)+          (Just (Checkpoint, continue)) ->+                pure Checkpoint <|> unAStarT (AStarT continue >>= f) -instance (Ord c, Monad m) => Alternative (AStarT s c r m) where+instance (Ord c, Monad m, Semigroup c) => Alternative (AStarT s c r m) where   empty = AStarT empty   (<|>) = weightedInterleave -weightedInterleave :: (Ord c, Monad m) => AStarT s c r m a -> AStarT s c r m a -> AStarT s c r m a+weightedInterleave :: (Ord c, Semigroup c, Monad m) => AStarT s c r m a -> AStarT s c r m a -> AStarT s c r m a weightedInterleave (AStarT a) (AStarT b) = AStarT $ weightedInterleave' a b -weightedInterleave' :: (Ord c, MonadLogic m, MonadState s m) => m (Step c r a) -> m (Step c r a) -> m (Step c r a)+weightedInterleave' :: (Ord c, Semigroup c, MonadLogic m, MonadState (BranchState s c) m) => m (Step r a) -> m (Step r a) -> m (Step r a) weightedInterleave' ma mb = do     beforeBoth <- get     (rA, lState) <- liftA2 (,) (msplit ma) get@@ -135,70 +137,70 @@     case (rA, rB) of         (m, Nothing) -> put lState >> reflect m         (Nothing, m) -> put rState >> reflect m-        (Just (Solved a, _), _) -> put lState >> pure (Solved a)-        (_ , Just (Solved a, _)) -> put rState >> pure (Solved a)-        (l@(Just (Weighted lw, lm)), r@(Just (Weighted rw, rm)))-          | lw < rw ->-              (put lState >> pure (Weighted lw))+        (Just (Solved r, _), _) -> put lState >> pure (Solved r)+        (_, Just (Solved r, _)) -> put rState >> pure (Solved r)+        (l@(Just (Checkpoint, lm)), r@(Just (Checkpoint, rm)))+          | totalCost lState <= totalCost rState ->do+              (put lState >> pure Checkpoint)                 <|> ((put lState >> lm) `weightedInterleave'` (put rState >> reflect r))           | otherwise ->-              (put rState >> pure (Weighted rw))+              (put rState >> pure Checkpoint)                <|> ((put rState >> rm) `weightedInterleave'` (put lState >> reflect l))         ((Just (Pure la, lm)), r) ->             (put lState >> pure (Pure la)) `interleave` ((put lState >> lm) `weightedInterleave'` (put rState >> reflect r))         (l, (Just (Pure ra, rm))) ->             (put rState >> pure (Pure ra)) `interleave` ((put rState >> rm) `weightedInterleave'` (put lState >> reflect l)) +-- | Run a pure A* computation returning the solution and branch state if one was found.+runAStar :: (Monoid c) => AStar s c r a -> s -> Maybe (r, s)+runAStar m s = runIdentity $ runAStarT m s+ -- | Run an A* computation effect returning the solution and branch state if one was found.-runAStarT :: (Monad m) => AStarT s c r m a -> s -> m (Maybe (r, s))+runAStarT :: (Monad m, Monoid c) => AStarT s c r m a -> s -> m (Maybe (r, s)) runAStarT (AStarT m) s = fmap listToMaybe . observeManyT 1 $ do-    runStateT m s >>= \case-      (Solved a, s) -> return (a, s)-      _ -> empty---- | Run a pure A* computation returning the solution and branch state if one was found.-runAStar :: AStar s c r a -> s -> Maybe (r, s)-runAStar m s = runIdentity $ runAStarT  m s+    runStateT m (BranchState s mempty mempty) >>= \case+          (Solved r, s) -> return (r, branchState s)+          _ -> empty --- | Run an effectful A* computation returning only the branch state-execAStarT :: (Monad m) => AStarT s c r m a -> s -> m (Maybe s)-execAStarT m s = fmap snd <$> runAStarT m s+evalAStar :: (Monoid c) => AStar s c r a -> s -> Maybe r+evalAStar m s = fst <$> runAStar m s --- | Run an effectful A* computation returning only the solution-evalAStarT :: (Monad m) => AStarT s c r m a -> s -> m (Maybe r)+evalAStarT :: (Monad m, Monoid c) => AStarT s c r m a -> s -> m (Maybe r) evalAStarT m s = fmap fst <$> runAStarT m s --- | Run a pure A* computation returning only the branch state-execAStar :: AStar s c r a -> s -> (Maybe s)+execAStar :: (Monoid c) => AStar s c r a -> s -> Maybe s execAStar m s = fmap snd $ runAStar m s --- | Run a pure A* computation returning only the solution-evalAStar :: AStar s c r a -> s -> (Maybe r)-evalAStar m s = fmap fst $ runAStar m s+execAStarT :: (Monad m, Monoid c) => AStarT s c r m a -> s -> m (Maybe s)+execAStarT m s = fmap snd <$> runAStarT m s  -- | Run a pure A* search but short-circuit when the lowest cost fails a predicate. -- -- This is useful for detecting if your search is diverging, or is likely to fail.-tryWhile :: (c -> Bool) -> AStar s c r a -> s -> (Maybe (r, s))-tryWhile p m s = runIdentity $ tryWhileT p m s+-- tryWhile :: Monoid c => (s -> c -> Bool) -> AStar s c r a -> s -> (Maybe (r, s))+-- tryWhile p m s = runIdentity $ tryWhileT p m s  -- | Effectful version of 'tryWhile'-tryWhileT :: Monad m => (c -> Bool) -> AStarT s c r m a -> s -> m (Maybe (r, s))-tryWhileT p m s = do-    stepAStar m s >>= \case-      Nothing -> return Nothing-      Just ((Pure _, s), continue) -> tryWhileT p continue s-      Just ((Weighted c, s), continue) ->-          if p c then tryWhileT p continue s-                 else return Nothing-      Just ((Solved r, s), _) -> return (Just (r, s))+-- tryWhileT :: (Monoid c, Monad m) => (s -> c -> Bool) -> AStarT s c r m a -> s -> m (Maybe (r, s))+-- tryWhileT p m s = fmap (second branchState) <$> tryWhileT' p m (BranchState s mempty mempty) +-- tryWhileT' :: (Monoid c, Monad m) => (s -> c -> Bool) -> AStarT s c r m a -> BranchState s c -> m (Maybe (r, BranchState s c))+-- tryWhileT' p m s = do+--     stepAStar m s >>= \case+--       Nothing -> return Nothing+--       Just ((Pure _, s), continue) -> tryWhileT' p continue s+--       Just ((Checkpoint, bs), continue) -> do+--           if p (branchState bs) (totalCost bs) then tryWhileT' p continue s+--                                                else return Nothing+--       Just ((Solved r, s), _) -> return (Just (r, s))+ -- NOTE probably doesn't handle state properly in returned continuation...-stepAStar :: (Monad m) => AStarT s c r m a -> s -> m (Maybe ((Step c r a, s), AStarT s c r m a))-stepAStar (AStarT m) s = fmap (fmap go) . observeT . (fmap . fmap . fmap . fmap) fst $ msplit (runStateT m s)-  where-    go (v, x) = (v, AStarT (lift x))+-- stepAStar :: (Monoid c, Monad m) => AStarT s c r m a -> BranchState s c -> m (Maybe ((Step r a, BranchState s c), AStarT s c r m a))+-- stepAStar (AStarT m) s = fmap (fmap go) . observeT . _ $ msplit (evalStateT m s)+--   where+--     go (v, x) = (v, AStarT (lift x)) -instance (Ord w, Monad m) => MonadAStar w r (AStarT s w r m) where-  updateCost c = AStarT $ pure (Weighted c) <|> return (Pure ())+instance (Ord c, Monoid c, Monad m) => MonadAStar c r (AStarT s c r m) where+  estimate c = AStarT $ modify (\bs -> bs{estimateTillDone=c}) >> (pure Checkpoint <|> pure (Pure ()))+  spend c = AStarT $ modify (\bs -> bs{cumulativeCost=cumulativeCost bs <> c}) >> (pure Checkpoint <|> pure (Pure ()))   done = AStarT . pure . Solved

@@ -19,22 +19,24 @@ -- > It should branch respecting costs using `<|>` from its 'Alternative' instance. -- > (updateCost 2 >> mx) <|> (updateCost 1 >> my) == mx <|> my -class (MonadPlus m) => MonadAStar w r m | m -> r, m -> w where-  -- | Update the cost estimate of the current branch and re-evaluate available branches,-  -- switching to a cheaper one when appropriate.-  updateCost :: w -> m ()+class (MonadPlus m, Monoid c) => MonadAStar c r m | m -> r, m -> c where+  -- | ADD to your current branch's CUMULATIVE cost. May cause a branch switch.+  spend :: c -> m () +  -- | SET the current branch's BEST-CASE-COST cost. May cause a branch switch.+  estimate :: c -> m ()+   -- | Return a solution and short-circuit any remaining branches.   done :: r -> m a  -- | Branch the search. -- -- > branch == (<|>)-branch :: MonadAStar w r m => m a -> m a -> m a+branch :: MonadAStar c r m => m a -> m a -> m a branch = (<|>)  -- | Fail the current branch. -- -- > branch == empty-failure :: MonadAStar w r m => m a+failure :: MonadAStar c r m => m a failure = empty

@@ -6,78 +6,121 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeApplications #-} import Control.Monad.AStar-import Test.Hspec hiding (Arg)+import Test.Hspec hiding (Arg, context) import Data.Foldable import Control.Lens hiding (Context) import Control.Monad.State import Control.Applicative+import Data.Monoid  data Move = U | D | L | R     deriving (Show, Eq)  data Context =-    Context { _current :: (Int, Int)-            , _goal    :: (Int, Int)-            , _moves   :: [Move]+    Context { _current   :: (Int, Int)+            , _goal      :: (Int, Int)+            , _moves     :: [Move]+            , _locations :: [(Int, Int)]             }     deriving (Show, Eq)  makeLenses ''Context +context :: (Int, Int) -> (Int, Int) -> Context+context start goal = Context start goal [] []+ main :: IO () main = hspec $ do     describe "a-star" $ do         it "should find a solution" $ do-            (view moves . snd <$> runAStar findPoint (Context (3, 6) (5, 5) []))-              `shouldBe` Just ([U, R, R])+            (fst <$> runAStar findPoint (context (3, 6) (5, 5)))+              `shouldBe` Just (5, 5)         it "should take the shortest path" $ do-            (view moves . snd <$> runAStar findPoint (Context (4, 6) (5, 5) []))-              `shouldBe` (Just [U, R])+            (view moves . snd <$> runAStar findPoint (context (4, 6) (5, 5)))+              `shouldBe` Just [R, U]         it "should take the shortest path in long situations" $ do-            (length . view moves . snd <$> runAStar findPoint (Context (4, 6) (20, 20) []))+            (length . view moves . snd <$> runAStar findPoint (context (4, 6) (20, 20)))               `shouldBe` Just 30         -- it "should properly rewind state" $ do-        --       do flip execAStar [] $ do-        --             asum [ updateCost (1 :: Int) >> modify (++ [1]) >> updateCost 10 >> modify (++ [10])-        --                  , updateCost (2 :: Int) >> modify (++ [2]) >> done ()+        --       do flip runAStar [] $ do+        --             asum [ estimate (1 :: Int) >> modify (++ [1]) >> estimate 10 >> modify (++ [10])+        --                  , estimate (2 :: Int) >> modify (++ [2]) >> done ()         --                  ]         it "should resolve with Nothing if branches return after updating cost" $ do-              do flip evalAStar () $ (updateCost @Int 1 >> return ()) <|> return ()+              do flip runAStar () $ (estimate @(Sum Int) 1 >> return ()) <|> return ()             `shouldBe`-              (Nothing :: Maybe ())+              (Nothing :: Maybe ((), ()))         it "should resolve with solution if some branches simply return" $ do-              do flip evalAStar () $ (return () <|> (updateCost @Int 1 >> done ()))-            `shouldBe`-              Just ()-        it "should resolve with solution if all branches simply return" $ do-              do flip evalAStar () $ (return () <|> return () :: AStar () () () ())+              do flip runAStar () $ (return () <|> (estimate @(Sum Int) 1 >> done ()))             `shouldBe`-              Nothing-    describe "tryWhile" $ do-        it "should stop if weight gets too high" $ do-              -- Use tuple monad to see how far we get-              do flip (tryWhileT (< 4)) () $ do-                    asum [ updateCost (10 :: Int) >> lift ([10], ()) >> empty-                          , updateCost (1 :: Int) >> lift ([1], ()) >> empty-                          , updateCost (5 :: Int) >> lift ([5], ()) >> empty-                          , updateCost (3 :: Int) >> lift ([3], ()) >> empty-                         ]+              Just ((), ())+        it "should resolve without solution if all branches simply return" $ do+              do flip runAStar () $ (return () <|> return () :: AStar () () () ())             `shouldBe`-              ([1, 3] :: [Int], Nothing :: Maybe ((), ()))+              (Nothing :: Maybe ((), ()))+    -- describe "tryWhile" $ do+    --     it "should stop if weight gets too high" $ do+    --           -- Use tuple monad to see how far we get+    --           do flip (tryWhileT (const (< 4))) () $ do+    --                 asum [ estimate (10 :: Sum Int) >> lift ([10], ()) >> empty+    --                       , estimate (1 :: Sum Int) >> lift ([1], ()) >> empty+    --                       , estimate (5 :: Sum Int) >> lift ([5], ()) >> empty+    --                       , estimate (3 :: Sum Int) >> lift ([3], ()) >> empty+    --                      ]+    --         `shouldBe`+    --           ([1, 3] :: [Int], Nothing :: Maybe ((), ()))   distanceTo :: (Int, Int) -> (Int, Int) -> Int distanceTo (x, y) (x', y') = abs (x - x') + abs (y - y') -findPoint :: AStar Context Int () ()+move :: Monad m => Move -> AStarT Context (Sum Int) r m ()+move L = moves <>= [L] >> current . _1 -= 1+move R = moves <>= [R] >> current . _1 += 1+move U = moves <>= [U] >> current . _2 -= 1+move D = moves <>= [D] >> current . _2 += 1++findPoint :: AStar Context (Sum Int) (Int, Int) () findPoint = do     c <- use current     gl <- use goal-    when (c == gl) $ done ()-    updateCost $ distanceTo gl c+    when (c == gl) $ done gl+    estimate . Sum $ distanceTo gl c     asum-        [ moves <>= [R] >> current . _1 += 1 >> findPoint-        , moves <>= [L] >> current . _1 -= 1 >> findPoint-        , moves <>= [D] >> current . _2 += 1 >> findPoint-        , moves <>= [U] >> current . _2 -= 1 >> findPoint+        [ move L >> findPoint+        , move R >> findPoint+        , move U >> findPoint+        , move D >> findPoint+        ]++-- To make things more interesting we'll say that moving through coordinates+-- where either 'x' or 'y' are divisible by the other is 3X more expensive!+addCost :: MonadAStar (Sum Int) r m => (Int, Int) -> m ()+-- Don't divide by zero!+addCost (0, _) = spend 1+addCost (_, 0) = spend 1+addCost (x, y)+    | mod x y == 0 || mod y x == 0 = spend 3+addCost _ = spend 1+++mineField :: AStar Context (Sum Int) (Int, Int) ()+mineField = do+    -- Get the current position+    (x, y) <- use current+    -- Add the current location to our list+    locations <>= [(x, y)]+    -- If we're at the goal we're done!+    gl <- use goal+    when ((x, y) == gl)+      $ done gl+    -- Add the cost of the current position+    addCost (x, y)+    -- Estimate steps to completion+    estimate . Sum $ distanceTo gl (x, y)+    asum+        [ move L >> mineField+        , move R >> mineField+        , move U >> mineField+        , move D >> mineField         ]