monad-memo-0.5.4/Control/0000755000000000000000000000000014164705676013377 5ustar0000000000000000monad-memo-0.5.4/Control/Monad/0000755000000000000000000000000014164705676014435 5ustar0000000000000000monad-memo-0.5.4/Control/Monad/Memo/0000755000000000000000000000000014164705676015332 5ustar0000000000000000monad-memo-0.5.4/Control/Monad/Memo/Array/0000755000000000000000000000000014164705676016410 5ustar0000000000000000monad-memo-0.5.4/Control/Monad/Memo/Vector/0000755000000000000000000000000014164705676016574 5ustar0000000000000000monad-memo-0.5.4/Control/Monad/Trans/0000755000000000000000000000000014164705676015524 5ustar0000000000000000monad-memo-0.5.4/Control/Monad/Trans/Memo/0000755000000000000000000000000014164705676016421 5ustar0000000000000000monad-memo-0.5.4/Data/0000755000000000000000000000000014164705676012630 5ustar0000000000000000monad-memo-0.5.4/Data/MapLike/0000755000000000000000000000000014164705676014152 5ustar0000000000000000monad-memo-0.5.4/Data/MaybeLike/0000755000000000000000000000000014164705676014472 5ustar0000000000000000monad-memo-0.5.4/benchmark/0000755000000000000000000000000014164705676013711 5ustar0000000000000000monad-memo-0.5.4/example/0000755000000000000000000000000014164705676013412 5ustar0000000000000000monad-memo-0.5.4/example/Customisation/0000755000000000000000000000000014164705676016253 5ustar0000000000000000monad-memo-0.5.4/test/0000755000000000000000000000000014164705676012736 5ustar0000000000000000monad-memo-0.5.4/Control/Monad/Memo.hs0000644000000000000000000001611214164705676015667 0ustar0000000000000000{- | Module : Control.Monad.Memo Copyright : (c) Eduard Sergeev 2011 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Importing just this module is sufficient for most cases of the package usage -} module Control.Monad.Memo ( module Control.Monad, module Control.Monad.Trans.Class, module Data.MapLike, module Data.MaybeLike, -- * MonadMemo class MonadMemo(..), -- * Generalized Memo monad MemoState, runMemoState, evalMemoState, -- * Generalized MemoStateT monad transformer MemoStateT(..), runMemoStateT, evalMemoStateT, -- * Map-based Memo monad Memo, runMemo, evalMemo, startRunMemo, startEvalMemo, -- * Map-based MemoT monad transformer MemoT, runMemoT, evalMemoT, startRunMemoT, startEvalMemoT, -- * Array-based Memo monad -- ** ArrayCache for boxed types ArrayCache, ArrayMemo, evalArrayMemo, runArrayMemo, -- ** ArrayCache for unboxed types UArrayCache, UArrayMemo, evalUArrayMemo, runUArrayMemo, -- * Vector-based Memo monad -- ** VectorCache for boxed types VectorCache, VectorMemo, evalVectorMemo, runVectorMemo, -- ** VectorCache for unboxed types UVectorCache, UVectorMemo, evalUVectorMemo, runUVectorMemo, -- * Adapter for memoization of multi-argument functions for2, for3, for4, -- * Memoization cache level access functions memoln, memol0, memol1, memol2, memol3, memol4, -- * Example 1: Fibonacci numbers -- $fibExample -- * Example 2: Mutualy recursive definition with memoization -- $mutualExample -- * Example 3: Combining Memo with other transformers -- $transExample -- * Example 4: Memoization of multi-argument function -- $multiExample -- * Example 5: Alternative memo caches -- $arrayCacheExample ) where import Control.Monad.Memo.Class import Control.Monad.Trans.Memo.State import Control.Monad.Trans.Memo.Map import Control.Monad.Memo.Array import Control.Monad.Memo.Array.Instances() import Control.Monad.Memo.Vector import Control.Monad.Memo.Vector.Instances() import Data.MapLike import Data.MaybeLike import Data.MaybeLike.Instances() import Control.Monad import Control.Monad.Trans.Class {- $fibExample Memoization can be specified whenever monadic computation is taking place. Including recursive definition. Classic example: Fibonacci number function: Here is simple non-monadic definition of it >fib :: (Eq n, Num n) => n -> n >fib 0 = 0 >fib 1 = 1 >fib n = fib (n-1) + fib (n-2) To use 'Memo' monad we need to convert it into monadic form: >fibm :: (Eq n, Num n, Monad m) => n -> m n >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = do > n1 <- fibm (n-1) > n2 <- fibm (n-2) > return (n1+n2) Then we can specify which computation we want to memoize with 'memo' (both recursive calls to (n-1) and (n-2)): >fibm :: (Eq n, Num n, Ord n) => n -> Memo n n n >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = do > n1 <- memo fibm (n-1) > n2 <- memo fibm (n-2) > return (n1+n2) NB: 'Ord' is required since internaly Memo implementation uses 'Data.Map' to store and lookup memoized values Then it can be run with 'startEvalMemo' >startEvalMemo (fibm 100) Or using applicative form: >fibm :: (Eq n, Num n, Ord n) => n -> Memo n n n >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = (+) <$> memo fibm (n-1) <*> memo fibm (n-2) -} {- $mutualExample In order to use memoization for both mutually recursive function we need to use nested MemoT monad transformers (one for each cache). Let's extend our Fibonacci function with meaningless extra function @boo@ which in turn uses @fibm2@. Memoization cache type for @fibm2@ (caches @Integer -> Integer@) will be: >type MemoFib = MemoT Integer Integer While cache for @boo@ (@Double -> String@): >type MemoBoo = MemoT Double String Stacking them together gives us te overall type for our combined memoization monad: >type MemoFB = MemoFib (MemoBoo Identity) >boo :: Double -> MemoFB String >boo 0 = return "" >boo n = do > n1 <- memol1 boo (n-1) -- uses next in stack transformer (memol_1_): MemoBoo is nested in MemoFib > fn <- memol0 fibm2 (floor (n-1)) -- uses current transformer (memol_0_): MemoFib > return (show fn ++ n1) >fibm2 :: Integer -> MemoFB Integer >fibm2 0 = return 0 >fibm2 1 = return 1 >fibm2 n = do > l <- memol1 boo (fromInteger n) -- as in 'boo' we need to use 1st nested transformer here > f1 <- memol0 fibm2 (n-1) -- and 0st (the current) for fibm2 > f2 <- memol0 fibm2 (n-2) > return (f1 + f2 + floor (read l)) >evalFibM2 :: Integer -> Integer >evalFibM2 = startEvalMemo . startEvalMemoT . fibm2 -} {- $transExample 'MonadMemo' can be combined with other monads and transformers: With 'MonadWriter': >fibmw :: (MonadWriter String m, MonadMemo Integer Integer m) => Integer -> m Integer >fibmw 0 = return 0 >fibmw 1 = return 1 >fibmw n = do > f1 <- memo fibmw (n-1) > f2 <- memo fibmw (n-2) > tell $ show n > return (f1+f2) >evalFibmw :: Integer -> (Integer, String) >evalFibmw = startEvalMemo . runWriterT . fibmw -} {- $multiExample Functions with more than one argument (in curried form) can also be memoized with a help of @forX@ set of function: For two-argument function we can use 'for2' function adapter: >-- Ackerman function classic definition >ack :: (Eq n, Num n) => n -> n -> n >ack 0 n = n+1 >ack m 0 = ack (m-1) 1 >ack m n = ack (m-1) (ack m (n-1)) > >-- Ackerman function memoized definition >ackm :: (Num n, Ord n, MonadMemo (n, n) n m) => n -> n -> m n >ackm 0 n = return (n+1) >ackm m 0 = for2 memo ackm (m-1) 1 >ackm m n = do > n1 <- for2 memo ackm m (n-1) > for2 memo ackm (m-1) n1 > >evalAckm :: (Num n, Ord n) => n -> n -> n >evalAckm n m = startEvalMemo $ ackm n m -} {- $arrayCacheExample Given a monadic function definition it is often possible to execute it using different memo-cache ('MonadCache') implementations. For example 'ArrayCache' when used can dramatically reduce function computation time and memory usage. For example the same Fibonacci function: >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = (+) <$> memo fibm (n-1) <*> memo fibm (n-2) can easily be run using mutable array in 'Control.Monad.ST.ST' monad: >evalFibmSTA :: Integer -> Integer >evalFibmSTA n = runST $ evalArrayMemo (fibm n) (0,n) or, if we change its return type to a primitive (unboxed) value, we can use even more efficient unboxed array 'Data.Array.ST.STUArray': >evalFibmSTUA :: Integer -> Double >evalFibmSTUA n = runST $ evalUArrayMemo (fibm n) (0,n) Finally if we want to achieve the best performance within monad-memo, we can switch to unboxed `Vector`-based `MemoCache` (vectors support only `Int` as a key so we have to change the type): >evalFibmSTUV :: Int -> Double >evalFibmSTUV n = runST $ evalUVectorMemo (fibm n) (n+1) Note that `IO` monad can be used instead of `Control.Monad.ST.ST`: >evalFibmIOUV :: Int -> IO Double >evalFibmIOUV n = evalUVectorMemo (fibm n) (n+1) -}monad-memo-0.5.4/Control/Monad/Memo/Class.hs0000644000000000000000000001335014164705676016735 0ustar0000000000000000{- | Module : Control.Monad.Memo.Class Copyright : (c) Eduard Sergeev 2011 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) [Computation type:] Interface for monadic computations which can be memoized. -} {-# LANGUAGE NoImplicitPrelude, TupleSections, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, FlexibleContexts, RankNTypes #-} module Control.Monad.Memo.Class ( MonadCache(..), MonadMemo(..), for2, for3, for4, memoln, memol0, memol1, memol2, memol3, memol4, ) where import Data.Tuple import Data.Function import Data.Maybe import Data.Either import Data.Monoid import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Cont import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Lazy as SL import qualified Control.Monad.Trans.State.Strict as SS import qualified Control.Monad.Trans.Writer.Lazy as WL import qualified Control.Monad.Trans.Writer.Strict as WS import qualified Control.Monad.Trans.RWS.Lazy as RWSL import qualified Control.Monad.Trans.RWS.Strict as RWSS -- | Interface for memoization cache -- Is necessary since memoization mechanism from one transformer can use a cache from other (further down the stack) class Monad m => MonadCache k v m | m -> k, m -> v where lookup :: k -> m (Maybe v) add :: k -> v -> m () -- | Memoization interface class Monad m => MonadMemo k v m | m -> k, m -> v where memo :: (k -> m v) -> k -> m v -- | Memoization for the current transformer in stack using a cache from an arbitrary transformer down the stack {-# INLINE memoln #-} memoln :: (MonadCache k2 v m1, Monad m1, Monad m2) => (forall a.m1 a -> m2 a) -> (k1 -> k2) -> (k1 -> m2 v) -> k1 -> m2 v memoln fl fk f k = do mr <- fl $ lookup (fk k) case mr of Just r -> return r Nothing -> do r <- f k fl $ add (fk k) r return r -- | Adapter for memoization of two-argument function for2 :: (((k1, k2) -> mv) -> (k1, k2) -> mv) -> (k1 -> k2 -> mv) -> k1 -> k2 -> mv for2 m f = curry (m (uncurry f)) -- | Adapter for memoization of three-argument function for3 :: (((k1, k2, k3) -> mv) -> (k1, k2, k3) -> mv) -> (k1 -> k2 -> k3 -> mv) -> k1 -> k2 -> k3 -> mv for3 m f a b c = m (\(a,b,c) -> f a b c) (a,b,c) -- | Adapter for memoization of four-argument function for4 :: (((k1, k2, k3, k4) -> mv) -> (k1, k2, k3, k4) -> mv) -> (k1 -> k2 -> k3 -> k4 -> mv) -> k1 -> k2 -> k3 -> k4 -> mv for4 m f a b c d = m (\(a,b,c,d) -> f a b c d) (a,b,c,d) -- | Uses current monad's memoization cache {-# INLINE memol0 #-} memol0 :: (MonadCache k v m, Monad m) => (k -> m v) -> k -> m v memol0 = memoln id id -- | Uses the 1st transformer in stack for memoization cache {-# INLINE memol1 #-} memol1 :: (MonadTrans t1, MonadCache k v m, Monad (t1 m)) => (k -> t1 m v) -> k -> t1 m v memol1 = memoln lift id -- | Uses the 2nd transformer in stack for memoization cache {-# INLINE memol2 #-} memol2 :: (MonadTrans t1, MonadTrans t2, MonadCache k v m, Monad (t2 m), Monad (t1 (t2 m))) => (k -> t1 (t2 m) v) -> k -> t1 (t2 m) v memol2 = memoln (lift . lift) id -- | Uses the 3rd transformer in stack for memoization cache {-# INLINE memol3 #-} memol3 :: (MonadTrans t1, MonadTrans t2, MonadTrans t3, MonadCache k v m, Monad (t3 m), Monad (t2 (t3 m)), Monad (t1 (t2 (t3 m))) ) => (k -> t1 (t2 (t3 m)) v) -> k -> t1 (t2 (t3 m)) v memol3 = memoln (lift.lift.lift) id -- | Uses the 4th transformer in stack for memoization cache {-# INLINE memol4 #-} memol4 :: (MonadTrans t1, MonadTrans t2, MonadTrans t3, MonadTrans t4, MonadCache k v m, Monad (t4 m), Monad (t3 (t4 m)), Monad (t2 (t3 (t4 m))), Monad (t1 (t2 (t3 (t4 m)))) ) => (k -> t1 (t2 (t3 (t4 m))) v) -> k -> t1 (t2 (t3 (t4 m))) v memol4 = memoln (lift.lift.lift.lift) id instance (MonadCache k v m) => MonadMemo k v (IdentityT m) where memo f = IdentityT . memol0 (runIdentityT . f) instance (MonadCache k v m) => MonadMemo k v (ContT r m) where memo = memol1 instance (MonadCache k (Maybe v) m) => MonadMemo k v (MaybeT m) where memo f = MaybeT . memol0 (runMaybeT . f) instance (MonadCache k (Either e v) m) => MonadMemo k v (ExceptT e m) where memo f = ExceptT . memol0 (runExceptT . f) instance (MonadCache (r,k) v m) => MonadMemo k v (ReaderT r m) where memo f k = ReaderT $ \r -> memol0 (\(r, k) -> runReaderT (f k) r) (r, k) instance (Monoid w, MonadCache k (v,w) m) => MonadMemo k v (WL.WriterT w m) where memo f = WL.WriterT . memol0 (WL.runWriterT . f) instance (Monoid w, MonadCache k (v,w) m) => MonadMemo k v (WS.WriterT w m) where memo f = WS.WriterT . memol0 (WS.runWriterT . f) instance (MonadCache (s,k) (v,s) m) => MonadMemo k v (SS.StateT s m) where memo f k = SS.StateT $ \s -> memol0 (\(s, k) -> SS.runStateT (f k) s) (s, k) instance (MonadCache (s,k) (v,s) m) => MonadMemo k v (SL.StateT s m) where memo f k = SL.StateT $ \s -> memol0 (\(s, k) -> SL.runStateT (f k) s) (s, k) instance (Monoid w, MonadCache (r,s,k) (v,s,w) m) => MonadMemo k v (RWSL.RWST r w s m) where memo f k = RWSL.RWST $ \r s -> memol0 (\(r, s, k) -> RWSL.runRWST (f k) r s) (r, s, k) instance (Monoid w, MonadCache (r,s,k) (v,s,w) m) => MonadMemo k v (RWSS.RWST r w s m) where memo f k = RWSS.RWST $ \r s -> memol0 (\(r, s, k) -> RWSS.runRWST (f k) r s) (r, s, k) monad-memo-0.5.4/Control/Monad/Trans/Memo/ReaderCache.hs0000644000000000000000000000456414164705676021114 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.ReaderCache Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable Generic StateCache - wrapper around `Control.Monad.Trans.Reader.ReaderT` -} {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} module Control.Monad.Trans.Memo.ReaderCache ( ReaderCache, evalReaderCache, container ) where import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.ST import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Array.Base import Data.Array.IO import Data.Array.ST newtype ReaderCache c m a = ReaderCache { toReaderT :: ReaderT c m a } deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix, MonadTrans, MonadIO) {-# INLINE evalReaderCache #-} evalReaderCache :: ReaderCache r m a -> r -> m a evalReaderCache = runReaderT . toReaderT -- | Returns internal container container :: Monad m => ReaderCache c m c {-# INLINE container #-} container = ReaderCache ask instance PrimMonad m => PrimMonad (ReaderCache c m) where type PrimState (ReaderCache c m) = PrimState m primitive = lift . primitive instance MArray IOArray e (ReaderCache c IO) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i instance MArray IOUArray e IO => MArray IOUArray e (ReaderCache c IO) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i instance MArray (STArray s) e (ReaderCache c (ST s)) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i instance MArray (STUArray s) e (ST s) => MArray (STUArray s) e (ReaderCache c (ST s)) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i monad-memo-0.5.4/Control/Monad/Trans/Memo/StateCache.hs0000644000000000000000000000551014164705676020762 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.StateCache Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, flexible instances) Generic StateCache - wrapper around `Control.Monad.Trans.State.Strict.StateT` -} {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} module Control.Monad.Trans.Memo.StateCache ( StateCache, runStateCache, container, setContainer, evalStateCache ) where import Control.Monad.Primitive import Control.Monad.ST import Data.Array.MArray import Data.Function import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Fix import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict import Data.Array.Base import Data.Array.IO import Data.Array.ST newtype StateCache c m a = StateCache { toStateT :: StateT c m a } deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix, MonadTrans, MonadIO) {-# INLINE runStateCache #-} runStateCache :: StateCache s m a -> s -> m (a, s) runStateCache = runStateT . toStateT -- | Evaluates computation discarding the resulting container evalStateCache :: Monad m => StateCache c m a -> c -> m a {-# INLINE evalStateCache #-} evalStateCache = evalStateT . toStateT -- | Returns internal container container :: Monad m => StateCache c m c {-# INLINE container #-} container = StateCache get -- | Assigns new value to internal container setContainer :: Monad m => c -> StateCache c m () {-# INLINE setContainer #-} setContainer = StateCache . put instance PrimMonad m => PrimMonad (StateCache c m) where type PrimState (StateCache c m) = PrimState m primitive = lift . primitive instance MArray IOArray e (StateCache c IO) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i instance MArray IOUArray e IO => MArray IOUArray e (StateCache c IO) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i instance MArray (STArray s) e (StateCache c (ST s)) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i instance MArray (STUArray s) e (ST s) => MArray (STUArray s) e (StateCache c (ST s)) where getBounds = lift . getBounds getNumElements = lift . getNumElements newArray a = lift . newArray a unsafeRead a = lift . unsafeRead a unsafeWrite a i = lift . unsafeWrite a i monad-memo-0.5.4/Control/Monad/Trans/Memo/State.hs0000644000000000000000000000521414164705676020037 0ustar0000000000000000{- | Module : Control.Monad.Memo Copyright : (c) Eduard Sergeev 2011 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, flexible instances) Defines "MemoStateT" - generalized (to any "Data.MapLike" content) memoization monad transformer -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} module Control.Monad.Trans.Memo.State ( -- * MemoStateT monad transformer MemoStateT(..), runMemoStateT, evalMemoStateT, -- * MemoState monad MemoState, runMemoState, evalMemoState, -- * Internal Container(..) ) where import Data.Tuple import Data.Function import Data.Functor.Identity import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import qualified Data.MapLike as M import Control.Monad.Memo.Class import Control.Monad.Trans.Memo.StateCache newtype Container s = Container { toState :: s } -- | Memoization monad transformer based on `StateCache` -- to be used with pure cache containers which support `M.MapLike` interface type MemoStateT s k v = StateCache (Container s) -- | Returns the pair of the result of `MonadMemo` computation -- along with the final state of the internal pure container wrapped in monad runMemoStateT :: Monad m => MemoStateT s k v m a -> s -> m (a, s) runMemoStateT m s = do (a, c) <- runStateCache m (Container s) return (a, toState c) -- | Returns the result of `MonadMemo` computation wrapped in monad. -- This function discards the cache evalMemoStateT :: Monad m => MemoStateT c k v m a -> c -> m a evalMemoStateT m s = runMemoStateT m s >>= return . fst -- | Memoization monad based on `StateCache` -- to be used with pure cache containers which support `M.MapLike` interface type MemoState c k v = MemoStateT c k v Identity -- | Returns the pair of the result of `MonadMemo` computation -- along with the final state of the internal pure container runMemoState :: MemoState c k v a -> c -> (a, c) runMemoState m = runIdentity . runMemoStateT m -- | Returns the result of `MonadMemo` computation discarding the cache evalMemoState :: MemoState c k v a -> c -> a evalMemoState m = runIdentity . evalMemoStateT m instance (Monad m, M.MapLike c k v) => MonadCache k v (MemoStateT c k v m) where {-# INLINE lookup #-} lookup k = container >>= return . M.lookup k . toState {-# INLINE add #-} add k v = container >>= setContainer . Container . M.add k v . toState instance (Monad m, M.MapLike c k v) => MonadMemo k v (MemoStateT c k v m) where {-# INLINE memo #-} memo = memol0monad-memo-0.5.4/Control/Monad/Trans/Memo/Map.hs0000644000000000000000000000524614164705676017501 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.Map Copyright : (c) Eduard Sergeev 2011 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Specialization of `MemoStateT` with `Data.Map` as a container -} {-# LANGUAGE NoImplicitPrelude #-} module Control.Monad.Trans.Memo.Map ( -- * MemoT monad transformer MemoT, runMemoT, evalMemoT, startRunMemoT, startEvalMemoT, -- * Memo monad Memo, runMemo, evalMemo, startRunMemo, startEvalMemo, ) where import Data.Functor.Identity import Control.Monad import Control.Monad.Trans.Memo.State import Data.MapLike.Instances() import qualified Data.Map as M -- | Memoization monad transformer which uses `Data.Map` as a cache container type MemoT k v = MemoStateT (M.Map k v) k v -- | Given an initial cache, compute the result of a memoized computation -- along with the final state of the cache runMemoT :: Monad m => MemoT k v m a -> M.Map k v -> m (a, M.Map k v) runMemoT = runMemoStateT -- | Given an initial state, compute the result of a memoized computation -- discarding the final state of the cache evalMemoT :: Monad m => MemoT k v m a -> M.Map k v -> m a evalMemoT = evalMemoStateT -- | Compute the result of memoized computation along with the final state of the cache. -- This function uses empty `M.Map` as an initial state startRunMemoT :: Monad m => MemoT k v m a -> m (a, M.Map k v) startRunMemoT = (`runMemoT` M.empty) -- | Compute the result of a memoized computation discarding the final state of the cache. -- This function uses empty `M.Map` as an initial state startEvalMemoT :: Monad m => MemoT k v m a -> m a startEvalMemoT = (`evalMemoT` M.empty) -- | Memoization monad which uses `Data.Map` as a cache container type Memo k v = MemoT k v Identity -- | Given an initial cache, compute the result of a memoized computation -- along with the final state of the cache runMemo :: Memo k v a -> M.Map k v -> (a, M.Map k v) runMemo = runMemoState -- | Given an initial state, compute the result of a memoized computation -- discarding the final state of the cache evalMemo :: Memo k v a -> M.Map k v -> a evalMemo = evalMemoState -- | Compute the result of memoized computation along with the final state of the cache. -- This function uses empty `M.Map` as an initial state startRunMemo :: Memo k v a -> (a, M.Map k v) startRunMemo = (`runMemo` M.empty) -- | Compute the result of a memoized computation discarding the final state of the cache. -- This function uses empty `M.Map` as an initial state startEvalMemo :: Memo k v a -> a startEvalMemo = (`evalMemo` M.empty) monad-memo-0.5.4/Control/Monad/Memo/Array.hs0000644000000000000000000001530514164705676016750 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.Array Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, flexible instances) ArrayCache - mutable-array-based (`IO` and `ST` hosted) `MonadCache` Very fast memoization cache. Unfortunatelly it cannot suit every case (see limitations), but if you can use it, please do: it is generally an order of magnitude faster than `Data.Map`-based `Control.Monad.Trans.Memo.Map.Memo`, especially /unboxed/ version - try to use it whenever you can. Limitations: Since `Data.Array.Base.MArray` is used as `MonadCache` the key range must be known beforehand and the array is allocated before the first call. It is therefore most suitable for the cases when the distribution of possible key values is within reasonable range and is rather dense (the best case: all values withing some range will be used). If this is the case then `MArray` has O(1) for both lookup and update operations. In addition unboxed `UArrayCache` can only store unboxed types (but it does it very efficiently). -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, TypeFamilies #-} module Control.Monad.Memo.Array ( -- * ArrayCache for boxed types Array, ArrayCache, ArrayMemo, evalArrayMemo, runArrayMemo, -- * ArrayCache for unboxed types UArray, UArrayCache, UArrayMemo, evalUArrayMemo, runUArrayMemo, -- * Generic function for ArrayCache Container(..), Cache, genericEvalArrayMemo, genericRunArrayMemo ) where import Data.Function import Data.Maybe (Maybe(..)) import Data.Array.ST import Data.Array.IO import Control.Monad import Control.Monad.Trans.Class import Control.Monad.ST import System.IO import Data.MaybeLike import Control.Monad.Memo.Class import Control.Monad.Trans.Memo.ReaderCache newtype Container arr = Container { toArray :: arr } -- | Generic Array-based memo cache type Cache arr k e = ReaderCache (Container (arr k e)) instance (Monad m, Ix k, MaybeLike e v, MArray c e m) => MonadCache k v (Cache c k e m) where {-# INLINE lookup #-} lookup k = do c <- container e <- lift $ readArray (toArray c) k return (if isNothing e then Nothing else Just (fromJust e)) {-# INLINE add #-} add k v = do c <- container lift $ writeArray (toArray c) k (just v) instance (Monad m, Ix k, MaybeLike e v, MArray c e m) => MonadMemo k v (Cache c k e m) where {-# INLINE memo #-} memo f k = do c <- container e <- lift $ readArray (toArray c) k if isNothing e then do v <- f k lift $ writeArray (toArray c) k (just v) return v else return (fromJust e) -- ArrayCache for boxed types -- -------------------------- -- | A family of boxed arrays type family Array (m :: * -> *) :: * -> * -> * type instance Array (ST s) = STArray s type instance Array IO = IOArray type instance Array (ReaderCache c (ST s)) = STArray s type instance Array (ReaderCache c IO) = IOArray -- | Memoization monad based on mutable boxed array type ArrayCache k e m = Cache (Array m) k e m -- | This is just to be able to infer the type of the `ArrayCache` element -- -- Type families could be used instead but due to the bug in 7.4.* we cannot use them here class MaybeLike e v => ArrayMemo v e | v -> e -- | Evaluate computation using boxed array -- -- Key range should cover all possible keys used in computation -- otherwise /not in range/ error is generated by array evalArrayMemo :: (Ix k, MArray (Array m) e m, ArrayMemo v e) => ArrayCache k e m a -- ^memoized computation to be evaluated -> (k,k) -- ^array key range -> m a -- ^computation result {-# INLINE evalArrayMemo #-} evalArrayMemo = genericEvalArrayMemo -- | Evaluate computation and the final content of array cache using boxed array -- -- Key range should cover all possible keys used in computation -- otherwise /not in range/ error is generated by array runArrayMemo :: (Ix k, MArray (Array m) e m, ArrayMemo v e) => ArrayCache k e m a -- ^memoized computation to be evaluated -> (k,k) -- ^array key range -> m (a, Array m k e) -- ^computation result and final array cache {-# INLINE runArrayMemo #-} runArrayMemo = genericRunArrayMemo -- ArrayCache for unboxed types -- ---------------------------- -- | A family of unboxed arrays type family UArray (m :: * -> *) :: * -> * -> * type instance UArray (ST s) = STUArray s type instance UArray IO = IOUArray type instance UArray (ReaderCache c (ST s)) = STUArray s type instance UArray (ReaderCache c IO) = IOUArray -- | Memoization monad based on mutable unboxed array type UArrayCache k e m = Cache (UArray m) k e m -- | This is just to be able to infer the type of the `UArrayCache` element -- -- Type families could be used instead but due to the bug in 7.4.* we cannot use them here class MaybeLike e v => UArrayMemo v e | v -> e -- | Evaluate computation using unboxed array -- -- Key range should cover all possible keys used in computation -- otherwise /not in range/ error is generated by array evalUArrayMemo :: (Ix k, MArray (UArray m) e m, UArrayMemo v e) => UArrayCache k e m a -- ^memoized computation to be evaluated -> (k,k) -- ^array key range -> m a -- ^computation result {-# INLINE evalUArrayMemo #-} evalUArrayMemo = genericEvalArrayMemo -- | Evaluate computation and the final content of array cache using unboxed array -- -- Key range should cover all possible keys used in computation -- otherwise /not in range/ error is generated by array runUArrayMemo :: (Ix k, MArray (UArray m) e m, UArrayMemo v e) => UArrayCache k e m a -- ^memoized computation to be evaluated -> (k,k) -- ^array key range -> m (a, UArray m k e) -- ^computation result and final array cache {-# INLINE runUArrayMemo #-} runUArrayMemo = genericRunArrayMemo genericEvalArrayMemo :: (Ix k, MaybeLike e v, MArray arr e m) => Cache arr k e m a -> (k, k) -> m a {-# INLINE genericEvalArrayMemo #-} genericEvalArrayMemo m lu = do arr <- newArray lu nothing evalReaderCache m (Container arr) genericRunArrayMemo :: (Ix k, MaybeLike e v, MArray arr e m) => Cache arr k e m a -> (k, k) -> m (a, arr k e) {-# INLINE genericRunArrayMemo #-} genericRunArrayMemo m lu = do arr <- newArray lu nothing a <- evalReaderCache m (Container arr) return (a, arr) monad-memo-0.5.4/Control/Monad/Memo/Array/Instances.hs0000644000000000000000000000133214164705676020672 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.Array.Instances Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Default instances of `ArrayMemo` and `UArrayMemo` -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances, FlexibleContexts #-} module Control.Monad.Memo.Array.Instances ( module Control.Monad.Memo.Array ) where import Data.Maybe import Data.MaybeLike import Control.Monad.Memo.Array instance MaybeLike (Maybe v) v => ArrayMemo v (Maybe v) instance MaybeLike v v => UArrayMemo v v monad-memo-0.5.4/Control/Monad/Memo/Vector.hs0000644000000000000000000001457214164705676017141 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.Vector Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, flexible instances) VectorCache - mutable-vector-based (`IO` and `ST` hosted) `MonadCache` The fastest memoization cache, however it is even more limiting than "Control.Monad.Memo.Array" due to nature of "Data.Vector.Mutable". Still if you can use this cache please do since it will give you dramatic calculation speed up in comparison to pure `Data.Map.Map`-based cache, especially when unboxed `UVectorCache` is used. Limitations: Since `Data.Vector.Generic.Mutable.MVector` is used as `MonadCache` the key must be `Int` and the size of the cache's vector must be known beforehand with vector being allocated before the first call. In addition unboxed `UVectorCache` can only store `Data.Vector.Unboxed.Unbox` values (but it does it very efficiently). -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeFamilies, UndecidableInstances, TypeSynonymInstances #-} module Control.Monad.Memo.Vector ( -- * VectorCache for boxed types Vector, VectorCache, VectorMemo, evalVectorMemo, runVectorMemo, -- * UVectorCache for unboxed types UVector, UVectorCache, UVectorMemo, evalUVectorMemo, runUVectorMemo, -- * Generic functions for VectorCache Container(..), Cache, genericEvalVectorMemo, genericRunVectorMemo ) where import Data.Int import Data.Function import Data.Maybe (Maybe(..)) import Data.Vector.Generic.Mutable import qualified Data.Vector.Mutable as M import qualified Data.Vector.Unboxed.Mutable as UM import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.Trans.Class import Control.Monad.Primitive import Data.MaybeLike import Control.Monad.Memo.Class import Control.Monad.Trans.Memo.ReaderCache newtype Container vec = Container { toVector :: vec } -- | Generic Vector-based memo cache type Cache vec s e = ReaderCache (Container (vec s e)) instance (PrimMonad m, PrimState m ~ s, MaybeLike e v, MVector c e) => MonadCache Int v (Cache c s e m) where {-# INLINE lookup #-} lookup k = do c <- container e <- lift $ read (toVector c) k return (if isNothing e then Nothing else Just (fromJust e)) {-# INLINE add #-} add k v = do c <- container lift $ write (toVector c) k (just v) instance (PrimMonad m, PrimState m ~ s, MaybeLike e v, MVector c e) => MonadMemo Int v (Cache c s e m) where {-# INLINE memo #-} memo f k = do c <- container e <- lift $ read (toVector c) k if isNothing e then do v <- f k lift $ write (toVector c) k (just v) return v else return (fromJust e) -- VectorCache for boxed types -- -------------------------- -- | Boxed vector type Vector = M.MVector -- | `MonadCache` based on boxed vector type VectorCache s e = Cache Vector s e -- | This is just to be able to infer the type of the `VectorCache` element. class MaybeLike e v => VectorMemo v e | v -> e -- | Evaluate computation using mutable boxed vector -- -- Vector length must covers all possible keys used in computation -- otherwise /index out of bound/ error is generated by vector code evalVectorMemo :: (PrimMonad m, VectorMemo v e) => VectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m a -- ^result {-# INLINE evalVectorMemo #-} evalVectorMemo = genericEvalVectorMemo -- | Evaluate computation using mutable boxed vector. -- It also returns the final content of the vector cache -- -- Vector length must covers all possible keys used in computation -- otherwise /index out of bound/ error is generated by vector code runVectorMemo :: (PrimMonad m, VectorMemo v e) => VectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m (a, Vector (PrimState m) e) -- ^result and final vector cache {-# INLINE runVectorMemo #-} runVectorMemo = genericRunVectorMemo -- VectorCache for unboxed types -- ---------------------------- -- | Unboxed vector type UVector = UM.MVector -- | `MonadCache` based on unboxed vector type UVectorCache s e = Cache UVector s e -- | This is just to be able to infer the type of the `UVectorCache` element. class MaybeLike e v => UVectorMemo v e | v -> e -- | Evaluate computation using mutable unboxed vector -- -- Vector length must covers all possible keys used in computation -- otherwise /index out of bound/ error is generated by vector code evalUVectorMemo :: (PrimMonad m, MVector UVector e, UVectorMemo v e) => UVectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m a -- ^result {-# INLINE evalUVectorMemo #-} evalUVectorMemo = genericEvalVectorMemo -- | Evaluate computation using mutable unboxed vector. -- It also returns the final content of the vector cache -- -- Vector length must covers all possible keys used in computation -- otherwise /index out of bound/ error is generated by vector code runUVectorMemo :: (PrimMonad m, MVector UVector e, UVectorMemo v e) => UVectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m (a, UVector (PrimState m) e) -- ^result and final vector cache {-# INLINE runUVectorMemo #-} runUVectorMemo = genericRunVectorMemo genericEvalVectorMemo :: (MaybeLike e v, PrimMonad m, MVector c e) => Cache c (PrimState m) e m a -> Int -> m a {-# INLINE genericEvalVectorMemo #-} genericEvalVectorMemo m n = do c <- replicate n nothing evalReaderCache m (Container c) genericRunVectorMemo :: (MaybeLike e v, PrimMonad m, MVector c e) => Cache c (PrimState m) e m a -> Int -> m (a, c (PrimState m) e) {-# INLINE genericRunVectorMemo #-} genericRunVectorMemo m n = do c <- replicate n nothing a <- evalReaderCache m (Container c) return (a, c)monad-memo-0.5.4/Control/Monad/Memo/Vector/Expandable.hs0000644000000000000000000001471114164705676021177 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.Vector Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, flexible instances) Vector-based `MonadCache` implementation which dynamically expands the vector during the computation to accomodate all requested keys. This implementation does not require to specify the length of the vector up front, but may be slower than "Control.Monad.Memo.Vector". -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, TypeFamilies #-} module Control.Monad.Memo.Vector.Expandable ( -- * VectorCache for boxed types VectorCache, VectorMemo, startEvalVectorMemo, startRunVectorMemo, -- * UVectorCache for unboxed types UVectorCache, UVectorMemo, startEvalUVectorMemo, startRunUVectorMemo, -- * Generic functions for VectorCache Container(..), Cache, genericStartEvalVectorMemo, genericStartRunVectorMemo ) where import Data.Int import Data.Eq import Data.Ord import Data.Function import Prelude (Num(..)) import Data.Maybe (Maybe(..)) import Data.Vector.Generic.Mutable import qualified Data.Vector.Mutable as M import qualified Data.Vector.Unboxed.Mutable as UM import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Primitive import Data.MaybeLike import Control.Monad.Memo.Class import Control.Monad.Trans.Memo.StateCache newtype Container vec = Container { toVector :: vec } -- | Generic Vector-based memo cache type Cache vec k e = StateCache (Container (vec k e)) instance (PrimMonad m, PrimState m ~ s, MaybeLike e v, MVector c e) => MonadCache Int v (Cache c s e m) where {-# INLINE lookup #-} lookup k = do c <- container e <- lift $ cacheRead (toVector c) k return (if isNothing e then Nothing else Just (fromJust e)) {-# INLINE add #-} add k v = do c <- container v' <- lift $ cacheWrite (toVector c) k (just v) setContainer (Container v') instance (PrimMonad m, PrimState m ~ s, MaybeLike e v, MVector c e) => MonadMemo Int v (Cache c s e m) where {-# INLINE memo #-} memo f k = do Container vec <- container let l = length vec d = k + 1 - l if d > 0 then do vec' <- lift $ expand vec l d setContainer (Container vec') v <- f k Container vec'' <- container lift $ unsafeWrite vec'' k (just v) return v else do e <- lift $ cacheRead vec k if isNothing e then do v <- f k Container vec' <- container lift $ unsafeWrite vec' k (just v) return v else return (fromJust e) -- VectorCache for boxed types -- -------------------------- -- | Boxed vector type Vector = M.MVector -- | `MonadCache` based on boxed vector type VectorCache s e = Cache Vector s e -- | This is just to be able to infer the type of the `VectorCache` element. class MaybeLike e v => VectorMemo v e | v -> e -- | Evaluate computation using mutable boxed vector which dynamically grows to accomodate all requested keys startEvalVectorMemo :: (PrimMonad m, VectorMemo v e) => VectorCache (PrimState m) e m a -> m a {-# INLINE startEvalVectorMemo #-} startEvalVectorMemo = genericStartEvalVectorMemo -- | Evaluate computation using mutable boxed vector -- which dynamically grows to accomodate all requested keys. -- This function also returns the final content of the vector cache startRunVectorMemo :: (PrimMonad m, VectorMemo v e) => VectorCache (PrimState m) e m a -> m (a, Vector (PrimState m) e) {-# INLINE startRunVectorMemo #-} startRunVectorMemo = genericStartRunVectorMemo -- VectorCache for unboxed types -- ---------------------------- -- | Unboxed vector type UVector = UM.MVector -- | `MonadCache` based on unboxed vector type UVectorCache s e = Cache UVector s e -- | This is just to be able to infer the type of the `UVectorCache` element. class MaybeLike e v => UVectorMemo v e | v -> e -- | Evaluate computation using mutable unboxed vector -- which dynamically grows to accomodate all requested keys startEvalUVectorMemo :: (PrimMonad m, UVectorMemo v e, MVector UVector e) => UVectorCache (PrimState m) e m a -> m a {-# INLINE startEvalUVectorMemo #-} startEvalUVectorMemo = genericStartEvalVectorMemo -- | Evaluate computation using mutable unboxed vector -- which dynamically grows to accomodate all requested keys. -- This function also returns the final content of the vector cache startRunUVectorMemo :: (PrimMonad m, UVectorMemo v e, MVector UVector e) => UVectorCache (PrimState m) e m a -> m (a, UVector (PrimState m) e) {-# INLINE startRunUVectorMemo #-} startRunUVectorMemo = genericStartRunVectorMemo genericStartEvalVectorMemo :: (MaybeLike e v, PrimMonad m, MVector vec e) => Cache vec (PrimState m) e m a -> m a {-# INLINE genericStartEvalVectorMemo #-} genericStartEvalVectorMemo m = do (a,_) <- genericStartRunVectorMemo m return a genericStartRunVectorMemo :: (MaybeLike e v, PrimMonad m, MVector vec e) => Cache vec (PrimState m) e m a -> m (a, vec (PrimState m) e) {-# INLINE genericStartRunVectorMemo #-} genericStartRunVectorMemo m = do vec <- replicate 0 nothing (a, c) <- runStateCache m (Container vec) return (a, toVector c) {-# INLINE cacheRead #-} cacheRead c k = if k >= length c then return nothing else unsafeRead c k {-# INLINE cacheWrite #-} cacheWrite c k e = do c' <- if d > 0 then expand c l d else return c unsafeWrite c' k e return c' where l = length c d = k + 1 - l {-# INLINE expand #-} expand c l d = do uc <- unsafeGrow c toGrow unsafeWrite uc l nothing initialise uc 1 where toGrow = d `max` (l * 2) {-# INLINE initialise #-} initialise c i | i == toGrow = return c initialise c i = do let n = i `min` (toGrow-i) t = unsafeSlice (l+i) n c s = unsafeSlice l n c unsafeCopy t s initialise c (i+n) monad-memo-0.5.4/Control/Monad/Memo/Vector/Unsafe.hs0000644000000000000000000001437114164705676020357 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.Vector Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, flexible instances) VectorCache - mutable-vector-based `MonadCache` with unsafe operations. This is a version of "Control.Monad.Memo.Mutable.Vector" but implemented using /unsafe*/ vector operations. Faster than default implementation but you must be sure that your code doesn't try to read/write outside vector boundaries. -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeFamilies, UndecidableInstances, TypeSynonymInstances #-} module Control.Monad.Memo.Vector.Unsafe ( -- * VectorCache for boxed types VectorCache, VectorMemo, unsafeEvalVectorMemo, unsafeRunVectorMemo, -- * UVectorCache for unboxed types UVectorCache, UVectorMemo, unsafeEvalUVectorMemo, unsafeRunUVectorMemo, -- * Generic functions for VectorCache Container(..), Cache, genericUnsafeEvalVectorMemo, genericUnsafeRunVectorMemo ) where import Data.Function import Data.Int import Data.Maybe (Maybe(..)) import Data.Vector.Generic.Mutable import qualified Data.Vector.Mutable as M import qualified Data.Vector.Unboxed.Mutable as UM import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.Trans.Class import Control.Monad.Primitive import Data.MaybeLike import Control.Monad.Memo.Class import Control.Monad.Trans.Memo.ReaderCache newtype Container vec = Container { toVector :: vec } -- | Generic Vector-based memo cache type Cache vec k e = ReaderCache (Container (vec k e)) instance (PrimMonad m, PrimState m ~ s, MaybeLike e v, MVector c e) => MonadCache Int v (Cache c s e m) where {-# INLINE lookup #-} lookup k = do c <- container e <- lift $ unsafeRead (toVector c) k return (if isNothing e then Nothing else Just (fromJust e)) {-# INLINE add #-} add k v = do c <- container lift $ unsafeWrite (toVector c) k (just v) instance (PrimMonad m, PrimState m ~ s, MaybeLike e v, MVector c e) => MonadMemo Int v (Cache c s e m) where {-# INLINE memo #-} memo f k = do c <- container e <- lift $ unsafeRead (toVector c) k if isNothing e then do v <- f k lift $ unsafeWrite (toVector c) k (just v) return v else return (fromJust e) -- VectorCache for boxed types -- -------------------------- -- | Boxed vector type Vector = M.MVector -- | `MonadCache` based on boxed vector type VectorCache s e = Cache Vector s e -- | This is just to be able to infer the type of the `VectorCache` element. class MaybeLike e v => VectorMemo v e | v -> e -- | Evaluate computation using mutable boxed vector and unsafe operations -- -- Vector length must covers all possible keys used in computation -- otherwise the behaviour is undefined (i.e. segfault) unsafeEvalVectorMemo :: (PrimMonad m, VectorMemo v e) => VectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m a -- ^result {-# INLINE unsafeEvalVectorMemo #-} unsafeEvalVectorMemo = genericUnsafeEvalVectorMemo -- | Evaluate computation using mutable boxed vector and unsafe operations. -- It also returns the final content of the vector cache -- -- Vector length must covers all possible keys used in computation -- otherwise the behaviour is undefined (i.e. segfault) unsafeRunVectorMemo :: (PrimMonad m, VectorMemo v e) => VectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m (a, Vector (PrimState m) e) -- ^result and final vector cache {-# INLINE unsafeRunVectorMemo #-} unsafeRunVectorMemo = genericUnsafeRunVectorMemo -- VectorCache for unboxed types -- ---------------------------- -- | Unboxed vector type UVector = UM.MVector -- | `MonadCache` based on unboxed vector type UVectorCache s e = Cache UVector s e -- | This is just to be able to infer the type of the `UVectorCache` element class MaybeLike e v => UVectorMemo v e | v -> e -- | Evaluate computation using mutable unboxed vector and unsafe operations -- -- Vector length must covers all possible keys used in computation -- otherwise the behaviour is undefined (i.e. segfault) unsafeEvalUVectorMemo :: (PrimMonad m, UVectorMemo v e, MVector UVector e) => UVectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m a -- ^result {-# INLINE unsafeEvalUVectorMemo #-} unsafeEvalUVectorMemo = genericUnsafeEvalVectorMemo -- | Evaluate computation using mutable boxed vector and unsafe operations. -- It also returns the final content of the vector cache -- -- Vector length must covers all possible keys used in computation -- otherwise the behaviour is undefined (i.e. segfault) unsafeRunUVectorMemo :: (PrimMonad m, UVectorMemo v e, MVector UVector e) => UVectorCache (PrimState m) e m a -- ^memoized computation -> Int -- ^vector length -> m (a, UVector (PrimState m) e) -- ^result and final vector cache {-# INLINE unsafeRunUVectorMemo #-} unsafeRunUVectorMemo = genericUnsafeRunVectorMemo genericUnsafeEvalVectorMemo :: (MaybeLike e v, PrimMonad m, MVector c e) => Cache c (PrimState m) e m a -> Int -> m a {-# INLINE genericUnsafeEvalVectorMemo #-} genericUnsafeEvalVectorMemo m n = do vec <- replicate n nothing evalReaderCache m (Container vec) genericUnsafeRunVectorMemo :: (MaybeLike e v, PrimMonad m, MVector c e) => Cache c (PrimState m) e m a -> Int -> m (a, c (PrimState m) e) {-# INLINE genericUnsafeRunVectorMemo #-} genericUnsafeRunVectorMemo m n = do vec <- replicate n nothing a <- evalReaderCache m (Container vec) return (a, vec) monad-memo-0.5.4/Control/Monad/Memo/Vector/Instances.hs0000644000000000000000000000204714164705676021062 0ustar0000000000000000{- | Module : Control.Monad.Trans.Memo.Vector.Instances Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Default instances for `VectorMemo` and `UVectorMemo` -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances, TypeFamilies, FlexibleContexts #-} module Control.Monad.Memo.Vector.Instances ( ) where import Data.Maybe import Data.MaybeLike import qualified Control.Monad.Memo.Vector as V import qualified Control.Monad.Memo.Vector.Expandable as E import qualified Control.Monad.Memo.Vector.Unsafe as U instance MaybeLike (Maybe v) v => V.VectorMemo v (Maybe v) instance MaybeLike v v => V.UVectorMemo v v instance MaybeLike (Maybe v) v => E.VectorMemo v (Maybe v) instance MaybeLike v v => E.UVectorMemo v v instance MaybeLike (Maybe v) v => U.VectorMemo v (Maybe v) instance MaybeLike v v => U.UVectorMemo v v monad-memo-0.5.4/Data/MapLike.hs0000644000000000000000000000125714164705676014513 0ustar0000000000000000{- | Module : Data.MapLike Copyright : (c) Eduard Sergeev 2011 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Defines MapLike typeclass - generalized interface to Data.Map, Data.HashMap etc. -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FunctionalDependencies #-} module Data.MapLike ( MapLike(..), ) where import Data.Maybe -- | An abstract interface to the container which can store 'v' indexed by 'k' class MapLike c k v | c -> k, c -> v where lookup :: k -> c -> Maybe v add :: k -> v -> c -> c monad-memo-0.5.4/Data/MapLike/Instances.hs0000644000000000000000000000171514164705676016441 0ustar0000000000000000{- | Module : Data.MapLike.Instances Copyright : (c) Eduard Sergeev 2011 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Defines MapLike instances declaration for standard data types -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances #-} module Data.MapLike.Instances ( MapLike(..) ) where import Data.Ord import Data.Int import Data.MapLike import qualified Data.Map as M import qualified Data.IntMap as IM -- | Data.Map is a default implementation (not the fastest but well-known) instance Ord k => MapLike (M.Map k v) k v where add = M.insert lookup = M.lookup -- | Data.IntMap is usually more efficient that Data.Map if @k :: Int@ instance MapLike (IM.IntMap v) Int v where {-# INLINE add #-} add = IM.insert {-# INLINE lookup #-} lookup = IM.lookup monad-memo-0.5.4/Data/MaybeLike.hs0000644000000000000000000000154014164705676015026 0ustar0000000000000000{- | Module : Data.MaybeLike Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Defines MaybeLike typeclass - a generic way to look at some types as if they were Maybe It is currently used to add maybe-ness to `unboxed` primitive types in cases when it isn't possuble to just use `Maybe a` (e.g. unboxed arrays) -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-} module Data.MaybeLike ( MaybeLike(..) ) where import Data.Bool -- | An abstract interface to a type which may not have a value class MaybeLike a v | a -> v where nothing :: a isNothing :: a -> Bool just :: v -> a fromJust :: a -> v monad-memo-0.5.4/Data/MaybeLike/Instances.hs0000644000000000000000000000765414164705676016771 0ustar0000000000000000{- | Module : Data.MaybeLike.Instances Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Defines default instances of `MaybeLike` for most primitive "Unboxed" types -} {-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} module Data.MaybeLike.Instances ( module Data.MaybeLike ) where import Data.Eq ((==)) import Prelude (Bounded(maxBound), (/), isNaN) import Prelude (Float, Double) import Data.Char import Data.Int import Data.Word import qualified Data.Maybe as M import Data.MaybeLike instance MaybeLike (M.Maybe a) a where {-# INLINE nothing #-} nothing = M.Nothing {-# INLINE isNothing #-} isNothing = M.isNothing {-# INLINE just #-} just = M.Just {-# INLINE fromJust #-} fromJust = M.fromJust instance MaybeLike Char Char where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Int Int where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Int8 Int8 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Int16 Int16 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Int32 Int32 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Int64 Int64 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Word Word where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Word8 Word8 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Word16 Word16 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Word32 Word32 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Word64 Word64 where {-# INLINE nothing #-} nothing = maxBound {-# INLINE isNothing #-} isNothing v = v == maxBound {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Float Float where {-# INLINE nothing #-} nothing = 0/0 {-# INLINE isNothing #-} isNothing = isNaN {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = v instance MaybeLike Double Double where {-# INLINE nothing #-} nothing = 0/0 {-# INLINE isNothing #-} isNothing = isNaN {-# INLINE just #-} just v = v {-# INLINE fromJust #-} fromJust v = vmonad-memo-0.5.4/test/Main.hs0000644000000000000000000000015114164705676014153 0ustar0000000000000000 module Main (main) where import MemoTest import Test.Framework (defaultMain) main = defaultMain testsmonad-memo-0.5.4/test/MemoTest.hs0000644000000000000000000003377514164705676015046 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} module MemoTest ( tests ) where import qualified Data.IntMap as IM import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer import Control.Monad.Trans.State import Control.Monad.Trans.Cont import Control.Monad.ST import Test.QuickCheck import Test.QuickCheck.Monadic import System.Random import Test.Framework (testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Control.Monad.Memo import qualified Control.Monad.Memo.Vector.Expandable as EV import qualified Control.Monad.Memo.Vector.Unsafe as UV smallUpperBound :: Num n => n smallUpperBound = 10 newtype SmallInt n = SmallInt { toInt::n } deriving Show instance (Num n, Random n) => Arbitrary (SmallInt n) where arbitrary = fmap SmallInt $ choose (0,smallUpperBound) newtype SmallList a = SmallList { toList::[a] } deriving Show instance Arbitrary a => Arbitrary (SmallList a) where arbitrary = do n <- choose (0,10) ls <- arbitrary return $ SmallList $ take n ls medUpperBound :: Num n => n medUpperBound = 1000 newtype MedInt n = MedInt { medToInt::n } deriving Show instance (Num n, Random n) => Arbitrary (MedInt n) where arbitrary = fmap MedInt $ choose (0,medUpperBound) -- | Plain monadic definition {-# INLINE fibm #-} fibm 0 = return 0 fibm 1 = return 1 fibm n = do f1 <- memo fibm (n-1) f2 <- memo fibm (n-2) return (f1+f2) -- | With ReaderT fibr 0 = return 0 fibr 1 = return 1 fibr 2 = return 1 fibr n = do p1 <- ask p2 <- local (const (p1+1)) $ fibr (n-2) f1 <- fibr (n-1) f2 <- fibr (n-2) return (p1+f1+f2+p2) runFibr r = (`runReader`r) . fibr fibmr 0 = return 0 fibmr 1 = return 1 fibmr 2 = return 1 fibmr n = do p1 <- ask p2 <- local (const (p1+1)) $ memo fibmr (n-2) f1 <- memo fibmr (n-1) f2 <- memo fibmr (n-2) return (p1+f1+f2+p2) runFibmr r = startEvalMemo . (`runReaderT`r) . fibmr prop_ReaderEqv :: SmallInt Int -> SmallInt Int -> Property prop_ReaderEqv (SmallInt r) (SmallInt n) = runFibr r n === runFibmr r n prop_ReaderSTEqv :: SmallInt Integer -> SmallInt Integer -> Bool prop_ReaderSTEqv (SmallInt r) (SmallInt n) = runReader (fibr n) r == runST (evalArrayMemo (runReaderT (fibmr n) r) ((0,0),(r+n,n))) -- | With WriterT fibw 0 = return 0 fibw 1 = return 1 fibw n = do f1 <- fibw (n-1) f2 <- fibw (n-2) tell $ show n return (f1+f2) fibmw 0 = return 0 fibmw 1 = return 1 fibmw n = do f1 <- memo fibmw (n-1) f2 <- memo fibmw (n-2) tell $ show n return (f1+f2) prop_WriterEqv :: SmallInt Int -> Bool prop_WriterEqv n = (runWriter . fibw . toInt $ n) == (startEvalMemo . runWriterT . fibmw . toInt $ n) -- | With ContT fibc 0 = return 0 fibc 1 = return 1 fibc n = do f1 <- fibc (n-1) f2 <- callCC $ \ break -> do if n == 4 then break 42 else fibc (n-2) return (f1+f2) fibmc 0 = return 0 fibmc 1 = return 1 fibmc n = do f1 <- memo fibmc (n-1) f2 <- callCC $ \ break -> do if n == 4 then break 42 else memo fibmc (n-2) return (f1+f2) prop_ContEqv :: SmallInt Int -> Bool prop_ContEqv n = ((`runCont`id) . fibc . toInt $ n) == (startEvalMemo . (`runContT`return) . fibmc . toInt $ n) prop_ContSTUEqv :: SmallInt Int -> Bool prop_ContSTUEqv (SmallInt n) = (runCont (fibc n) id :: Int) == (runST $ (`evalUArrayMemo`(0,n)) . (`runContT`return) . fibmc $ n) -- | With StateT fibs 0 = return 0 fibs 1 = return 1 fibs n = do s <- get f1 <- fibs (n-1) f2 <- fibs (n-2) modify (+1) return (f1+f2+s) fibms 0 = return 0 fibms 1 = return 1 fibms n = do s <- get f1 <- memo fibms (n-1) f2 <- memo fibms (n-2) modify (+1) return (f1+f2+s) prop_StateEqv :: SmallInt Int -> SmallInt Int -> Bool prop_StateEqv (SmallInt s) (SmallInt n) = ((`runState`s) . fibs $ n) == (startEvalMemo . (`runStateT`s) . fibms $ n) -- | Mutual recursion f :: Int -> (Int,String) f 0 = (1,"+") f n = (g(n-1, fst (f (n-1))),"-" ++ snd(f (n-1))) g :: (Int, Int) -> Int g (0, m) = m + 1 g (n,m) = fst(f (n-1))-g((n-1),m) type MemoF = MemoT Int (Int,String) type MemoG = Memo (Int,Int) Int type MemoFG = MemoF MemoG fm :: Int -> MemoFG (Int,String) fm 0 = return (1,"+") fm n = do fn <- memol0 fm (n-1) g <- memol1 gm (n-1 , fst fn) return (g , "-" ++ snd fn) gm :: (Int,Int) -> MemoFG Int gm (0,m) = return (m+1) gm (n,m) = do fn <- memol0 fm (n-1) g <- memol1 gm (n-1,m) return $ fst fn - g evalAll = startEvalMemo . startEvalMemoT evalFm = evalAll . fm evalGm = evalAll . gm prop_MutualFEqv :: SmallInt Int -> Bool prop_MutualFEqv sx = f x == evalFm x where x = toInt sx prop_MutualGEqv :: SmallInt Int -> SmallInt Int -> Bool prop_MutualGEqv sx sy = g (x,y) == evalGm (x,y) where x = toInt sx y = toInt sy -- Same as above but without explicit uncurring fm2 :: Int -> MemoFG (Int,String) fm2 0 = return (1,"+") fm2 n = do fn <- memol0 fm2 (n-1) g <- for2 memol1 gm2 (n-1) (fst fn) return (g , "-" ++ snd fn) gm2 :: Int -> Int -> MemoFG Int gm2 0 m = return (m+1) gm2 n m = do fn <- memol0 fm2 (n-1) g <- for2 memol1 gm2 (n-1) m return $ fst fn - g evalAll2 = startEvalMemo . startEvalMemoT evalFm2 = evalAll2 . fm2 evalGm2 n m = evalAll2 $ gm2 n m prop_Mutual2FEqv :: SmallInt Int -> Bool prop_Mutual2FEqv sx = f x == evalFm2 x where x = toInt sx prop_Mutual2GEqv :: SmallInt Int -> SmallInt Int -> Bool prop_Mutual2GEqv sx sy = g (x,y) == evalGm2 x y where x = toInt sx y = toInt sy -- | Array tests ---------------- fibMap :: (Ord n, Num n, Num v) => n -> v fibMap = startEvalMemo . fibm fibIntMap :: Int -> Int fibIntMap = (`evalMemoState`IM.empty) . fibm fibSTA :: Integer -> Integer fibSTA n = runST $ evalArrayMemo (fibm n) (0,n) fibSTUA :: Int -> Int fibSTUA n = runST $ evalUArrayMemo (fibm n) (0,n) fibIOA :: Integer -> IO Integer fibIOA n = evalArrayMemo (fibm n) (0,n) fibIOUA :: Int -> IO Int fibIOUA n = evalUArrayMemo (fibm n) (0,n) prop_IntMapEqv :: MedInt Int -> Bool prop_IntMapEqv (MedInt n) = fibMap n == fibIntMap n prop_STAEqv :: MedInt Integer -> Bool prop_STAEqv (MedInt n) = fibMap n == fibSTA n prop_STUAEqv :: MedInt Int -> Bool prop_STUAEqv (MedInt n) = fibMap n == fibSTUA n prop_STUADEqv :: MedInt Int -> Bool prop_STUADEqv (MedInt n) = fibMap n == fibSTUA n prop_IOAEqv :: MedInt Integer -> Property prop_IOAEqv (MedInt n) = monadicIO $ do r <- run $ fibIOA n assert $ r == fibMap n prop_IOUAEqv :: MedInt Int -> Property prop_IOUAEqv (MedInt n) = monadicIO $ do r <- run $ fibIOUA n assert $ r == fibMap n -- | Vector tests ----------------- fibSTV :: Int -> Integer fibSTV n = runST $ evalVectorMemo (fibm n) (n+1) prop_STVEqv :: MedInt Int -> Bool prop_STVEqv (MedInt n) = fibMap n == fibSTV n fibSTUV :: Int -> Int fibSTUV n = runST $ evalUVectorMemo (fibm n) (n+1) prop_STUVEqv :: MedInt Int -> Bool prop_STUVEqv (MedInt n) = fibMap n == fibSTUV n fibIOV :: Int -> IO Integer fibIOV n = evalVectorMemo (fibm n) (n+1) prop_IOVEqv :: MedInt Int -> Property prop_IOVEqv (MedInt n) = monadicIO $ do r <- run $ fibIOV n assert $ r == fibMap n fibIOUV :: Int -> IO Int fibIOUV n = evalUVectorMemo (fibm n) (n+1) prop_IOUVEqv :: MedInt Int -> Property prop_IOUVEqv (MedInt n) = monadicIO $ do r <- run $ fibIOUV n assert $ r == fibMap n -- | Expandable vector tests ---------------------------- fibSTEV :: Int -> Integer fibSTEV n = runST $ EV.startEvalVectorMemo (fibm n) prop_STEVEqv :: MedInt Int -> Bool prop_STEVEqv (MedInt n) = fibMap n == fibSTEV n fibSTEUV :: Int -> Int fibSTEUV n = runST $ EV.startEvalUVectorMemo (fibm n) prop_STEUVEqv :: MedInt Int -> Bool prop_STEUVEqv (MedInt n) = fibMap n == fibSTEUV n fibIOEV :: Int -> IO Integer fibIOEV n = EV.startEvalVectorMemo (fibm n) prop_IOEVEqv :: MedInt Int -> Property prop_IOEVEqv (MedInt n) = monadicIO $ do r <- run $ fibIOEV n assert $ r == fibMap n fibIOEUV :: Int -> IO Int fibIOEUV n = EV.startEvalUVectorMemo (fibm n) prop_IOEUVEqv :: MedInt Int -> Property prop_IOEUVEqv (MedInt n) = monadicIO $ do r <- run $ fibIOEUV n assert $ r == fibMap n -- | Unsafe vector tests ------------------------ fibSTUSV :: Int -> Integer fibSTUSV n = runST $ UV.unsafeEvalVectorMemo (fibm n) (n+1) prop_STUSVEqv :: MedInt Int -> Bool prop_STUSVEqv (MedInt n) = fibMap n == fibSTUSV n fibSTUSUV :: Int -> Int fibSTUSUV n = runST $ UV.unsafeEvalUVectorMemo (fibm n) (n+1) prop_STUSUVEqv :: MedInt Int -> Bool prop_STUSUVEqv (MedInt n) = fibMap n == fibSTUSUV n fibIOUSV :: Int -> IO Integer fibIOUSV n = UV.unsafeEvalVectorMemo (fibm n) (n+1) prop_IOUSVEqv :: MedInt Int -> Property prop_IOUSVEqv (MedInt n) = monadicIO $ do r <- run $ fibIOUSV n assert $ r == fibMap n fibIOUSUV :: Int -> IO Int fibIOUSUV n = UV.unsafeEvalUVectorMemo (fibm n) (n+1) prop_IOUSUVEqv :: MedInt Int -> Property prop_IOUSUVEqv (MedInt n) = monadicIO $ do r <- run $ fibIOUSUV n assert $ r == fibMap n -- | Hofstadter Female and Male sequences -- Mutually recursive functions hf :: Int -> Int hf n = gof n where gof 0 = 1 gof i = i - ms !! (fs !! (i-1)) gom 0 = 0 gom i = i - fs !! (ms !! (i-1)) fs = [gof j | j <- [0..n]] ms = [gom j | j <- [0..n]] -- hfm :: a -> t1 m a hfm n = gof n where gof 0 = return 1 gof i = do fs <- memol0 gof (i-1) ms <- memol1 gom fs return (i - ms) gom 0 = return 0 gom i = do ms <- memol1 gom (i-1) fs <- memol0 gof ms return (i - fs) hfM :: Int -> Int hfM = startEvalMemo . startEvalMemoT . hfm prop_hfMEqv :: MedInt Int -> Property prop_hfMEqv (MedInt n) = hfM n === hf n hfIOA :: Int -> IO Int hfIOA n = (`evalArrayMemo`(0,n)) . (`evalArrayMemo`(0,n)) . hfm $ n hfIOAU :: Int -> IO Int hfIOAU n = (`evalUArrayMemo`(0,n)) . (`evalUArrayMemo`(0,n)) . hfm $ n hfSTA :: Int -> Int hfSTA n = runST $ (`evalArrayMemo`(0,n)) . (`evalArrayMemo`(0,n)) . hfm $ n hfSTAU :: Int -> Int hfSTAU n = runST $ (`evalUArrayMemo`(0,n)) . (`evalUArrayMemo`(0,n)) . hfm $ n hfIOV :: Int -> IO Int hfIOV n = (`evalVectorMemo`(n+1)) . (`evalVectorMemo`(n+1)) . hfm $ n hfIOVU :: Int -> IO Int hfIOVU n = (`evalUVectorMemo`(n+1)) . (`evalUVectorMemo`(n+1)) . hfm $ n hfSTV :: Int -> Int hfSTV n = runST $ (`evalVectorMemo`(n+1)) . (`evalVectorMemo`(n+1)) . hfm $ n hfSTVU :: Int -> Int hfSTVU n = runST $ (`evalUVectorMemo`(n+1)) . (`evalUVectorMemo`(n+1)) . hfm $ n hfSTVE :: Int -> Int hfSTVE n = runST $ (EV.startEvalVectorMemo) . (EV.startEvalVectorMemo) . hfm $ n hfSTVUE :: Int -> Int hfSTVUE n = runST $ (EV.startEvalUVectorMemo) . (EV.startEvalUVectorMemo) . hfm $ n prop_hfIOEqv :: MedInt Int -> Property prop_hfIOEqv (MedInt n) = monadicIO $ do hfIOAn <- run $ hfIOA n hfIOAUn <- run $ hfIOAU n hfIOVn <- run $ hfIOV n hfIOVUn <- run $ hfIOVU n return $ hfIOAn === hfn .&&. hfIOAUn === hfn .&&. hfIOVn === hfn .&&. hfIOVUn === hfn where hfn = hf n prop_hfSTAEqv :: MedInt Int -> Property prop_hfSTAEqv (MedInt n) = hfSTA n === hf n prop_hfSTAUEqv :: MedInt Int -> Property prop_hfSTAUEqv (MedInt n) = hfSTAU n === hf n prop_hfSTVEqv :: MedInt Int -> Property prop_hfSTVEqv (MedInt n) = hfSTV n === hf n prop_hfSTVUEqv :: MedInt Int -> Property prop_hfSTVUEqv (MedInt n) = hfSTVU n === hf n prop_hfSTVEEqv :: MedInt Int -> Property prop_hfSTVEEqv (MedInt n) = hfSTVE n === hf n prop_hfSTVUEEqv :: MedInt Int -> Property prop_hfSTVUEEqv (MedInt n) = hfSTVUE n === hf n tests = [ testGroup "Transformers" [ testProperty "ReaderEqv" prop_ReaderEqv, testProperty "ReaderSTEqv" prop_ReaderSTEqv, testProperty "WriterEqv" prop_WriterEqv, testProperty "ContEqv" prop_ContEqv, testProperty "ContSTUEqv" prop_ContSTUEqv, testProperty "StateEqv" prop_StateEqv ], testGroup "Others" [ testProperty "MutualFEqv" prop_MutualFEqv, testProperty "MutualGEqv" prop_MutualGEqv, testProperty "MutualCurryFEqv" prop_Mutual2FEqv, testProperty "MutualCurryGEqv" prop_Mutual2GEqv, testGroup "Hofstadter" [ testProperty "Map" prop_hfMEqv, testProperty "IO (Arr & Vec)" prop_hfIOEqv, testGroup "ST" [ testProperty "Vector" prop_hfSTVEqv, testProperty "UVector" prop_hfSTVUEqv, testProperty "Array" prop_hfSTAEqv, testProperty "UArray" prop_hfSTAUEqv, testProperty "Vector exp" prop_hfSTVEEqv, testProperty "UVector exp" prop_hfSTVUEEqv ] ] ], testGroup "Different memo-caches" [ testGroup "ArrayCache" [ testProperty "Data.IntMap cache" prop_IntMapEqv, testProperty "STArray cache" prop_STAEqv, testProperty "STUArray cache" prop_STUAEqv, testProperty "STUArray Double" prop_STUADEqv, testProperty "IOArray cache" prop_IOAEqv, testProperty "IOUArray cache" prop_IOUAEqv ], testGroup "VectorCache" [ testProperty "STVector cache" prop_STVEqv, testProperty "STUVector cache" prop_STUVEqv, testProperty "IOVector cache" prop_IOVEqv, testProperty "IOUVector cache" prop_IOUVEqv ], testGroup "Expandable VectorCache" [ testProperty "STVector cache" prop_STEVEqv, testProperty "STUVector cache" prop_STEUVEqv, testProperty "IOVector cache" prop_IOEVEqv, testProperty "IOUVector cache" prop_IOEUVEqv ], testGroup "Unsafe VectorCache" [ testProperty "STVector cache" prop_STUSVEqv, testProperty "STUVector cache" prop_STUSUVEqv, testProperty "IOVector cache" prop_IOUSVEqv, testProperty "IOUVector cache" prop_IOUSUVEqv ] ] ] monad-memo-0.5.4/benchmark/Main.hs0000644000000000000000000001747314164705676015145 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, BangPatterns #-} module Main (main) where import Data.Int import Data.List import Data.Word import qualified Data.IntMap as IM import Data.Array import Control.Monad.ST import Control.Monad.Memo import Control.Monad.Memo.Class import Control.Monad.Memo.Vector.Unsafe import Control.Monad.Memo.Vector.Expandable import Criterion.Main -- Fibonacci numbers -------------------- {-# INLINE fibm #-} fibm :: (Eq k, Num k, Num v, MonadMemo k v m) => k -> m v fibm 0 = return 0 fibm 1 = return 1 fibm n = do f1 <- memo fibm (n - 1) f2 <- memo fibm (n - 2) return (f1+f2) fibM :: Int -> Word fibM = startEvalMemo . fibm fibIM :: Int -> Word fibIM n = evalMemoState (fibm n) IM.empty fibIOA :: Int -> IO Word fibIOA n = evalArrayMemo (fibm n) (0,n) fibIOUA :: Int -> IO Word fibIOUA n = evalUArrayMemo (fibm n) (0,n) fibSTA :: Int -> Word fibSTA n = runST $ evalArrayMemo (fibm n) (0,n) fibSTUA :: Int -> Word fibSTUA n = runST $ evalUArrayMemo (fibm n) (0,n) fibIOV :: Int -> IO Word fibIOV n = evalVectorMemo (fibm n) (n+1) fibIOUV :: Int -> IO Word fibIOUV n = evalUVectorMemo (fibm n) (n+1) fibSTV :: Int -> Word fibSTV n = runST $ evalVectorMemo (fibm n) (n+1) fibSTUV :: Int -> Word fibSTUV n = runST $ evalUVectorMemo (fibm n) (n+1) fibIOVU :: Int -> IO Word fibIOVU n = unsafeEvalVectorMemo (fibm n) (n+1) fibIOUVU :: Int -> IO Word fibIOUVU n = unsafeEvalUVectorMemo (fibm n) (n+1) fibSTVU :: Int -> Word fibSTVU n = runST $ unsafeEvalVectorMemo (fibm n) (n+1) fibSTUVU :: Int -> Word fibSTUVU n = runST $ unsafeEvalUVectorMemo (fibm n) (n+1) fibIOVE :: Int -> IO Word fibIOVE n = startEvalVectorMemo (fibm n) fibIOUVE :: Int -> IO Word fibIOUVE n = startEvalUVectorMemo (fibm n) fibSTVE :: Int -> Word fibSTVE n = runST $ startEvalVectorMemo (fibm n) fibSTUVE :: Int -> Word fibSTUVE n = runST $ startEvalUVectorMemo (fibm n) -- 0-1 Knapsack problem ----------------------- {-# INLINE knap #-} knap :: MonadMemo (Int, Int) Int m => [Int] -> [Int] -> Int -> m Int knap ws vs = m (l-1) where l = length ws wa = listArray (0,l-1) ws va = listArray (0,l-1) vs {-# INLINE m #-} m 0 _ = return 0 m !i !w | wa ! i > w = for2 memo m (i-1) w | otherwise = do !m1 <- for2 memo m (i-1) w !m2 <- for2 memo m (i-1) (w - wa ! i) return (m1 `max` (m2 + va ! i)) knapM :: [Int] -> [Int] -> Int -> Int knapM ws vs w = startEvalMemo (knap ws vs w) knapSTA :: [Int] -> [Int] -> Int -> Int knapSTA ws vs w = runST $ evalArrayMemo (knap ws vs w) ((0,0), ((length ws),w)) knapSTUA :: [Int] -> [Int] -> Int -> Int knapSTUA ws vs w = runST $ evalUArrayMemo (knap ws vs w) ((0,0), ((length ws),w)) knapIOA :: [Int] -> [Int] -> Int -> IO Int knapIOA ws vs w = evalArrayMemo (knap ws vs w) ((0,0), ((length ws),w)) knapIOUA :: [Int] -> [Int] -> Int -> IO Int knapIOUA ws vs w = evalUArrayMemo (knap ws vs w) ((0,0), ((length ws),w)) -- Longest common subsequence ----------------------------- {-# INLINE lcsm2 #-} lcsm2 :: MonadMemo (Int,Int) Int m => [Int] -> [Int] -> m Int lcsm2 as bs = lcs la lb where la = length as lb = length bs aa = listArray (1,la) as ba = listArray (1,lb) bs {-# INLINE lcs #-} lcs 0 _ = return 0 lcs _ 0 = return 0 lcs ia ib | (aa!ia) == (ba!ib) = succ `liftM` for2 memo lcs (ia-1) (ib-1) | otherwise = do !l1 <- for2 memo lcs (ia-1) ib !l2 <- for2 memo lcs ia (ib-1) return (l1 `max` l2) lcsM :: [Int] -> [Int] -> Int lcsM as bs = startEvalMemo (lcsm2 as bs) lcsSTA :: [Int] -> [Int] -> Int lcsSTA as bs = runST $ evalArrayMemo (lcsm2 as bs) ((0,0), (length as, length bs)) lcsSTUA :: [Int] -> [Int] -> Int lcsSTUA as bs = runST $ evalUArrayMemo (lcsm2 as bs) ((0,0), (length as, length bs)) {-# INLINE lcsm #-} lcsm :: MonadMemo Int Int m => [Int] -> [Int] -> m Int lcsm as bs = lcs la lb where la = genericLength as lb = genericLength bs aa = listArray (1,la) as ba = listArray (1,lb) bs {-# INLINE lcs #-} lcs 0 _ = return 0 lcs _ 0 = return 0 lcs ia ib | (aa!ia) == (ba!ib) = succ `liftM` mlcs (ia-1) (ib-1) | otherwise = do l1 <- mlcs (ia-1) ib l2 <- mlcs ia (ib-1) return (l1 `max` l2) mlcs ai bi = memo (\abi -> uncurry lcs $! abi `quotRem` lb) (ai*lb + bi) lcsIM :: [Int] -> [Int] -> Int lcsIM as bs = evalMemoState (lcsm as bs) IM.empty lcsSTUV :: [Int] -> [Int] -> Int lcsSTUV as bs = runST $ evalUVectorMemo (lcsm as bs) ((length as + 1) * (length bs + 1)) lcsSTUVE :: [Int] -> [Int] -> Int lcsSTUVE as bs = runST $ startEvalUVectorMemo (lcsm as bs) -- | Hofstadter Female and Male sequences -- Mutually recursive memoized functions gof :: (MonadTrans t, MonadCache Int Int m, MonadCache Int Int (t m)) => Int -> t m Int gof 0 = return 1 gof i = do fs <- memol0 gof (i-1) ms <- memol1 gom fs return (i - ms) gom :: (MonadTrans t, MonadCache Int Int m, MonadCache Int Int (t m)) => Int -> t m Int gom 0 = return 0 gom i = do ms <- memol1 gom (i-1) fs <- memol0 gof ms return (i - fs) fM :: Int -> Int fM = startEvalMemo . startEvalMemoT . gof fSTA :: Int -> Int fSTA n = runST $ (`evalArrayMemo`(0,n)) . (`evalArrayMemo`(0,n)) . gof $ n fSTAU :: Int -> Int fSTAU n = runST $ (`evalUArrayMemo`(0,n)) . (`evalUArrayMemo`(0,n)) . gof $ n fSTV :: Int -> Int fSTV n = runST $ (`evalVectorMemo`(n+1)) . (`evalVectorMemo`(n+1)) . gof $ n fSTVU :: Int -> Int fSTVU n = runST $ (`evalUVectorMemo`(n+1)) . (`evalUVectorMemo`(n+1)) . gof $ n fSTVUU :: Int -> Int fSTVUU n = runST $ (`unsafeEvalUVectorMemo`(n+1)) . (`unsafeEvalUVectorMemo`(n+1)) . gof $ n main :: IO () main = defaultMainWith defaultConfig [ bgroup "fib" [ bgroup "pure" [ bench "Map" $ whnf fibM n , bench "IntMap" $ whnf fibIM n ] , bgroup "ST" [ bench "Array" $ whnf fibSTA n , bench "UArray" $ whnf fibSTUA n , bench "Vector" $ whnf fibSTV n , bench "UVector" $ whnf fibSTUV n , bench "Vector unsafe" $ whnf fibSTVU n , bench "UVector unsafe" $ whnf fibSTUVU n , bench "Vector exp" $ whnf fibSTVE n , bench "UVector exp" $ whnf fibSTUVE n ] , bgroup "IO" [ bench "Array" $ whnfIO (fibIOA n) , bench "UArray" $ whnfIO (fibIOUA n) , bench "Vector" $ whnfIO (fibIOV n) , bench "UVector" $ whnfIO (fibIOUV n) , bench "Vector unsafe" $ whnfIO (fibIOVU n) , bench "UVector unsafe" $ whnfIO (fibIOUVU n) , bench "Vector exp" $ whnfIO (fibIOVE n) , bench "UVector exp" $ whnfIO (fibIOUVE n) ] ] , bgroup "knapsack" [ bgroup "pure" [ bench "Map" $ whnf (knapM ws vs) w ] , bgroup "ST" [ bench "Array" $ whnf (knapSTA ws vs) w , bench "UArray" $ whnf (knapSTUA ws vs) w ] , bgroup "IO" [ bench "Array" $ whnfIO (knapIOA ws vs w) , bench "UArray" $ whnfIO (knapIOUA ws vs w) ] ] , bgroup "LCS" [ bgroup "pure" [ bench "Map" $ whnf (lcsM as) bs , bench "IntMap" $ whnf (lcsIM as) bs ] , bgroup "ST" [ bench "Array" $ whnf (lcsSTA as) bs , bench "UArray" $ whnf (lcsSTUA as) bs , bench "UVector exp" $ whnf (lcsSTUVE as) bs , bench "UVector" $ whnf (lcsSTUV as) bs ] ] , bgroup "Hofstadter" [ bgroup "pure" [ bench "Map" $ whnf fM fn ] , bgroup "ST" [ bench "Array" $ whnf fSTA fn , bench "UArray" $ whnf fSTAU fn , bench "Vector" $ whnf fSTV fn , bench "UVector" $ whnf fSTVU fn , bench "UVector unsafe" $ whnf fSTVUU fn ] ] ] where -- fib arg n = 100000 -- knapsac args ws = [1..200] vs = [1..200] w = 800 -- LCS args as = [1..400] bs = [100,102..800] -- Hofstadter fn = 100000 monad-memo-0.5.4/LICENSE0000644000000000000000000000276514164705676012776 0ustar0000000000000000Copyright (c)2011, Eduard Sergeev 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 Eduard Sergeev 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. monad-memo-0.5.4/Setup.hs0000644000000000000000000000005514164705676013413 0ustar0000000000000000import Distribution.Simple main = defaultMainmonad-memo-0.5.4/monad-memo.cabal0000644000000000000000000000716614164705676015006 0ustar0000000000000000Name: monad-memo Version: 0.5.4 -- A short (one-line) description of the package. Synopsis: Memoization monad transformer -- A longer description of the package. Description: Memoization monad transformer supporting most of the standard monad transformers and a range of memoization cache types: from default pure maps to extremely fast mutable vectors . To add memoization behaviour to a monadic function: . 1) Add 'Control.Monad.Memo.memo' combinator at the point when memoization is required (i.e. recursive call) . >import Control.Monad.Memo > >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = do > n1 <- memo fibm (n-1) > n2 <- memo fibm (n-2) > return (n1+n2) . 2) Use appropriate /*eval*/ or /*run*/ function to evaluate resulting `MonadMemo` monad: . >startEvalMemo (fibm 100) . See detailed description and examples: "Control.Monad.Memo" -- URL for the project homepage or repository. Homepage: https://github.com/EduardSergeev/monad-memo -- The license under which the package is released. License: BSD3 -- The file containing the license text. License-file: LICENSE -- The package author(s). Author: Eduard Sergeev -- An email address to which users can send suggestions, bug reports, -- and patches. Maintainer: eduard.sergeev@gmail.com Category: Control, Monad Build-type: Simple -- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.10 Tested-with: GHC==7.8.4 GHC==7.10.3 GHC==8.2.2 GHC==8.4.3 GHC==8.6.5 GHC==8.8.4 GHC==9.2.1 Extra-source-files: CHANGELOG.md, README.md, example/*.hs, example/Customisation/*.hs Source-repository head type: git location: https://github.com/EduardSergeev/monad-memo.git Library default-language: Haskell2010 build-depends: base >= 3.0 && <= 5.0, transformers >= 0.2, containers >= 0.3, array >= 0.3, vector >= 0.7, primitive >= 0.3 if impl(ghc < 7.10) build-depends: transformers-compat >= 0.3 exposed-modules: Control.Monad.Memo, Control.Monad.Memo.Class, Control.Monad.Trans.Memo.ReaderCache, Control.Monad.Trans.Memo.StateCache, Control.Monad.Trans.Memo.State, Control.Monad.Trans.Memo.Map, Control.Monad.Memo.Array, Control.Monad.Memo.Array.Instances, Control.Monad.Memo.Vector, Control.Monad.Memo.Vector.Expandable, Control.Monad.Memo.Vector.Unsafe, Control.Monad.Memo.Vector.Instances, Data.MapLike, Data.MapLike.Instances, Data.MaybeLike, Data.MaybeLike.Instances Test-suite tests default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs build-depends: monad-memo, base >= 3.0 && <= 5.0, transformers >= 0.2, containers >= 0.3, array >= 0.3, vector >= 0.7, primitive >= 0.3, random >= 1.0, QuickCheck >= 2.0, test-framework-quickcheck2 >= 0.2.9, test-framework >= 0.3.3 if impl(ghc < 7.10) build-depends: transformers-compat >= 0.3 other-modules: MemoTest Benchmark all default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: benchmark main-is: Main.hs build-depends: monad-memo, base >= 3.0 && <= 5.0, transformers >= 0.2, containers >= 0.3, array >= 0.3, vector >= 0.7, primitive >= 0.3, criterion >= 0.6 if impl(ghc < 7.10) build-depends: transformers-compat >= 0.3 monad-memo-0.5.4/CHANGELOG.md0000644000000000000000000000334314164705676013573 0ustar0000000000000000# Change Log All notable changes to the `monad-memo` project will be documented in this file ## [0.5.4] - 2022-01-04 ### Fixed - Fix GHC 9.2.1 build ## [0.5.3] - 2020-09-21 ### Fixed - `README.md` links ### Removed - Travis-ci build configuration ## [0.5.2] - 2020-09-20 ### Added - CI on Github actions with test coverage and Hackage upload ### Fixed - `monad-memo.cabal` structure: redundancy and to enable test coverage calculation - `CHANGELOG.md` structure ## [0.5.1] - 2018-08-31 ### Added - Support multiple mutable caches in transformers stack This allows Array/Vector-based caches to be used for mutually recursive function memoization ## [0.5.0] - 2018-08-06 ### Fixed - Refresh project to be compilable with latest GHC and libraries - Remove dependency on `mtl` package (`transformers` is sufficient) - Use `Except` instead of deprecated `Error` - Remove support for `ListT` transformer since it is now deprecated - Use standard `StateT` & `ReaderT` for `MonadCache` implementations ## [0.4.1] - 2013-03-06 ### Fixed - Documentation - `Example` is renamed to `example` and is excluded from package's module hierarchy ## [0.4.0] - 2013-02-26 ### Added - `ArrayCache`: mutable array-based `MonadCache` for top performance - `VectorCache` (and flavours) `vector`-based `MonadCache` for even better performance - Simple benchmark included ### Fixed - Bug fixes in transformer implementations (`Reader`, `State`, `RWS`) ## [0.3.0] - 2011-04-03 ### Added - Added generalized `MemoStateT` transformer (to host any `Data.MapLike` cache-container) - `MemoT` is now `MemoStateT` instantiated with `Data.Map` ## [0.2.0] - 2011-03-27 ### Added - A set of `forX` functions (`for2`, `for3` and `for4`) to adapt curried function into uncurried `MemoCache` monad-memo-0.5.4/README.md0000644000000000000000000004225114164705676013242 0ustar0000000000000000# monad-memo [![Build Status](https://github.com/EduardSergeev/monad-memo/workflows/master/badge.svg)](https://github.com/EduardSergeev/monad-memo/actions?query=workflow%3Amaster+branch%3Amaster) [![Test Coverage](https://coveralls.io/repos/github/EduardSergeev/monad-memo/badge.svg)](https://coveralls.io/github/EduardSergeev/monad-memo) [![Hackage](https://img.shields.io/hackage/v/monad-memo.svg)](https://hackage.haskell.org/package/monad-memo) [![Hackage](https://img.shields.io/badge/dynamic/xml?color=success&label=Downloads&query=substring-before%28%2F%2F%2A%5B%40id%3D%22properties%22%5D%2Ftable%2Ftbody%2Ftr%2Fth%5Btext%28%29%5Bnormalize-space%28.%29%3D%27Downloads%27%5D%5D%2F..%2Ftd%2C%20%27%20%27%29&url=https%3A%2F%2Fhackage.haskell.org%2Fpackage%2Fmonad-memo)](https://hackage.haskell.org/package/monad-memo) ## Purpose This package provides a convenient mechanism for adding memoization to Haskell monadic functions. ## Memoization Memoization is a well known way to speed up function evaluation by caching previously calculated results and reusing them whenever a memoized function is needed to be evaluated with the same arguments again. It is usually associated with dynamic programming techiques. ## Overview Even though it is possible to manually add memoization to the code which would benefit from it, this ad-hoc approach has usual ad-hoc drawbacks: code pollution, bugs, resistance to changes. This package however encapsulates the underlying plumbing behind its simple monadic interface `MonadMemo` with a single combinator `memo` which, when applied to monadic function, turns it into "memoized" one. The package offers various implementation of `MonadMemo` (which differs in terms of performance and requirements) and it is possible to choose/change the implementation without affecting the main function code. The range of supported implementations "out of box" is limited by the range of containers provided by the standard packages installed by [Haskel Platform](http://www.haskell.org/platform/): from default pure "fit them all" [Data.Map](http://hackage.haskell.org/packages/archive/containers/latest/doc/html/Data-Map.html) to very fast but limiting [vector](http://hackage.haskell.org/packages/archive/vector/latest/doc/html/Data-Vector-Generic-Mutable.html). It is also possible to plug-in a custom container (from a third-party library) and run existing monadic code with it. The default implementation of `MonadMemo` is also [monad transformer](http://en.wikibooks.org/wiki/Haskell/Monad_transformers) so it can be "mixed" with other monads. The package also provides the "memoized" versions of most standard monads found in [mtl](http://hackage.haskell.org/package/mtl). ## Example of usage A clasic example of function which greatelly benefits from memoization is a recursively defined Fibonacci number function. A plain version of this function can be written in the following way: ```haskell fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) ``` which is very inefficient (impractical for `n>40`). We can rewrite this definition as a monad: ```haskell fibm :: Monad m => Integer -> m Integer fibm 0 = return 0 fibm 1 = return 1 fibm n = do f1 <- fibm (n-1) f2 <- fibm (n-2) return (f1+f2) ``` and even run it with `Identity` monad with identical inefficiency: ```haskell evalFibmId :: Integer -> Integer evalFibmId = runIdentity . fibm ``` But all we need to do to make this function "computable" for reasonable argument is to add memoization for both recursive branches with `memo` combinator: ```haskell fibm :: (MonadMemo Integer Integer m) => Integer -> m Integer fibm 0 = return 0 fibm 1 = return 1 fibm n = do f1 <- memo fibm (n-1) f2 <- memo fibm (n-2) return (f1+f2) ``` then, to evaluate it with default `Data.Map` based memoization cache we use the following "eval*" function: ```haskell evalFibm :: Integer -> Integer evalFibm = startEvalMemo . fibm ``` Now the range of the arguments it can handle is limited only by `Integer` computation complexity and stack memory limit. ## More Examples ### Slightly more complicated recursive function Well known [Ackerman function](http://en.wikipedia.org/wiki/Ackermann_function) is a two arguments function. To memoize two argument function `for2` combinator can be used, giving the following generic code: ```haskell ackm :: (Num n, Ord n, MonadMemo (n, n) n m) => n -> n -> m n ackm 0 n = return (n+1) ackm m 0 = for2 memo ackm (m-1) 1 ackm m n = do n1 <- for2 memo ackm m (n-1) -- 'for2' adapts 'memo' for 2-argument 'ackm' for2 memo ackm (m-1) n1 evalAckm :: (Num n, Ord n) => n -> n -> n evalAckm n m = startEvalMemo $ ackm n m ``` ### Mutually recursive function memoization This example is taken from paper ["Monadic Memoization Mixins" by Daniel Brown and William R. Cook](http://www.cs.utexas.edu/~wcook/Drafts/2006/MemoMixins.pdf) Given the following mutually recursive function definitions: ```haskell -- 'f' depends on 'g' f :: Int -> (Int,String) f 0 = (1,"+") f (n+1) = (g(n,fst(f n)),"-" ++ snd(f n)) -- 'g' depends on 'f' g :: (Int, Int) -> Int g (0, m) = m + 1 g (n+1,m) = fst(f n)-g(n,m) ``` How can we memoize both functions? Lets try to just add [memo](http://hackage.haskell.org/packages/archive/monad-memo/latest/doc/html/Control-Monad-Memo.html#v:memo) for both functions: ```haskell -- WRONG: Will NOT compile! fm 0 = return (1,"+") fm (n+1) = do fn <- memo fm n gn <- memo gm (n , fst fn) return (gn , "-" ++ snd fn) gm (0,m) = return (m+1) gm (n+1,m) = do fn <- memo fm n gn <- memo gm (n,m) return $ fst fn - gn ``` GHC complains: ```text "Occurs check: cannot construct the infinite type: t = (t, v) Expected type: t Inferred type: (t, v)" ``` which is understandable since we are trying to use the same cache for storing "key-value" pairs of the functions of different types (`fm :: Int -> m (Int,String)` and `gm :: (Int, Int) -> m Int`). Obviously, to cache both function we will need _two_ caches (even if the types of the functions were identical, it's not very good idea to share the same cache). And this is precisely what we have to do - use two memoization caches! The way to achieve it is to use _two_ [MemoT](http://hackage.haskell.org/packages/archive/monad-memo/latest/doc/html/Control-Monad-Memo.html#t:MemoT) monad transformers one nested in another: ```haskell -- Memo-cache for 'fm' type MemoF = MemoT Int (Int,String) -- Memo-cache for 'gm' type MemoG = MemoT (Int,Int) Int -- | Combined stack of caches (transformers) -- Stacks two 'MemoT' transformers in one monad to be used in both 'gm' and 'fm' monadic functions type MemoFG = MemoF (MemoG Identity) ``` NB As usually with Haskell it isn't necessary to specify types here (or restrict them to [MemoT](http://hackage.haskell.org/packages/archive/monad-memo/latest/doc/html/Control-Monad-Memo.html#t:MemoT) combinations for the given example). Then, a little bit of complication, since we use _two_ caches now (one from the current [monad transformer](http://en.wikibooks.org/wiki/Haskell/Monad_transformers) and another from the next, nested in the current) we need to use *memol_X_* set of functions: [memol0](http://hackage.haskell.org/packages/archive/monad-memo/latest/doc/html/Control-Monad-Memo.html#v:memol0), [memol1](http://hackage.haskell.org/packages/archive/monad-memo/latest/doc/html/Control-Monad-Memo.html#v:memol1) etc. Where _X_ specifies "sequential number" of the transformer in stack for a given cache (starting from the current). Here we use the current (0) and the next (1) for `fm` and `gm` respectively: ```haskell fm :: Int -> MemoFG (Int,String) fm 0 = return (1,"+") fm (n+1) = do fn <- memol0 fm n gn <- memol1 gm (n , fst fn) return (gn , "-" ++ snd fn) gm :: (Int,Int) -> MemoFG Int gm (0,m) = return (m+1) gm (n+1,m) = do fn <- memol0 fm n gn <- memol1 gm (n,m) return $ fst fn - gn evalAll = startEvalMemo . startEvalMemoT -- | Function to run 'fm' computation evalFm :: Int -> (Int, String) evalFm = evalAll . fm -- | Function to run 'gm' computation evalGm :: (Int,Int) -> Int evalGm = evalAll . gm ``` In fact we can also define 'gm' function in curried form: ```haskell fm2 :: Int -> MemoFG (Int,String) fm2 0 = return (1,"+") fm2 n = do fn <- memol0 fm2 (n-1) gn <- for2 memol1 gm2 (n-1) (fst fn) return (gn , "-" ++ snd fn) -- 2-argument function now gm2 :: Int -> Int -> MemoFG Int gm2 0 m = return (m+1) gm2 n m = do fn <- memol0 fm2 (n-1) gn <- for2 memol1 gm2 (n-1) m -- 'for2' adapts 'memol1' for 2-argument gm2 return $ fst fn - gn evalFm2 :: Int -> (Int, String) evalFm2 = evalAll . fm2 evalGm2 :: Int -> Int -> Int evalGm2 n m = evalAll $ gm2 n m ``` ### Combining MemoT with other monads Being monad transformer, memoization monad can be combined with most of existing monads. Here we mix it with [MonadWriter](http://hackage.haskell.org/packages/archive/mtl/latest/doc/html/Control-Monad-Writer-Class.html#t:MonadWriter): ```haskell fibmw :: (Num n, MonadWriter String m, MonadMemo n n m) => n -> m n fibmw 0 = tell "0" >> return 0 fibmw 1 = tell "1" >> return 1 fibmw n = do f1 <- memo fibmw (n-1) f2 <- memo fibmw (n-2) tell $ show n return (f1+f2) -- To run combined monad we need to sequence both 'run' functions: evalFibmw :: Integer -> (Integer, String) evalFibmw = startEvalMemo . runWriterT . fibmw res = evalFibmw 6 -- > produces (8,"1021310241021351021310246") ``` ## Custom pure cache container From monad-memo [version 0.3.0](http://hackage.haskell.org/package/monad-memo-0.3.0) it is possible to replace default [Data.Map](http://hackage.haskell.org/packages/archive/containers/latest/doc/html/Data-Map.html) with another (more efficient?) implementation of internal cache-container as long as there is an instance of [Data.MapLike](http://hackage.haskell.org/packages/archive/monad-memo/0.3.0/doc/html/Data-MapLike.html) defined for this container. The package currently defines these instances for [Data.Map](http://hackage.haskell.org/packages/archive/containers/latest/doc/html/Data-Map.html) and [Data.IntMap](http://hackage.haskell.org/packages/archive/containers/latest/doc/html/Data-IntMap.html) only. For instance, should we decide to use [unordered-containers](http://hackage.haskell.org/package/unordered-containers) all we need to do is to define the following instance for our container: ```haskell import Data.Hashable import qualified Data.HashMap.Strict as H instance (Eq k, Hashable k) => MapLike (H.HashMap k v) k v where lookup = H.lookup add = H.insert ``` then we just need to use `(``evalMemoState``H.empty)` instead of `startEvalMemo` and our memoized function will be evaluated using `Hashmap` as an internal container hosted in [MemoState](http://hackage.haskell.org/packages/archive/monad-memo/latest/doc/html/Control-Monad-Trans-Memo-State.html#t:MemoState). There is usually no need to do any modification to the memoized function itself. ## Mutable arrays and vectors as MonadCache ### Array-based memoization cache [version 0.4.0](http://hackage.haskell.org/package/monad-memo-0.4.0) adds [ArrayCache](http://hackage.haskell.org/packages/archive/monad-memo/0.4.0/doc/html/Control-Monad-Memo-Array.html): a new [MonadCache](http://hackage.haskell.org/packages/archive/monad-memo/0.4.0/doc/html/Control-Monad-Memo-Class.html#t:MonadCache) implementation based on mutable arrays (inside [IO](http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-IO.html#t:IO) or [ST s](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Monad-ST.html) monad). The main benefit of this `MonadCache` is its performance: it can be an order of magnitude faser than standard `Data.Map`-based cache. This is due to the fact that arrays have `O(1)` lookup time and in-place mutable arrays also have `O(1)` for updates (i.e. the cache `add` operation). Unfortunatelly you cannot always use this `MonadCache` due to array's natural limitations: * The key must be an instance of [Ix](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Ix.html#t:Ix) typeclass * The bounds of the array must be known (and specified) beforehand and array cannot be resized * Array is a continious space of values, so if the key distribution is wide and sparse the memory will be wasted (or array may not even fit into memory) But if the nature of your memoized function permits the usage of `ArrayCache` you can make your code much more faster by simply switching from Map-based `MonadCache` to `ArrayCache` especially if the value type of your function can be "unboxed" (i.e. it is one of primitive types like `Int` or `Double`). "Unboxed" values are packed in unboxed arrays `UArray` which offer even faster execution and are the most efficient in terms of memory usage. Normally you don't have to modify your monadic function definition to run `ArrayCache`-based memoization: just use appropriate `eval*` or `run*` function. For instance our canonical `fibm` function: ```haskell fibm 0 = return 0 fibm 1 = return 1 fibm n = do n1 <- memo fibm (n-1) n2 <- memo fibm (n-2) return (n1+n2) ``` can be run using `ST` array of `Integers` with the following function: ```haskell evalFibmSTA :: Integer -> Integer evalFibmSTA n = runST $ evalArrayMemo (fibm n) (0,n) ``` here the `(0,n)` argument defines the bounds of cache array. Is it equally easy to use unboxed version of the array, but `Integer` cannot be unboxed (it isn't primitive type), so lets just use `Double` for our function result: ```haskell evalFibmSTUA :: Integer -> Double evalFibmSTUA n = runST $ evalUArrayMemo (fibm n) (0,n) ``` Instead of `ST` you can use `IO` monad: ```haskell evalFibmIOA :: Integer -> IO Integer evalFibmIOA n = evalArrayMemo (fibm n) (0,n) evalFibmIOUA :: Integer -> IO Double evalFibmIOUA n = evalUArrayMemo (fibm n) (0,n) ``` ### Vector-based memoization cache For even better performance use [VectorCache](http://hackage.haskell.org/packages/archive/monad-memo/0.4.0/doc/html/Control-Monad-Memo-Vector.html) and its flavours ([unsafe version](http://hackage.haskell.org/packages/archive/monad-memo/0.4.0/doc/html/Control-Monad-Memo-Vector-Unsafe.html) and [dynamically expandable version](http://hackage.haskell.org/packages/archive/monad-memo/0.4.0/doc/html/Control-Monad-Memo-Vector-Expandable.html)) which are all based on very fast [vector](http://hackage.haskell.org/package/vector) library. Note however that this `MonadCache` is even more limiting that `ArrayCache` since `vector` supports only `Int` as an index. The usage is very similar to `ArrayCache`, but instead of range we need to specify the length of the vector: ```haskell evalFibmSTV :: Int -> Integer evalFibmSTV n = runST $ evalVectorMemo (fibm n) n evalFibmIOUV :: Int -> IO Double evalFibmIOUV n = evalUVectorMemo (fibm n) n ``` Use "Expandable" version to avoid specifying length parameter: ```haskell import qualified Control.Monad.Memo.Vector.Expandable as VE evalFibmSTVE :: Int -> Integer evalFibmSTVE n = runST $ VE.startEvalVectorMemo (fibm n) ``` ## Performance of different `MonadCache`'s The difference in performance for different `MonadCache`'s with Fibonacci function is demonstrated by [this criterion test](benchmark/Main.hs). The test runs memoized Fibonacci function using the following caches: * default Map-based * State-based with Data.IntMap * array and unboxed array based (Array and UArray) * vector, unsafe vector and expandable vector (both boxed and unboxed vectors) ![summary](benchmark/results/fib_memo.png) Full report can be [found here](http://htmlpreview.github.com/?https://github.com/EduardSergeev/monad-memo/blob/dev/benchmark/results/fib_memo.html). ## Custom mutable cache It is also possible to use a mutable container as a `MonadCache` not defined here. For example if we wish to use mutable hash-table from [hashtables package](http://hackage.haskell.org/package/hashtables) we can do so with the following code: ```haskell {-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} import Data.Hashable import Control.Monad.ST import Control.Monad.Memo import Control.Monad.Trans.Memo.ReaderCache import qualified Data.HashTable.ST.Basic as H newtype Container s k v = Container { toTable :: H.HashTable s k v } type Cache s k v = ReaderCache (Container s k v) instance (Eq k, Hashable k) => MonadMemo k v (Cache s k v (ST s)) where {-# INLINE memo #-} memo f k = do c <- container e <- lift $ H.lookup (toTable c) k if isNothing e then do v <- f k lift $ H.insert (toTable c) k v return v else return (fromJust e) {-# INLINE fib1 #-} fibm 0 = return 0 fibm 1 = return 1 fibm n = do f1 <- memo fibm (n-1) f2 <- memo fibm (n-2) return (f1+f2) evalFib :: Int -> Int evalFib n = runST $ do c <- H.new evalReaderCache (fibm n) (Container c) ``` ## References * [Memoization Haskell wiki](http://www.haskell.org/haskellwiki/Memoization) * ["Monadic Memoization Mixins" by Daniel Brown and William R. Cook](http://www.cs.utexas.edu/~wcook/Drafts/2006/MemoMixins.pdf) * [data-memocombinators](http://hackage.haskell.org/packages/archive/data-memocombinators/latest/doc/html/Data-MemoCombinators.html) * ["Fun with Type Functions" by Oleg Kiselyov, Ken Shan, and Simon Peyton Jones (see 3.1 - "Type-directed memoization")](http://research.microsoft.com/~simonpj/papers/assoc-types/fun-with-type-funs/typefun.pdf) monad-memo-0.5.4/example/Basic.hs0000644000000000000000000003413614164705676014776 0ustar0000000000000000{- | Module : Sample.Memo Copyright : (c) Eduard Sergeev 2011 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) Some basic examples of 'monad-memo' usage -} {-# LANGUAGE FlexibleContexts #-} module Example.Basic ( -- * Memoized Fibonacci number function fibm, evalFibm, runFibm, -- * Combining ListT and MemoT transformers -- | Original sample is taken from: \"Monadic Memoization Mixins\" by Daniel Brown and William R. Cook -- *** Non-memoized original definition Tree(..), fringe, unfringe, -- *** Memoized definition unfringem, evalUnfringem, -- * Mutualy recursive function definitions -- | Original sample is taken from: \"Monadic Memoization Mixins\" by Daniel Brown and William R. Cook -- *** Non-memoized original definition f, g, -- *** Memoized definition MemoF, MemoG, MemoFG, fm, gm, evalFm, evalGm, -- * Fibonacci with mutual recursive addition MemoFib, MemoBoo, MemoFB, boo, fibm2, evalFibM2, -- * Fibonacci with `Memo` and `Writer` fibmw, evalFibmw, -- * Fibonacci with MonadMemo and MonadCont fibmc, evalFibmc, -- * Tribonacci with constant factor through Reader plus memoization via Memo fibmr, evalFibmr, -- * Ackerman function ack, ackm, evalAckm, -- * Levensthein distance editDistance, editDistancem, -- * Travelling salesman problem evalTsp, evalTspSTU, -- * Different MonadCache for the same monadic function -- ** `Data.IntMap`-based evalFibmIM, -- ** `ArrayCache`-based evalFibmSTA, evalFibmIOA, runFibmIOA, evalFibmIOUA, runFibmIOUA, evalFibmSTUA, runFibmSTUA, -- ** `VectorCache`-based evalFibmSTV, evalFibmSTUV, evalFibmIOV, evalFibmIOUV ) where import Control.Monad.Identity import Control.Monad.List import Control.Monad.Cont import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.ST import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Array.ST import Data.Array.Unboxed import qualified Data.Vector as V import qualified Data.Vector.Unboxed as UV import Control.Applicative import Debug.Trace import Data.Array.MArray import Data.Array.IO import Control.Monad.Memo import Control.Monad.Memo.Vector.Expandable as EV -- infix form fibm' :: (Num n, Ord n) => n -> Memo n n n fibm' 0 = return 0 fibm' 1 = return 1 fibm' n = memo fibm' (n-1) `mp` memo fibm' (n-2) where mp = liftM2 (+) -- applicative form fibm'' :: (Num n, Ord n) => n -> Memo n n n fibm'' 0 = return 0 fibm'' 1 = return 1 fibm'' n = (+) <$> memo fibm'' (n-1) <*> memo fibm'' (n-2) -- data Tree a = Leaf !a | Fork !(Tree a) !(Tree a) deriving (Show,Eq) fringe :: Tree a -> [a] fringe (Leaf a) = [a] fringe (Fork t u) = fringe t ++ fringe u partitions as = [ splitAt n as | n <- [1..length as - 1 ]] -- | Non-memoized version (Uses ListT monad - returns a list of 'Tree') unfringe :: (Show t) => [t] -> [Tree t] unfringe [a] = show [a] `trace` [Leaf a] unfringe as = show as `trace` do (l,k) <- partitions as t <- unfringe l u <- unfringe k return (Fork t u) -- | Mixes memoization with ListT monad: -- memoizes the result as list of 'Tree' (e.g. @k :: [t]@, @v :: [Tree t]@) unfringem :: (Ord t, Show t) => [t] -> ListT (Memo [t] [Tree t]) (Tree t) unfringem [a] = show [a] `trace` return (Leaf a) unfringem as = show as `trace` do (l,k) <- ListT $ return (partitions as) t <- memo unfringem l u <- memo unfringem k return (Fork t u) evalUnfringem :: (Ord t, Show t) => [t] -> [Tree t] evalUnfringem = startEvalMemo . runListT . unfringem -- | 'f' depends on 'g' f :: Int -> (Int,String) f 0 = (1,"+") f n = (g(n,fst(f (n-1))),"-" ++ snd(f (n-1))) -- | 'g' depends on 'f' g :: (Int, Int) -> Int g (0, m) = m + 1 g (n,m) = fst(f (n-1))-g((n-1),m) -- | Memo-cache for 'fm' type MemoF = MemoT Int (Int,String) -- | Memo-cache for 'gm' type MemoG = MemoT (Int,Int) Int -- | Combined stack of caches (transformers) -- Stacks two 'MemoT' transformers in one monad to be used in both 'gm' and 'fm' monadic functions type MemoFG = MemoF (MemoG Identity) fm :: Int -> MemoFG (Int,String) fm 0 = return (1,"+") fm n = do fn <- memol0 fm (n-1) gn <- memol1 gm ((n-1) , fst fn) return (gn , "-" ++ snd fn) gm :: (Int,Int) -> MemoFG Int gm (0,m) = return (m+1) gm (n,m) = do fn <- memol0 fm (n-1) gn <- memol1 gm ((n-1),m) return $ fst fn - gn evalAll = startEvalMemo . startEvalMemoT -- | Function to run 'fm' computation evalFm :: Int -> (Int, String) evalFm = evalAll . fm -- | Function to run 'gm' computation evalGm :: (Int,Int) -> Int evalGm = evalAll . gm fm2 :: Int -> MemoFG (Int,String) fm2 0 = return (1,"+") fm2 n = do fn <- memol0 fm2 (n-1) gn <- for2 memol1 gm2 (n-1) (fst fn) return (gn , "-" ++ snd fn) -- | Same as @gm@ but in curried form gm2 :: Int -> Int -> MemoFG Int gm2 0 m = return (m+1) gm2 n m = do fn <- memol0 fm2 (n-1) gn <- for2 memol1 gm2 (n-1) m return $ fst fn - gn evalFm2 :: Int -> (Int, String) evalFm2 = evalAll . fm2 evalGm2 :: Int -> Int -> Int evalGm2 n m = evalAll $ gm2 n m -- type MemoFib = MemoT Integer Integer type MemoBoo = MemoT Double String type MemoFB = MemoFib (MemoBoo Identity) boo :: Double -> MemoFB String boo 0 = "boo: 0" `trace` return "" boo n = ("boo: " ++ show n) `trace` do n1 <- boo `memol1` (n-1) fn <- fibm2 `memol0` floor (n-1) return (show fn ++ n1) fibm2 :: Integer -> MemoFB Integer fibm2 0 = "fib: 0" `trace` return 0 fibm2 1 = "fib: 1" `trace` return 1 fibm2 n = ("fib: " ++ show n) `trace` do l <- boo `memol1` fromInteger n f1 <- fibm2 `memol0` (n-1) f2 <- fibm2 `memol0` (n-2) return (f1 + f2 + floor (read l)) evalFibM2 :: Integer -> Integer evalFibM2 = startEvalMemo . startEvalMemoT . fibm2 -- | Plus MonadWriter fibmw 0 = "fib: 0" `trace` tell "0" >> return 0 fibmw 1 = "fib: 1" `trace` tell "1" >> return 1 fibmw n = ("fib: " ++ show n) `trace` do f1 <- fibmw (n-1) f2 <- fibmw (n-2) tell $ show n return (f1+f2) evalFibmw :: Integer -> (Integer, String) evalFibmw = startEvalMemo . runWriterT . fibmw t1 n = startEvalMemo . runWriterT $ fibmw n >> fibmw 1 t2 n = runWriter $ fibmw n >> fibmw 1 runFibmw n = startRunMemo . runWriterT $ fibmw n >> fibmw 1 evalFibmwSTA n = runST $ evalArrayMemo (runWriterT (fibmw n)) (0,n) evalFibmwSTV n = runST $ evalVectorMemo (runWriterT (fibmw n)) (n+1) runFibmwST :: Integer -> ((Integer,String), Array Integer (Maybe (Integer,String))) runFibmwST n = runST $ do (a,arr) <- runArrayMemo (runWriterT (fibmw n)) (0,n) iarr <- freeze arr return (a,iarr) evalFibmwIO :: Integer -> IO (Integer, String) evalFibmwIO n = evalArrayMemo (runWriterT (fibmw n)) (0,n) -- | Can also be defined with polymorphic monad classes -- MonadCont here fibmc :: (Eq k, Num k, Show k, Num n, MonadCont m, MonadMemo k n m) => k -> m n fibmc 0 = "fib: 0" `trace` return 0 fibmc 1 = "fib: 1" `trace` return 1 fibmc n = ("fib: " ++ show n) `trace` do f1 <- memo fibmc (n-1) f2 <- callCC $ \ break -> do if n == 4 then break 42 else memo fibmc (n-2) return (f1+f2) evalFibmc :: Integer -> Integer evalFibmc = startEvalMemo . (`runContT`return) . fibmc runFibmc = startRunMemo . (`runContT`return) . fibmc evalFibmcIO :: Integer -> IO Integer evalFibmcIO n = (`evalArrayMemo`(0,n)) . (`runContT`return) . fibmc $ n evalFibmcST :: Integer -> Integer evalFibmcST n = runST $ (`evalArrayMemo`(0,n)) $ (`runContT`return) $ fibmc n fibmr :: (Eq k, Num k, Show k, Num n, MonadMemo k n m, MonadReader n m) => k -> m n fibmr 0 = "fib: 0" `trace` return 0 fibmr 1 = "fib: 1" `trace` return 1 fibmr 2 = "fib: 2" `trace` return 1 fibmr n = ("fib: " ++ show n) `trace` do p1 <- ask p2 <- local (const p1) $ memo fibmr (n-2) f1 <- memo fibmr (n-1) f2 <- memo fibmr (n-2) return (p1+f1+f2+p2) evalFibmr :: Integer -> Integer -> Integer evalFibmr r = startEvalMemo . (`runReaderT` r) . fibmr runFibmr r = startRunMemo . (`runReaderT` r) . fibmr fibi 0 = print 0 >> return 0 fibi 1 = print 1 >> return 1 fibi n = do n1 <- fibi (n-1) n2 <- fibi (n-2) let r = n1+n2 print r >> return r fibmi 0 = print 0 >> return 0 fibmi 1 = print 1 >> return 1 fibmi n = do n1 <- memo fibmi (n-1) n2 <- memo fibmi (n-2) let r = n1+n2 print r >> return r -- | Ackerman function ack :: (Eq n, Num n) => n -> n -> n ack 0 n = n+1 ack m 0 = ack (m-1) 1 ack m n = ack (m-1) (ack m (n-1)) ackm :: (Num n, Ord n, MonadMemo (n, n) n m) => n -> n -> m n ackm 0 n = return (n+1) ackm m 0 = for2 memo ackm (m-1) 1 ackm m n = do n1 <- for2 memo ackm m (n-1) for2 memo ackm (m-1) n1 evalAckm :: (Num n, Ord n) => n -> n -> n evalAckm n m = startEvalMemo $ ackm n m runAckm n m = startRunMemo $ ackm n m evalAckmST :: Int -> Int -> Int evalAckmST n m = runST $ evalUArrayMemo (ackm n m) ((0,0),(4,100000)) -- | Levensthein distance - recursive definition editDistance [] ys = length ys editDistance xs [] = length xs editDistance (x:xs) (y:ys) | x == y = editDistance xs ys | otherwise = minimum [ 1 + editDistance xs (y:ys), 1 + editDistance (x:xs) ys, 1 + editDistance xs ys] -- | Levensthein distance - with memoization editDistancem [] ys = return $ length ys editDistancem xs [] = return $ length xs editDistancem (x:xs) (y:ys) | x == y = for2 memo editDistancem xs ys | otherwise = ((+1) . minimum) <$> sequence [ for2 memo editDistancem xs (y:ys), for2 memo editDistancem (x:xs) ys, for2 memo editDistancem xs ys] runEditDistancem xs ys = startEvalMemo $ editDistancem xs ys -- | Travelling salesman problem tsp gph mp t ss | ss == (mp ! t) = return (gph ! (1,t)) | otherwise = do krs <- mapM (\k -> for2 memo (tsp gph mp) k ss' >>= \r -> return (k,r)) (elms ss') return $ minimum [ r + gph ! (k,t) | (k,r) <- krs] where ss' = ss - (mp ! t) elms ss = go 1 ss where go b 1 = [b] go b ss = case ss `quotRem` 2 of (q,1) -> b : go (b+1) q (q,0) -> go (b+1) q calcTsp dim = do rs <- mapM (\k -> for2 memo (tsp gph mp) k (ss-1)) [2..n] return $ minimum [ r + gph ! (k,1) | (r,k) <- zip rs [2..n]] where n = dim^2 cities = [(x*dim+y+1, (fromIntegral x, fromIntegral y)) | x <- [0..dim-1], y <- [0..dim-1]] dists = [((c1,c2), sqrt ((x1-x2)^2 + (y1-y2)^2)) | (c1,(x1,y1)) <- cities, (c2,(x2,y2)) <- cities] gph = array ((1,1),(n,n)) dists :: UArray (Int,Int) Float mp = array (1,n) [(i,2^(i-1)) | i <- [1..n]] :: UArray Int Int ss = 2^n-1 evalTsp = startEvalMemo . calcTsp evalTspSTU dim = runST $ evalUArrayMemo (calcTsp dim) ((1,1),(n,2^n-1)) where n = dim^2 evalTspIOU :: Int -> IO Float evalTspIOU dim = evalUArrayMemo (calcTsp dim) ((1,1),(n,2^n-1)) where n = dim^2 -- | Different `MonadCache` implementations -- The same monadic funtion can be called using different MonadeCache implementation fibm :: (Eq k, Num k, Num n, MonadMemo k n m) => k -> m n fibm 0 = return 0 fibm 1 = return 1 fibm n = do n1 <- memo fibm (n-1) n2 <- memo fibm (n-2) return (n1+n2) evalFibm :: Integer -> Integer evalFibm = startEvalMemo . fibm runFibm :: Integer -> (Integer, M.Map Integer Integer) runFibm = startRunMemo . fibm evalFibmIM :: Int -> Int evalFibmIM n = evalMemoState (fibm n) IM.empty evalFibmSTA :: Integer -> Integer evalFibmSTA n = runST $ evalArrayMemo (fibm n) (0,n) runFibmSTA :: Integer -> (Integer, Array Integer (Maybe Integer)) runFibmSTA n = runST $ do (a,arr) <- runArrayMemo (fibm n) (0,n) iarr <- freeze arr return (a, iarr) evalFibmIOA :: Integer -> IO Integer evalFibmIOA n = evalArrayMemo (fibm n) (0,n) runFibmIOA :: Integer -> IO (Integer, Array Integer (Maybe Integer)) runFibmIOA n = do (r, arr) <- runArrayMemo (fibm n) (0,n) iarr <- freeze arr return (r, iarr) evalFibmIOUA :: Int -> IO Int evalFibmIOUA n = evalUArrayMemo (fibm n) (0,n) runFibmIOUA :: Int -> IO (Int, UArray Int Int) runFibmIOUA n = do (r, arr) <- runUArrayMemo (fibm n) (0,n) iarr <- freeze arr return (r, iarr) evalFibmSTUA :: Int -> Int evalFibmSTUA n = runST $ evalUArrayMemo (fibm n) (0,n) runFibmSTUA :: Int -> (Int, UArray Int Int) runFibmSTUA n = runST $ do (a,arr) <- runUArrayMemo (fibm n) (0,n) iarr <- freeze arr return (a,iarr) evalFibmSTV :: Int -> Integer evalFibmSTV n = runST $ evalVectorMemo (fibm n) (n+1) evalFibmIOV :: Int -> IO Integer evalFibmIOV n = evalVectorMemo (fibm n) (n+1) evalFibmSTUV :: Int -> Int evalFibmSTUV n = runST $ evalUVectorMemo (fibm n) (n+1) runFibmSTUV :: Int -> (Int, UV.Vector Int) runFibmSTUV n = runST $ do (a,vec) <- runUVectorMemo (fibm n) (n+1) ivec <- UV.freeze vec return (a,ivec) evalFibmIOUV :: Int -> IO Int evalFibmIOUV n = evalUVectorMemo (fibm n) (n+1) runFibmIOUV :: Int -> IO (Int, UV.Vector Int) runFibmIOUV n = do (a, vec) <- runUVectorMemo (fibm n) (n+1) ivec <- UV.freeze vec return (a, ivec) evalFibmSTEV :: Int -> Integer evalFibmSTEV n = runST $ EV.startEvalVectorMemo (fibm n) evalFibmIOEV :: Int -> IO Integer evalFibmIOEV n = EV.startEvalVectorMemo (fibm n) evalFibmSTEUV :: Int -> Int evalFibmSTEUV n = runST $ EV.startEvalUVectorMemo (fibm n) runFibmSTEUV :: Int -> (Int, UV.Vector Int) runFibmSTEUV n = runST $ do (a,vec) <- EV.startRunUVectorMemo (fibm n) ivec <- UV.freeze vec return (a,ivec) evalFibmIOEUV :: Int -> IO Int evalFibmIOEUV n = EV.startEvalUVectorMemo (fibm n) runFibmIOEUV :: Int -> IO (Int, UV.Vector Int) runFibmIOEUV n = do (a, vec) <- EV.startRunUVectorMemo (fibm n) ivec <- UV.freeze vec return (a, ivec)monad-memo-0.5.4/example/Customisation/Array.hs0000644000000000000000000000410014164705676017660 0ustar0000000000000000{- | Module : Sample.Memo Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable More advanced examples -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeSynonymInstances #-} module Example.Customisation.Array ( -- * Custom `ArrayMemo` -- $UnboxedInt16TupleArray Int16Sum, evalFibSTUA, runFibSTUA, evalFibIOUA, runFibIOUA ) where import Data.Ix import Data.Int import Data.Array.MArray (MArray, freeze) import qualified Data.Array.Unboxed as UA import Control.Monad.ST import Control.Monad.Writer import Data.MaybeLike import Control.Monad.Memo.Class import Control.Monad.Memo.Array fibmw 0 = return 0 fibmw 1 = return 1 fibmw n = do f1 <- memo fibmw (n-1) f2 <- memo fibmw (n-2) tell $ Sum 1 return (f1+f2) {- $UnboxedInt16TupleArray The way to memoize a tuple of Int16 values using unboxed `UArrayCache` -} -- | A tuple of unboxed `Int16` and `Sum` of it type Int16Sum = (Int16,Sum Int16) -- | `MaybeLike` instance for our tuple instance MaybeLike Int32 Int16Sum where nothing = minBound isNothing v = v == minBound just (a,Sum b) = fromIntegral a * 2^16 + fromIntegral b fromJust v = let (a,b) = v `divMod` (2^16) in (fromIntegral a, Sum (fromIntegral b)) -- | `UArrayMemo` instance for our tuple -- Now we can use `evalUArrayMemo` and `runUArrayMemo` methods instance UArrayMemo Int16Sum Int32 evalFibSTUA :: Int -> Int16Sum evalFibSTUA n = runST $ evalUArrayMemo (runWriterT (fibmw n)) (0,n) runFibSTUA :: Int -> (Int16Sum, UA.UArray Int Int32) runFibSTUA n = runST $ do (a,arr) <- runUArrayMemo (runWriterT (fibmw n)) (0,n) iarr <- freeze arr return (a, iarr) evalFibIOUA :: Int -> IO Int16Sum evalFibIOUA n = (`evalUArrayMemo`(0,n)) . runWriterT . fibmw $ n runFibIOUA :: Int -> IO (Int16Sum, UA.UArray Int Int32) runFibIOUA n = do (a,arr) <- runUArrayMemo (runWriterT (fibmw n)) (0,n) iarr <- freeze arr return (a, iarr) monad-memo-0.5.4/example/Customisation/Vector.hs0000644000000000000000000000502214164705676020050 0ustar0000000000000000{- | Module : Sample.Memo Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable More advanced examples -} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, TypeSynonymInstances #-} module Example.Customisation.Vector ( -- * Custom `VectorMemo` -- $UnboxedTupleVector BoolInt, evalFibSTUV, runFibSTUV, evalFibIOUV, runFibIOUV ) where import Control.Monad import Control.Monad.ST import Control.Monad.Primitive import qualified Data.Vector.Unboxed as UV import qualified Data.Vector.Unboxed.Mutable as UM import Data.MaybeLike import Control.Monad.Memo.Class import Control.Monad.Trans.Memo.ReaderCache import Control.Monad.Memo.Vector fibm 0 = return 0 fibm 1 = return 1 fibm n = liftM2 (+) (memo fibm (n-1)) (memo fibm (n-2)) {- $UnboxedTupleVector New custom types, not handled by "Control.Monad.Trans.Memo.Vector.Instances", can be used inside `VectorCache` if necessary. For example if we need a full range of `Int` (including `minBound` and `maxBound`) we can represent `Maybelike` `Int` as a pair @(Bool,Int)@ with `nothing` indicated by the @False@ value of its first element. `Data.Vector.Unboxed.Mutable.MVector` can store such pair efficiently (internally as a pair of unboxed arrays) so all we have to do then is to define `MaybeLike` and `VectorMemo` instances for our product-type. -} -- | Unboxed `Int` which can memoize entire range of `Int` values -- by indicating `nothing` values by setting its first element to @False@ type BoolInt = (Bool,Int) -- | MaybeLike instance for our unboxed Int instance MaybeLike BoolInt Int where nothing = (False,0) isNothing (b,_) = not b just a = (True,a) fromJust (True,a) = a -- | UVectorMemo instance will allow us to use all @eval*@ and @run*@ functions -- from unboxed part of "Control.Monad.Trans.Memo.Vector" module instance UVectorMemo Int BoolInt -- | Use standard function once we defined the instance for `VectorMemo` evalFibSTUV :: Int -> Int evalFibSTUV n = runST $ evalUVectorMemo (fibm n) (n+1) runFibSTUV :: Int -> (Int, UV.Vector (Bool,Int)) runFibSTUV n = runST $ do (a,vec) <- runUVectorMemo (fibm n) (n+1) ivec <- UV.unsafeFreeze vec return (a, ivec) evalFibIOUV :: Int -> IO Int evalFibIOUV n = evalUVectorMemo (fibm n) (n+1) runFibIOUV :: Int -> IO (Int, UV.Vector (Bool,Int)) runFibIOUV n = do (a, vec) <- runUVectorMemo (fibm n) (n+1) ivec <- UV.unsafeFreeze vec return (a, ivec) monad-memo-0.5.4/example/Customisation/MaybeLike.hs0000644000000000000000000000350214164705676020451 0ustar0000000000000000{- | Module : Sample.Memo Copyright : (c) Eduard Sergeev 2013 License : BSD-style (see the file LICENSE) Maintainer : eduard.sergeev@gmail.com Stability : experimental Portability : non-portable More advanced examples -} {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-} module Example.Customisation.MaybeLike ( -- * Customised `MaybeLike` -- $MaybeLike runFibSTUA, ) where import Data.Array.MArray import qualified Data.Array.Unboxed as UA import Control.Monad import Control.Monad.ST import Data.MaybeLike import Control.Monad.Memo.Class import Control.Monad.Memo.Array.Instances fibm 0 = return 0 fibm 1 = return 1 fibm n = do f1 <- memo fibm (n-1) f2 <- memo fibm (n-2) return (f1+f2) {- $MaybeLike Default implementation of `ArrayCache` and `VectorCache` uses `minBound` for `Bounded` types and `NaN` for `RealFloat` types as "null" value (i.e. missing result in memo-cache). However it is possible to override these default settings. To do that we have to exclude default definitions from "Control.Monad.Memo" (and manualy import all relevant modules like in this example). Then we just need to implement `MaybeLike` instance for our type after which we can use all existing methods of running `ArrayCache` or `VectorCache`. -} -- | Our customised version of `MaybeLike` for Double with @`nothing` == (-1)@ -- to be used with any unboxed `ArrayCache` instance MaybeLike Double Double where nothing = -1 isNothing = (<0) just v = v fromJust v = v evalFibSTUA :: Int -> Double evalFibSTUA n = runST $ evalUArrayMemo (fibm n) (0,n) -- | This also produces resulting array runFibSTUA :: Int -> (Double, UA.UArray Int Double) runFibSTUA n = runST $ do (a,arr) <- runUArrayMemo (fibm n) (0,n) iarr <- freeze arr return (a,iarr)