packages feed

astar-monad (empty) → 0.1.0.0

raw patch · 8 files changed

+438/−0 lines, 8 filesdep +astar-monaddep +basedep +hspecsetup-changed

Dependencies added: astar-monad, base, hspec, lens, logict, mtl

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for astart++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -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]+              })+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ astar-monad.cabal view
@@ -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
+ src/Control/Monad/AStar.hs view
@@ -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
+ src/Control/Monad/AStar/Class.hs view
@@ -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
+ test/Spec.hs view
@@ -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+        ]