summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChrisPenner <>2019-09-10 17:35:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-09-10 17:35:00 (GMT)
commit9f61f1bd0207dfff966c1cc816e5b9b28cad9bc0 (patch)
tree47d33f39351c679728ca7e6b2fe10af985d8b36d
version 0.1.0.00.1.0.0
-rw-r--r--ChangeLog.md3
-rw-r--r--LICENSE30
-rw-r--r--README.md73
-rw-r--r--Setup.hs2
-rw-r--r--astar-monad.cabal58
-rw-r--r--src/Control/Monad/AStar.hs192
-rw-r--r--src/Control/Monad/AStar/Class.hs15
-rw-r--r--test/Spec.hs65
8 files changed, 438 insertions, 0 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..9987b25
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for astart
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c811151
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Chris Penner (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Chris Penner nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..00a2282
--- /dev/null
+++ b/README.md
@@ -0,0 +1,73 @@
+A\* Monad
+=========
+
+Easily do A\* searches with use of arbitrary monadic effects!
+
+## 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.
+* 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!
+
+Here's an example of using A\* to find a path to a location in a 2 dimensional grid.
+
+```haskell
+-- Track which moves we've made, up, down, left or right
+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.
+data Context =
+ Context { _currentPos :: (Int, Int)
+ , _goal :: (Int, Int)
+ , _moves :: [Move]
+ }
+ deriving (Show, Eq)
+makeLenses ''Context
+
+-- The Manhattan distance between two points
+-- This is our A* heuristic
+distanceTo :: (Int, Int) -> (Int, Int) -> Int
+distanceTo (x, y) (x', y') = abs (x - x') + abs (y - y')
+
+-- Move around the space looking for the destination point.
+findPoint :: AStar Context Int () ()
+findPoint = do
+ c <- use currentPos
+ 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.
+ 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
+ ]
+
+-- We only care about the ending state, so we use `execAStar`
+-- `runAStarT` is the most powerful and runs a monad-transformer version
+-- and returns both the state and result type.
+run :: Maybe Context
+run = execAStar findPoint
+ Context { _current = (5, 5)
+ , _goal = (7, 4)
+ , _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]
+ })
+```
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/astar-monad.cabal b/astar-monad.cabal
new file mode 100644
index 0000000..47a9bd9
--- /dev/null
+++ b/astar-monad.cabal
@@ -0,0 +1,58 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 9b0da561d4a2aab07a5b16f423b1a711563fb04085433460b4f91879142f5f9b
+
+name: astar-monad
+version: 0.1.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
+author: Chris Penner
+maintainer: christopher.penner@gmail.com
+copyright: Chris Penner
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+ ChangeLog.md
+
+source-repository head
+ type: git
+ location: https://github.com/ChrisPenner/astar-monad
+
+library
+ exposed-modules:
+ Control.Monad.AStar
+ Control.Monad.AStar.Class
+ other-modules:
+ Paths_astar_monad
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -Wno-name-shadowing
+ build-depends:
+ base >=4.7 && <5
+ , logict
+ , mtl
+ default-language: Haskell2010
+
+test-suite astar-monad-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Paths_astar_monad
+ hs-source-dirs:
+ test
+ ghc-options: -Wall -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ astar-monad
+ , base >=4.7 && <5
+ , hspec
+ , lens
+ , logict
+ , mtl
+ default-language: Haskell2010
diff --git a/src/Control/Monad/AStar.hs b/src/Control/Monad/AStar.hs
new file mode 100644
index 0000000..f843079
--- /dev/null
+++ b/src/Control/Monad/AStar.hs
@@ -0,0 +1,192 @@
+{-|
+Module : Control.Monad.AStar
+Description : Provides a monad transformer for A* search. See README for details and examples.
+Copyright : (c) Chris Penner, 2019
+License : BSD3
+
+See the <https://github.com/chrispenner/astar-monad README> for usage info and examples.
+
+-}
+
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Control.Monad.AStar
+ (
+ -- * Types
+ AStar
+ , AStarT
+
+ -- * Methods
+ , MonadAStar(..)
+
+ -- * Executing Search
+ , runAStarT
+ , execAStarT
+ , evalAStarT
+ , runAStar
+ , execAStar
+ , evalAStar
+
+ , tryWhile
+ , tryWhileT
+ )
+ where
+
+import Control.Monad.AStar.Class
+import Control.Monad.Except
+import Control.Monad.Fail
+import Control.Monad.Logic
+import Control.Applicative
+import Control.Monad.State
+import Data.Functor.Identity
+import Data.Maybe
+
+data Step c r a = Pure a | Weighted c | Solved r
+ deriving (Show, Functor, Eq)
+
+-- | Non-transformer version of 'AStarT'
+type AStar s c r a = AStarT s c r Identity a
+
+-- | The 'AStar' search monad transformer
+--
+-- Lots of type variables here:
+--
+-- @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'.
+--
+-- @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.
+--
+-- @m@: An arbitrary monad which will be threaded through.
+--
+-- 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)
+ } 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
+ liftIO io = lift $ liftIO io
+
+instance (Monad m, Ord c) => Applicative (AStarT s c r m) where
+ pure = return
+ (<*>) = ap
+
+instance (Ord 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
+ 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 (Monad m, 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) => 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 (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' ma mb = do
+ beforeBoth <- get
+ (rA, lState) <- liftA2 (,) (msplit ma) get
+ put beforeBoth
+ (rB, rState) <- liftA2 (,) (msplit mb) get
+ 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))
+ <|> ((put lState >> lm) `weightedInterleave'` (put rState >> reflect r))
+ | 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)
+
+-- | 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 (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
+
+-- | 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
+
+-- | Run an effectful A* computation returning only the solution
+evalAStarT :: (Monad m) => 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 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
+
+-- | 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
+
+-- | 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))
+
+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
new file mode 100644
index 0000000..2604143
--- /dev/null
+++ b/src/Control/Monad/AStar/Class.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Control.Monad.AStar.Class (MonadAStar(..)) where
+
+-- | 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
+
+ -- | 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
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..5b5a41f
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BlockArguments #-}
+import Control.Monad.AStar
+import Test.Hspec hiding (Arg)
+import Data.Foldable
+import Control.Lens hiding (Context)
+import Control.Monad.State
+import Control.Applicative
+
+data Move = U | D | L | R
+ deriving (Show, Eq)
+
+data Context =
+ Context { _current :: (Int, Int)
+ , _goal :: (Int, Int)
+ , _moves :: [Move]
+ }
+ deriving (Show, Eq)
+
+makeLenses ''Context
+
+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])
+ it "should take the shortest path" $ do
+ (view moves . snd <$> runAStar findPoint (Context (4, 6) (5, 5) []))
+ `shouldBe` (Just [U, R])
+ it "should take the shortest path in long situations" $ do
+ (length . view moves . snd <$> runAStar findPoint (Context (4, 6) (20, 20) []))
+ `shouldBe` Just 30
+ 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
+ ]
+ `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 () ()
+findPoint = do
+ c <- use current
+ gl <- use goal
+ when (c == gl) $ done ()
+ updateCost $ 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
+ ]