diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,10 @@ A\* Monad ========= +[Hackage](http://hackage.haskell.org/package/astar-monad) + +**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! ## Basics @@ -9,7 +13,7 @@ * 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. * Call `done mySolution` to short circuit ALL running branches and immediately return your result. -* `AStarT` has a built-in State monad which **automatically keeps state contiguous in spite of branching**. This means that your state monad will properly switch states when switching branches. Just use state normally, it should work as expected. 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! +* `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! Here's an example of using A\* to find a path to a location in a 2 dimensional grid. @@ -71,3 +75,8 @@ , _moves = [U, R, R] }) ``` + + +## Known Issues + +Currently, computation will **hang** if the end of a branch "finishes" without calling `done` or `failure`; so don't do that. diff --git a/astar-monad.cabal b/astar-monad.cabal --- a/astar-monad.cabal +++ b/astar-monad.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 9b0da561d4a2aab07a5b16f423b1a711563fb04085433460b4f91879142f5f9b +-- hash: dd7ab531bbfc60dd1505d0488c11c684b9259708a61f021be586d938d7d5d5a8 name: astar-monad -version: 0.1.0.0 +version: 0.2.0.0 description: Please see the README on GitHub at homepage: https://github.com/ChrisPenner/astar-monad#readme bug-reports: https://github.com/ChrisPenner/astar-monad/issues diff --git a/src/Control/Monad/AStar.hs b/src/Control/Monad/AStar.hs --- a/src/Control/Monad/AStar.hs +++ b/src/Control/Monad/AStar.hs @@ -22,6 +22,8 @@ -- * Methods , MonadAStar(..) + , branch + , failure -- * Executing Search , runAStarT @@ -110,6 +112,13 @@ 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) + instance (Ord c, Monad m) => Alternative (AStarT s c r m) where empty = AStarT empty (<|>) = weightedInterleave @@ -135,7 +144,10 @@ | otherwise -> (put rState >> pure (Weighted rw)) <|> ((put rState >> rm) `weightedInterleave'` (put lState >> reflect l)) - (l, r) -> (put lState >> reflect l) `weightedInterleave'` (put rState >> reflect r) + ((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 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)) @@ -181,12 +193,12 @@ 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)) instance (Ord w, Monad m) => MonadAStar w r (AStarT s w r m) where - branch = (<|>) updateCost c = AStarT $ pure (Weighted c) <|> return (Pure ()) done = AStarT . pure . Solved diff --git a/src/Control/Monad/AStar/Class.hs b/src/Control/Monad/AStar/Class.hs --- a/src/Control/Monad/AStar/Class.hs +++ b/src/Control/Monad/AStar/Class.hs @@ -1,15 +1,40 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -module Control.Monad.AStar.Class (MonadAStar(..)) where +module Control.Monad.AStar.Class (MonadAStar(..), branch, failure) where +import Control.Monad +import Control.Applicative -- | A class which represents the ability to do A* search. -class MonadAStar w r m | m -> r, m -> w where - -- | Branch the search - branch :: m a -> m a -> m a +-- +-- The laws aren't completely pinned down yet, but these should probably hold: +-- +-- > It should short-circuit on 'done' +-- > done a >> mx == done a +-- > done a <|> mx == done a +-- > +-- > It should fail a branch using `empty`. +-- > empty >> mx == empty +-- > empty <|> mx == mx +-- > +-- > 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 () -- | 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 = (<|>) + +-- | Fail the current branch. +-- +-- > branch == empty +failure :: MonadAStar w r m => m a +failure = empty diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeApplications #-} import Control.Monad.AStar import Test.Hspec hiding (Arg) import Data.Foldable @@ -35,6 +36,23 @@ it "should take the shortest path in long situations" $ do (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 () + -- ] + it "should resolve with Nothing if branches return after updating cost" $ do + do flip evalAStar () $ (updateCost @Int 1 >> return ()) <|> return () + `shouldBe` + (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 () () () ()) + `shouldBe` + Nothing describe "tryWhile" $ do it "should stop if weight gets too high" $ do -- Use tuple monad to see how far we get