monad-dijkstra 0.1.1.1 → 0.1.1.2

raw patch · 2 files changed

+91/−45 lines, 2 filesdep +containersdep ~basedep ~psqueuesdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers

Dependency ranges changed: base, psqueues, transformers

API changes (from Hackage documentation)

Files

• monad-dijkstra.cabal +4/−3
• src/Control/Monad/Search.hs +87/−42

@@ -1,7 +1,7 @@ name:                monad-dijkstra-version:             0.1.1.1-synopsis:            Monad transformer for weighted graph searches using Dijkstra's or A* algorithm-description:         Please see README.md+version:             0.1.1.2+synopsis:            A monad transformer for weighted graph searches+description:         A monad transformer for weighted graph searches using Dijkstra's or A* algorithm. homepage:            https://github.com/ennocramer/monad-dijkstra license:             BSD3 license-file:        LICENSE@@ -16,6 +16,7 @@   hs-source-dirs:      src   exposed-modules:     Control.Monad.Search   build-depends:       base >= 4.7 && < 5+                     , containers >= 0.5.6.2 && < 0.6.1                      , transformers >= 0.4.2.0 && < 0.5.6                      , mtl >= 2.2.0 && < 2.3                      , free >= 4.12.0 && < 5.2

@@ -61,34 +61,64 @@     , winner     ) where -import           Control.Applicative         ( Alternative(..) )-import           Control.Monad               ( MonadPlus(..) )-import           Control.Monad.Trans.Free    ( FreeF(Free, Pure), FreeT-                                             , runFreeT, wrap )-import           Control.Monad.Trans.State   ( evalStateT, gets, modify )+import           Control.Applicative             ( Alternative(..) )+import           Control.Monad                   ( MonadPlus(..) ) -import           Control.Monad.Trans.Class   ( MonadTrans, lift )-import           Control.Monad.IO.Class      ( MonadIO )-import           Control.Monad.Reader        ( MonadReader, ReaderT(..)-                                             , runReaderT )-import qualified Control.Monad.Writer.Lazy   as Lazy ( MonadWriter, WriterT(..)-                                                     , runWriterT )-import qualified Control.Monad.Writer.Strict as Strict ( WriterT(..)-                                                       , runWriterT )-import qualified Control.Monad.State.Lazy    as Lazy ( MonadState, StateT(..)-                                                     , runStateT )-import qualified Control.Monad.State.Strict  as Strict ( StateT(..), runStateT )-import qualified Control.Monad.RWS.Lazy      as Lazy ( MonadRWS, RWST(..)-                                                     , runRWST )-import qualified Control.Monad.RWS.Strict    as Strict ( RWST(..), runRWST )-import           Control.Monad.Except        ( ExceptT(..), MonadError-                                             , runExceptT )-import           Control.Monad.Cont          ( MonadCont )-import           Data.Functor.Identity       ( Identity, runIdentity )-import           Data.Maybe                  ( catMaybes, listToMaybe )+import           Control.Monad.Cont              ( MonadCont )+import           Control.Monad.Except            ( ExceptT(..), MonadError+                                                 , runExceptT )+import           Control.Monad.IO.Class          ( MonadIO ) -import qualified Data.OrdPSQ                 as PSQ+import qualified Control.Monad.RWS.Lazy          as Lazy ( MonadRWS, RWST(..)+                                                         , runRWST )+import qualified Control.Monad.RWS.Strict        as Strict ( RWST(..), runRWST )+import           Control.Monad.Reader            ( MonadReader, ReaderT(..)+                                                 , runReaderT ) +import qualified Control.Monad.State.Lazy        as Lazy ( MonadState+                                                         , StateT(..)+                                                         , runStateT )+import qualified Control.Monad.State.Strict      as Strict ( StateT(..)+                                                           , runStateT )+import           Control.Monad.Trans.Class       ( MonadTrans, lift )+import           Control.Monad.Trans.Free        ( FreeF(Free, Pure), FreeT+                                                 , runFreeT, wrap )+import           Control.Monad.Trans.Free.Church ( FT, fromFT )+import           Control.Monad.Trans.State       ( evalStateT, gets, modify )++import qualified Control.Monad.Writer.Lazy       as Lazy ( MonadWriter+                                                         , WriterT(..)+                                                         , runWriterT )+import qualified Control.Monad.Writer.Strict     as Strict ( WriterT(..)+                                                           , runWriterT )++import           Data.Functor.Identity           ( Identity, runIdentity )+import qualified Data.IntPSQ                     as PSQ+import qualified Data.IntMap.Strict              as Map+import           Data.Maybe                      ( catMaybes, listToMaybe )+import qualified Data.IntSet                     as Set++newtype Scopemap = Scopemap { unScopemap :: Map.IntMap Set.IntSet }++singleton  :: Int -> Int -> Scopemap+singleton k = Scopemap . Map.singleton k . Set.singleton++insert :: Int -> Int -> Scopemap -> Scopemap+insert k v = Scopemap . Map.alter fn k . unScopemap+  where+    fn = Just . maybe (Set.singleton v) (Set.insert v)++delete :: Int -> Int -> Scopemap -> Scopemap+delete k v = Scopemap . Map.update fn k . unScopemap+  where+    fn = (\s -> if Set.null s then Nothing else Just s) . Set.delete v++list :: Int -> Scopemap -> [Int]+list k = maybe [] Set.toList . Map.lookup k . unScopemap++listAll :: Scopemap -> [Int]+listAll = Set.toList . foldr (Set.union . snd) Set.empty . Map.toList . unScopemap+ -- | The Search monad type Search c = SearchT c Identity @@ -110,7 +140,7 @@     deriving Functor  -- | The SearchT monad transformer-newtype SearchT c m a = SearchT { unSearchT :: FreeT (SearchF c) m a }+newtype SearchT c m a = SearchT { unSearchT :: FT (SearchF c) m a }     deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadReader r, Lazy.MonadWriter w, Lazy.MonadState s, MonadError e, MonadCont)  instance (Ord c, Monoid c, Monad m) => Alternative (SearchT c m) where@@ -128,9 +158,10 @@                        }  -- | State used during evaluation of SearchT-data St c m a = St { stNum   :: !Int-                   , stScope :: !Int-                   , stQueue :: !(PSQ.OrdPSQ Int c (Cand c m a))+data St c m a = St { stNum    :: !Int+                   , stScope  :: !Int+                   , stActive :: !Scopemap+                   , stQueue  :: !(PSQ.IntPSQ c (Cand c m a))                    }  -- | Generate all solutions in order of increasing cost.@@ -152,28 +183,34 @@             Free Abandon -> return Nothing             Free (Cost c e p) ->                 let newCost = candCost `mappend` c-                    newPriority = newCost `mappend` e+                    newPriority = max prio $ newCost `mappend` e                 in do-                    updateQueue $-                        PSQ.insert num-                                   newPriority-                                   cand { candCost = newCost, candPath = p }-                    return Nothing+                    reschedule <- gets (maybe False+                                              (\(_, x, _) -> x <= newPriority) .+                                            PSQ.findMin . stQueue)+                    let cand' = cand { candCost = newCost, candPath = p }+                    if reschedule+                        then do+                            updateQueue $ PSQ.insert num newPriority cand'+                            return Nothing+                        else step num newPriority cand'             Free (Alt lhs rhs) -> do                 num' <- nextNum+                addScopes candScope num'                 updateQueue $ PSQ.insert num' prio cand { candPath = rhs }                 step num prio cand { candPath = lhs }             Free (Enter p) -> do                 scope <- nextScope+                addScope scope num                 step num                      prio                      cand { candScope = scope : candScope, candPath = p }-            Free (Exit p) ->+            Free (Exit p) -> do+                delScope (head candScope) num                 step num prio cand { candScope = tail candScope, candPath = p }             Free (Collapse p) -> do-                updateQueue $ PSQ.fromList .-                    filter (\(_, _, c) -> not $ hasScope (head candScope) c) .-                        PSQ.toList+                cs <- listScope $ listToMaybe candScope+                updateQueue $ \q -> foldr PSQ.delete q cs                 step num prio cand { candPath = p }      nextNum = do@@ -184,13 +221,21 @@         modify $ \s -> s { stScope = stScope s + 1 }         gets stScope -    hasScope s Cand{..} = s `elem` candScope+    addScope scope c = updateActive $ insert scope c +    addScopes scopes c = updateActive $ \sm -> foldr (`insert` c) sm scopes++    delScope scope c = updateActive $ delete scope c++    listScope scope = gets $ maybe listAll list scope . stActive+     updateQueue f = modify $ \s -> s { stQueue = f (stQueue s) } -    state = St 0 0 queue+    updateActive f = modify $ \s -> s { stActive = f (stActive s) } -    queue = PSQ.singleton 0 mempty (Cand mempty [ 0 ] (unSearchT m))+    state = St 0 0 (singleton 0 0) queue++    queue = PSQ.singleton 0 mempty (Cand mempty [ 0 ] (fromFT $ unSearchT m))  -- | Generate only the best solutions. runSearchBestT :: (Ord c, Monoid c, Monad m) => SearchT c m a -> m (Maybe (c, a))