packages feed

logict-state (empty) → 0.1.0.0

raw patch · 8 files changed

+656/−0 lines, 8 filesdep +basedep +logictdep +mtlsetup-changed

Dependencies added: base, logict, mtl, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Atze Dijkstra++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 Atze Dijkstra 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ logict-state.cabal view
@@ -0,0 +1,35 @@+-- Initial logict-backtrack.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                logict-state+version:             0.1.0.0+synopsis:            Library for logic programming based on haskell package logict+description:         Logic programming built on top of part of logict library, in particular for dealing with backtrackable state+homepage:            https://github.com/atzedijkstra/logict-state+license:             BSD3+license-file:        LICENSE+author:              Atze Dijkstra+maintainer:          atzedijkstra@gmail.com+-- copyright:           +category:            Development+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/atzedijkstra/logict-state.git++library+  exposed-modules:     Control.Monad.LogicState,+                       Control.Monad.LogicState.Class,+                       Control.Monad.TransLogicState.Class,+                       Control.Monad.LogicState.Examples+  other-modules:       Control.Monad.LogicState.Logic+  default-extensions:  MultiParamTypeClasses+  build-depends:       base >=4.8 && <4.9,+                       mtl >= 2.1,+                       transformers >= 0.4.2,+                       logict >= 0.6.0.2+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Control/Monad/LogicState.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE UndecidableInstances, Rank2Types, FlexibleInstances, FlexibleContexts, GADTs, ScopedTypeVariables, FunctionalDependencies #-}++-------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.LogicState+-- Copyright   : (c) Atze Dijkstra+-- License     : BSD3+--+-- Maintainer  : atzedijkstra@gmail.com+-- Stability   : experimental, (as of 20160218) under development+-- Portability : non-portable+--+-- A backtracking, logic programming monad partially derived and on top of logict, adding backtrackable state.+--+--    LogicT (and thus this library as well) is adapted from the paper+--    /Backtracking, Interleaving, and Terminating+--        Monad Transformers/, by+--    Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry+--    (<http://www.cs.rutgers.edu/~ccshan/logicprog/LogicT-icfp2005.pdf>).+--+-- +-------------------------------------------------------------------------++module Control.Monad.LogicState (+    module Control.Monad.Logic.Class,+    module Control.Monad,+    module Control.Monad.Trans,+    module Control.Monad.LogicState.Class,+    module Control.Monad.TransLogicState.Class,+    -- * The LogicVar monad+    -- LogicVar,+    LogicState,+    {-+    logicVar,+    runLogicVar,+    -- * The LogicVarT monad transformer+    -}+    -- LogicVarT(..),+    {-+    runLogicVarT,+    -}+    LogicStateT(..),+  ) where++import Data.Maybe+import Data.Typeable++import Control.Applicative++import Control.Monad+import Control.Monad.Identity+import Control.Monad.Trans++import Control.Monad.State+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class++import Data.Monoid (Monoid(mappend, mempty))+import qualified Data.Foldable as F+import qualified Data.Traversable as T++import Control.Monad.Logic.Class++import Control.Monad.LogicState.Class+import Control.Monad.TransLogicState.Class++-------------------------------------------------------------------------+-- | A monad transformer for performing backtracking computations+-- layered over another monad 'm', with propagation of global and backtracking state, e.g. resp. for freshness/uniqueness and maintaining variable mappings.+newtype LogicStateT gs bs m a =+    LogicStateT { unLogicStateT ::+      forall r. LogicContS gs bs r m a+    }++-- | Convenience types+type LogicStateS gs bs r m = StateT (gs,bs) m r -- (gs,bs) -> m (r,(gs,bs))+type LogicContS gs bs r m a =+           (   a                                 --  result+            -> LogicStateS gs bs r m             --  failure continuation+            -> LogicStateS gs bs r m+           )                                     -- ^ success continuation+        -> LogicStateS gs bs r m                 -- ^ failure continuation+        -> LogicStateS gs bs r m                 -- ^ global + backtracking state++instance Functor (LogicStateT gs bs f) where+    fmap f lt = LogicStateT $ \sk -> unLogicStateT lt (sk . f)++instance Applicative (LogicStateT gs bs f) where+    pure a = LogicStateT $ \sk -> sk a+    f <*> a = LogicStateT $ \sk -> unLogicStateT f (\g -> unLogicStateT a (sk . g))++instance Monad (LogicStateT gs bs m) where+    return a = LogicStateT ($ a)+    m >>= f = LogicStateT $ \sk -> unLogicStateT m (\a -> unLogicStateT (f a) sk)+    fail _ = LogicStateT $ flip const++instance Alternative (LogicStateT gs bs f) where+    empty = LogicStateT $ flip const+    -- state backtracking variant, but in general interacts badly with other combinators using msplit. Backtracking separately available.+    -- f1 <|> f2 = LogicStateT $ \sk fk -> StateT $ \s@(_,bs) -> runStateT (unLogicStateT f1 sk (StateT $ \(gs',_) -> runStateT (unLogicStateT f2 sk fk) (gs',bs))) s+    f1 <|> f2 = LogicStateT $ \sk fk -> unLogicStateT f1 sk (unLogicStateT f2 sk fk)++instance MonadPlus (LogicStateT gs bs m) where+  mzero = empty+  {-# INLINE mzero #-}+  mplus = (<|>)+  {-# INLINE mplus #-}++instance MonadTrans (LogicStateT gs bs) where+    lift m = LogicStateT $ \sk fk -> StateT $ \s -> m >>= \a -> runStateT (sk a fk) s++instance (MonadIO m) => MonadIO (LogicStateT gs bs m) where+    liftIO = lift . liftIO++instance {-# OVERLAPPABLE #-} MonadState s m => MonadState s (LogicStateT gs bs m) where+    get = lift get+    put = lift . put++instance MonadReader r m => MonadReader r (LogicStateT gs bs m) where+    ask = lift ask+    local f m = LogicStateT $ \sk fk -> StateT $ runStateT $ unLogicStateT m (\a fk -> StateT $ local f . runStateT (sk a fk)) (StateT $ local f . runStateT fk)++{-+instance MonadError e m => MonadError e (LogicStateT gs bs m) where+  throwError = lift . throwError+  catchError m h = LogicStateT $ \sk fk -> StateT $ \s -> let+      handle r = r `catchError` \e -> put s >> unLogicStateT (h e) sk fk+    in handle $ put s >> unLogicStateT m (\a fk' -> sk a (handle . fk')) fk+-}++{-+instance MonadError e m => MonadError e (LogicStateT gs bs m) where+  throwError = lift . throwError+  catchError m h = LogicStateT $ \sk fk -> StateT $ \s -> let+      handle r = r `catchError` \e -> StateT $ \_ -> runStateT (unLogicStateT (h e) sk fk) s+    in handle $ StateT $ \_ -> runStateT (unLogicStateT m (\a fk' -> sk a (handle . fk')) fk) s+-}++{-+-}+instance (Monad m) => MonadLogic (LogicStateT gs bs m) where+    msplit m =+       liftWithState $ runStateT $ unLogicStateT m+         (\a fk -> return (Just (a, liftWithState (runStateT fk) >>= reflect)))+         (return Nothing)++instance TransLogicState (gs,bs) (LogicStateT gs bs) where+  observeT s lt = evalStateT (unLogicStateT lt (\a _ -> return a) (fail "No answer.")) s+  +  observeAllT s m = evalStateT (unLogicStateT m+    (\a fk -> fk >>= \as -> return (a:as))+    (return []))+    s+  +  observeManyT s n m = evalStateT (obs n m) s+   where+     obs n m+        | n <= 0 = return []+        | n == 1 = unLogicStateT m (\a _ -> return [a]) (return [])+        | otherwise = unLogicStateT (msplit m) sk (return [])+     +     sk Nothing _ = return []+     sk (Just (a, m')) _ = StateT $ \s -> (\as -> (a:as,s)) `liftM` observeManyT s (n-1) m'++  liftWithState m = LogicStateT $ \sk fk -> StateT $ \s -> m s >>= \(a,s) -> runStateT (sk a fk) s+  {-# INLINE liftWithState #-}++instance Monad m => MonadState (gs,bs) (LogicStateT gs bs m) where+    get   = LogicStateT $ \sk fk -> get >>= \s -> sk s fk+    put s = LogicStateT $ \sk fk -> put s >>= \a -> sk a fk++instance (Monad m) => MonadLogicState (gs,bs) (LogicStateT gs bs m) where+    backtrack m = get >>= \(_::gs,bs) -> return $ LogicStateT $ \sk fk -> StateT $ \(gs,_) -> runStateT (unLogicStateT m sk fk) (gs,bs)+++-------------------------------------------------------------------------+-- | The basic LogicVar monad, for performing backtracking computations+-- returning values of type 'a'+type LogicState gs bs = LogicStateT gs bs Identity++{-+-------------------------------------------------------------------------+-- | A monad transformer for performing backtracking computations+-- layered over another monad 'm', with propagation of global and backtracking state, e.g. resp. for freshness/uniqueness and maintaining variable mappings.+newtype LogicVarT gs bs m a =+    LogicVarT { unLogicVarT ::+      forall r. {- (Typeable r) => -} LogicCont gs bs r m a+    }++-- | Convenience types+type LogicStateT gs bs r m = (gs,bs) -> m (r,(gs,bs)) -- StateT (gs,bs) m r -- (gs,bs) -> m (r,(gs,bs))+type LogicCont gs bs r m a =+           (   a                                -- ^ result+            -> LogicState gs bs r m             -- ^ failure continuation+            -> LogicState gs bs r m+           )                                    -- ^ success continuation+        -> LogicState gs bs r m                 -- ^ failure continuation+        -> LogicState gs bs r m                 -- ^ global + backtracking state++instance Functor (LogicVarT gs bs f) where+    fmap f lt = LogicVarT $ \sk -> unLogicVarT lt (sk . f)++instance Applicative (LogicVarT gs bs f) where+    pure a = LogicVarT $ \sk -> sk a+    f <*> a = LogicVarT $ \sk -> unLogicVarT f (\g -> unLogicVarT a (sk . g))++instance Monad (LogicVarT gs bs m) where+    return a = LogicVarT $ \sk -> sk a+    m >>= f = LogicVarT $ \sk -> unLogicVarT m (\a -> unLogicVarT (f a) sk)+    fail _ = LogicVarT $ \_ fk -> fk++instance Alternative (LogicVarT gs bs f) where+    empty = LogicVarT $ \_ fk -> fk+    f1 <|> f2 = LogicVarT $ \sk fk s@(_,bs) -> unLogicVarT f1 sk (\(gs',_) -> unLogicVarT f2 sk fk (gs',bs)) s++instance MonadPlus (LogicVarT gs bs m) where+  mzero = empty+  {-# INLINE mzero #-}+  mplus = (<|>)+  {-# INLINE mplus #-}++instance MonadTrans (LogicVarT gs bs) where+    lift m = LogicVarT $ \sk fk s -> m >>= \a -> sk a fk s++instance (MonadIO m) => MonadIO (LogicVarT gs bs m) where+    liftIO = lift . liftIO+-}++{-+data ResultLV gs bs r m a where+    DoneR :: ResultLV gs bs r m a+    NextR :: a -> LogicCont gs bs r m a -> ResultLV gs bs r m a+-}++{-+instance (Monad m, F.Foldable m) => F.Foldable (LogicVarT m) where+    foldMap f m = F.fold $ unLogicVarT m (liftM . mappend . f) (return mempty)++instance T.Traversable (LogicVarT Identity) where+    traverse g l = runLogicVar l (\a ft -> cons <$> g a <*> ft) (pure mzero)+     where cons a l' = return a `mplus` l'+-}++{-+-- Needs undecidable instances+instance MonadReader r m => MonadReader r (LogicVarT gs bs m) where+    ask = lift ask+    local f m = LogicVarT $ \sk fk -> unLogicVarT m (\a fk -> local f . sk a fk) (local f . fk)+    -- ((local f .) . sk) (local f fk)+    -- (\a -> (local f .) $ \fk -> sk a fk) (local f fk)++-- Needs undecidable instances+instance MonadState s m => MonadState s (LogicVarT gs bs m) where+    get = lift get+    put = lift . put++-- Needs undecidable instances+instance MonadError e m => MonadError e (LogicVarT gs bs m) where+  throwError = lift . throwError+  catchError m h = LogicVarT $ \sk fk s -> let+      handle r = r `catchError` \e -> unLogicVarT (h e) sk fk s+    in handle $ unLogicVarT m (\a fk' -> sk a (handle . fk')) fk s+-}+{-+  catchError m h = LogicT $ \sk fk -> let+      handle r = r `catchError` \e -> unLogicT (h e) sk fk+    in handle $ unLogicT m (\a -> sk a . handle) fk+-}++{-+instance (Monad m) => MonadLogic (LogicVarT gs bs m) where+    msplit m =+       liftWithState $ unLogicVarT m+         (\a fk s -> return (Just (a, liftWithState fk >>= reflect), s))+         (\s -> return (Nothing,s))+-}+{-+    msplit m =+       liftWithState $ \s -> unLogicVarT m s+         (\a s2@(gs2,bs2) fk -> return+           ( Just ( a+                  , do ma <- liftWithState fk -- $ \s3@(gs3,bs3::bs) -> fk s3 -- >>= \(a,s@(gs,bs)) -> return (a,s))+                       reflect ma+                  )+           , s2+           ))+         (\s -> return (Nothing,s))+-}+{-+    interleave m1 m2 = msplit m1 >>=+                        maybe m2 (\(a, m1') -> return a `mplus` interleave m2 m1')++    m >>- f = do (a, m') <- maybe mzero return =<< msplit m+                 interleave (f a) (m' >>- f)++    ifte t th el = msplit t >>= maybe el (\(a,m) -> th a `mplus` (m >>= th))++    once m = do (a, _) <- maybe mzero return =<< msplit m+                return a+-}++{-+instance (Monad m) => MonadLogicState (gs,bs) (LogicVarT gs bs m) where+    lvGet = LogicVarT $ \sk fk s -> sk s fk s+    lvModifyGet f = LogicVarT $ \sk fk s -> let (x,s') = f s in sk x fk s'++instance TransLogicState (gs,bs) (LogicVarT gs bs) where+  -------------------------------------------------------------------------+  -- | Extracts the first result from a LogicVarT computation,+  -- failing otherwise.+  observeT s lt = fmap fst $ unLogicVarT lt (\a _ s -> return (a,s)) (\_ -> fail "No answer.") s+  +  -------------------------------------------------------------------------+  -- | Extracts all results from a LogicVarT computation.+  observeAllT s m = fmap fst $ unLogicVarT m+    (\a fk s -> fk s >>= \(as,s') -> return (a:as, s'))+    (\s -> return ([],s))+    s+  +  -------------------------------------------------------------------------+  -- | Extracts up to a given number of results from a LogicVarT computation.+  observeManyT s n m = fmap fst $ obs s n m+   where+     obs s n m+        | n <= 0 = return ([],s)+        | n == 1 = unLogicVarT m (\a _ s -> return ([a],s)) (\s -> return ([],s)) s+        | otherwise = unLogicVarT (msplit m) sk (\s -> return ([],s)) s+     +     sk Nothing _ s = return ([],s)+     sk (Just (a, m')) _ s = (\as -> (a:as,s)) `liftM` observeManyT s (n-1) m'++  -- |+  liftWithState m = LogicVarT $ \sk fk s -> m s >>= \(a,s) -> sk a fk s+-}++{-+  +-------------------------------------------------------------------------+-- | Runs a LogicVarT computation with the specified initial success and+-- failure continuations.+runLogicVarT :: LogicVarT m a -> (a -> m r -> m r) -> m r -> m r+runLogicVarT = unLogicVarT+-}++{-+-------------------------------------------------------------------------+-- | The basic LogicVar monad, for performing backtracking computations+-- returning values of type 'a'+type LogicVar gs bs = LogicVarT gs bs Identity++-------------------------------------------------------------------------+-- | A smart constructor for LogicVar computations.+logicVar :: (forall r. (a -> r -> r) -> r -> r) -> LogicVar a+logicVar f = LogicVarT $ \k -> Identity .+                         f (\a -> runIdentity . k a . Identity) .+                         runIdentity++-------------------------------------------------------------------------+-- | Runs a LogicVar computation with the specified initial success and+-- failure continuations.+runLogicVar :: LogicVar a -> (a -> r -> r) -> r -> r+runLogicVar l s f = runIdentity $ unLogicVarT l si fi+ where+ si = fmap . s+ fi = Identity f++-}+
+ src/Control/Monad/LogicState/Class.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE FunctionalDependencies #-}++module Control.Monad.LogicState.Class+  ( MonadLogicState(..)+  )+  where++import Control.Monad+import Control.Monad.Logic.Class+import Control.Monad.State++-------------------------------------------------------------------------------+-- | API for MonadLogic which allows state and backtracking on it+-- Minimal implementation: msplit+class (MonadLogic m, MonadState s m) => MonadLogicState s m where+    +    -- | Return argument monad with the current backtrackable part of the state remembered.+    -- If the default def is not overridden this a no-op.+    -- This function complements 'mplus' for 'LogicT', 'mplus' backtracks on results, not on state, which is what this function should do.+    backtrack :: m a -> m (m a)+    backtrack = return+
+ src/Control/Monad/LogicState/Examples.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ExistentialQuantification, RankNTypes, ScopedTypeVariables #-}++module Control.Monad.LogicState.Examples+  ( main+  )+  where++import           Control.Monad+import           Control.Monad.Trans.Class+import           Control.Monad.State.Strict as StStr+-- import qualified Control.Monad.State.Strict as StStr+import qualified Control.Monad.State.Lazy as StLaz++import           Control.Monad.LogicState.Logic+import           Control.Monad.LogicState+++odds :: MonadPlus m => m Int+odds = (return 1) `mplus` (odds >>= \a -> return (2 + a))++{-++-------------------------------------------------------------------------------------------------+-- Basic queens+queens1 :: Int -> [[Int]]+queens1 n = filter test (generate n)+    where generate 0      = [[]]+          generate k      = [q : qs | q <- [1..n], qs <- generate (k-1)]+          test []         = True+          test (q:qs)     = isSafe q qs && test qs+          isSafe   try qs = not (try `elem` qs || sameDiag try qs)+          sameDiag try qs = any (\(colDist,q) -> abs (try - q) == colDist) $ zip [1..] qs++-------------------------------------------------------------------------------------------------+-- Basic queens, optimized with pruning+queens2 :: Int -> [[Int]]+queens2 n = map reverse $ queens' n+    where queens' 0       = [[]]+          queens' k       = [q:qs | qs <- queens' (k-1), q <- [1..n], isSafe q qs]+          isSafe   try qs = not (try `elem` qs || sameDiag try qs)+          sameDiag try qs = any (\(colDist,q) -> abs (try - q) == colDist) $ zip [1..] qs++-------------------------------------------------------------------------------------------------+-- Logic queens+queens1L n = do+    q <- generate1 n n+    guard (test q)+    return q+  where+    test []         = True+    test (q:qs)     = isSafe q qs && test qs+    isSafe   try qs = not (try `elem` qs || sameDiag try qs)+    sameDiag try qs = any (\(colDist,q) -> abs (try - q) == colDist) $ zip [1..] qs++generate1 :: MonadPlus m => Int -> Int -> m [Int]+generate1 _ 0 = return []+generate1 n k = do+  qs <- generate1 n (k-1)+  msum $ map (return . (:qs)) [1..n]++-------------------------------------------------------------------------------------------------+-- Logic queens, with pruning+queens2L n = do+    q <- generate2 n n+    return q++generate2 :: MonadPlus m => Int -> Int -> m [Int]+generate2 _ 0 = return []+generate2 n k = do+    qs <- generate2 n (k-1)+    msum $ flip map [1..n] $ \i -> do+      let q = i : qs+      guard (test q)+      return q+  where+    test []         = True+    test (q:qs)     = isSafe q qs && test qs+    isSafe   try qs = not (try `elem` qs || sameDiag try qs)+    sameDiag try qs = any (\(colDist,q) -> abs (try - q) == colDist) $ zip [1..] qs++-}++-------------------------------------------------------------------------------------------------+-- Logic queens, with pruning, with state+queens3L n = do+    q <- generate3 n n+    return q++count3g :: Monad m => LogicStateT Int Int m Int+count3g = state (\(g::Int, b::Int) -> (g,(g+1,b)))++count3gb :: Monad m => LogicStateT Int Int m (Int,Int)+count3gb = state (\(g::Int, b::Int) -> ((g,b),(g+1,b+1)))++generate3 :: Monad m => Int -> Int -> LogicStateT Int Int m ((Int,Int),[Int])+generate3 _ 0 = count3gb >>= \c -> return (c,[])+generate3 n k = do+    (_,qs) <- generate3 n (k-1)+    qss <- forM [1..n] $ \i -> backtrack $ do+      let q = i : qs+      guard (test q)+      cnt <- count3gb+      return (cnt,q)+    foldr1 mplus qss+{-+    foldr1 mplus $ flip map [1..n] $ \i -> do+      let q = i : qs+      guard (test q)+      cnt <- count3gb+      return (cnt,q)+-}+  where+    test []         = True+    test (q:qs)     = isSafe q qs && test qs+    isSafe   try qs = not (try `elem` qs || sameDiag try qs)+    sameDiag try qs = any (\(colDist,q) -> abs (try - q) == colDist) $ zip [1..] qs+++main = do+  -- forM_ (queens1 8) print+  -- forM_ (queens2 8) print+  -- forM_ (observeAll () $ queens1L 8) print+  -- forM_ (observeAll () $ (queens2L 8 :: Logic [Int])) print+  -- forM_ (observeAll (0::Int,0::Int) $ (queens3L 8 :: LogicVar Int Int ((Int,Int),[Int]))) print+  forM_ (observeMany (0::Int,0::Int) 500 $ (queens3L 10 :: LogicState Int Int ((Int,Int),[Int]))) print+  -- forM_ (observe (0::Int,0::Int) $ (queens3L 8 :: LogicVar Int Int ((Int,Int),[Int]))) print
+ src/Control/Monad/LogicState/Logic.hs view
@@ -0,0 +1,20 @@+{-| Wrapper around 'Control.Monad.Logic'+-}++module Control.Monad.LogicState.Logic+  ( module Control.Monad.Logic+  , module Control.Monad.TransLogicState.Class+  )+  where++import           Control.Monad.Logic hiding (observeT, observeAllT, observeManyT, observe, observeAll, observeMany)+import qualified Control.Monad.Logic as CML++import           Control.Monad.TransLogicState.Class++instance TransLogicState () LogicT where+  observeT _ = CML.observeT+  observeAllT _ = CML.observeAllT+  observeManyT _ = CML.observeManyT+  liftWithState m = lift $ m () >>= (return . fst)+
+ src/Control/Monad/TransLogicState/Class.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Control.Monad.TransLogicState.Class+  ( TransLogicState(..)+  +  , observe+  , observeAll+  , observeMany+  )+  where++import Data.Typeable++import Control.Monad.Identity+-- import Control.Monad.Trans++-- | Additions to MonadTrans specifically useful for LogicState+class {- MonadTrans t => -} TransLogicState s t where+  -------------------------------------------------------------------------+  -- | Extracts the first result from a 't m' computation,+  -- failing otherwise.+  observeT :: (Monad m) => s -> t m a -> m a+  observeT e m = fmap head $ observeManyT e 1 m+  +  -------------------------------------------------------------------------+  -- | Extracts all results from a 't m' computation.+  observeAllT :: (Monad m) => s -> t m a -> m [a]+  observeAllT e = observeManyT e maxBound+  +  -------------------------------------------------------------------------+  -- | Extracts up to a given number of results from a 't m' computation.+  observeManyT :: forall m a . (Monad m) => s -> Int -> t m a -> m [a]+  observeManyT e n m = fmap (take n) $ observeAllT e m++  -- | Lift a monad by threading the state available in the transformed monad through it+  liftWithState :: Monad m => (s -> m (a,s)) -> t m a++-------------------------------------------------------------------------+-- | Extracts the first result from a LogicVar computation.+observe :: (TransLogicState s t) => s -> t Identity a -> a+observe e = runIdentity . observeT e++-------------------------------------------------------------------------+-- | Extracts all results from a LogicVar computation.+observeAll :: (TransLogicState s t) => s -> t Identity a -> [a]+observeAll e = runIdentity . observeAllT e++-------------------------------------------------------------------------+-- | Extracts up to a given number of results from a LogicVar computation.+observeMany :: (TransLogicState s t) => s -> Int -> t Identity a -> [a]+observeMany e i = runIdentity . observeManyT e i+