packages feed

monad-memo (empty) → 0.1.0

raw patch · 8 files changed

+1007/−0 lines, 8 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, mtl, random, transformers

Files

+ Control/Monad/Memo.hs view
@@ -0,0 +1,151 @@+{- |+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)++[Computation type:] Monadic computations with support for memoization.++Defines monadic interface 'MonadMemo' for memoization and simple implementation 'MemoT' (based on 'Data.Map')+-}+++module Control.Monad.Memo (+    -- * MonadMemo class+    MonadMemo(..),+    -- * The Memo monad+    Memo,+    runMemo,+    evalMemo,+    startRunMemo,+    startEvalMemo,+    -- * The MemoT monad transformer+    MemoT(..),+    runMemoT,+    evalMemoT,+    startRunMemoT,+    startEvalMemoT,+    module Control.Monad,+    module Control.Monad.Fix,+    module Control.Monad.Trans,+    -- * 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+    ) where++import Control.Monad.Memo.Class++import Control.Monad.Trans.Memo.Strict (+    MemoT(..), runMemoT, startRunMemoT, evalMemoT, startEvalMemoT,+    Memo, runMemo, startRunMemo, evalMemo, startEvalMemo )++import Control.Monad.Trans+import Control.Monad+import Control.Monad.Fix++{- $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 :: (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 :: (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 :: (Num n, Ord n) => n -> Memo n n n+>fibm 0 = return 0+>fibm 1 = return 1+>fibm n = do+>  n1 <- fibm `memo` (n-1)+>  n2 <- fibm `memo` (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 $ 5++-}++{- $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 = "boo: 0" `trace` return ""+>boo n = ("boo: " ++ show n) `trace` do+>  n1 <- boo `memol1` (n-1)         -- uses next in stack transformer (memol_1_): MemoBoo is nested in MemoFib+>  f <- fibm2 `memol0` floor (n-1)  -- uses current transformer (memol_0_): MemoFib+>  return (show n ++ show f)++>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  -- as in 'boo' we need to use 1st nested transformer here+>  f1 <- fibm2 `memol0` (n-1)       -- as in 'boo' we need to use 1st nested transformer here+>  f2 <- fibm2 `memol0` (n-2)       --+>  return (f1 + f2 + floor (read l))++>evalFibM2 = startEvalMemo . startEvalMemoT . fibm2++-}++{- $transExample+Being transformer, @MemoT@ can be used with other monads and transformers:++With @Writer@:++>fibmw 0 = return 0+>fibmw 1 = return 1+>fibmw n = do+>  f1 <- fibmw `memo` (n-1)+>  f2 <- fibmw `memo` (n-2)+>  tell $ show n+>  return (f1+f2)++>evalFibmw = startEvalMemo . runWriterT . fibmw++-}+
+ Control/Monad/Memo/Class.hs view
@@ -0,0 +1,162 @@+{- |+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, RankNTypes #-}+++module Control.Monad.Memo.Class+(++      MonadCache(..),+      MonadMemo(..),++      memoln,+      memol0,+      memol1,+      memol2,+      memol3,+      memol4++) where++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.Error+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy -- (StateT, get, put)+import qualified Control.Monad.Trans.State.Strict as Strict -- (StateT, get, put)+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict+++class Monad m => MonadCache k v m | m -> k, m -> v where+    lookup :: k -> m (Maybe v)+    add :: k -> v -> m ()++class Monad m => MonadMemo k v m | m -> k, m -> v where+    memo :: (k -> m v) -> k -> m v+++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++-- | Uses current monad's memoization cache+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+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+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+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+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 (MonadMemo k [v] m) => MonadMemo k v (ListT m) where+    memo f = ListT . memo (runListT . f)++instance (Error e, MonadCache k  (Either e v) m) => MonadMemo k v (ErrorT e m) where+    memo f = ErrorT . memol0 (runErrorT . f)++instance (MonadCache (r,k) v m) => MonadMemo k v (ReaderT r m) where+    memo f k = do+      e <- ask+      memoln lift (e,) f k++instance (Monoid w, MonadCache k (v,w) m) => MonadMemo k v (Lazy.WriterT w m) where+    memo f = Lazy.WriterT . memol0 (Lazy.runWriterT . f)++instance (Monoid w, MonadCache k (v,w) m) => MonadMemo k v (Strict.WriterT w m) where+    memo f = Strict.WriterT . memol0 (Strict.runWriterT . f)+++instance (MonadCache (s,k) v m) => MonadMemo k v (Lazy.StateT s m) where+    memo f k = do+      s <- Lazy.get+      memoln lift (s,) f k++instance (MonadCache (s,k) v m) => MonadMemo k v (Strict.StateT s m) where+    memo f k = do+      s <- Strict.get+      memoln lift (s,) f k
+ Control/Monad/Memo/Example/Main.hs view
@@ -0,0 +1,271 @@+{- |+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)++Samples of usage of MemoT++-}++{-# LANGUAGE NoMonomorphismRestriction #-}++module Control.Monad.Memo.Example.Main+    (+         -- * Memoized Fibonacci number function+         fibm,+         evalFibm,++         -- * Combining ListT and MemoT transformers +         -- | Original sample is taken from: \"Monadic Memoization Mixins\" by Daniel Brown and William R. Cook <http://www.cs.utexas.edu/~wcook/Drafts/2006/MemoMixins.pdf>++         -- ***    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 <http://www.cs.utexas.edu/~wcook/Drafts/2006/MemoMixins.pdf>++         -- ***    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,++) where++import Control.Monad.Memo.Class+import Control.Monad.Trans.Memo.Strict+import Control.Monad.Identity+import Control.Monad.List+import Control.Monad.Cont+import Control.Monad.Reader+import Control.Monad.Writer++import Debug.Trace++++fibm :: (Ord n, Num n) => n -> Memo n n n+fibm 0 = return 0+fibm 1 = return 1+fibm n = do+  n1 <- fibm `memo` (n-1)+  n2 <- fibm `memo` (n-2)+  return (n1+n2)++evalFibm :: Integer -> Integer+evalFibm = startEvalMemo . fibm+++--+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 <- unfringem `memo` l+  u <- unfringem `memo` 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+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)++-- | 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+1) = do+  fn <- fm `memol0` n+  gn <- gm `memol1` (n , fst fn)+  return (gn , "-" ++ snd fn)++gm :: (Int,Int) -> MemoFG Int+gm (0,m) = return (m+1) +gm (n+1,m) = do+  fn <- fm `memol0` n+  gn <- gm `memol1` (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++++--+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+++++-- | Here we use monomorphic type+fibmw :: Integer -> WriterT String (Memo Integer (Integer,String)) Integer+fibmw 0 = "fib: 0" `trace` return 0+fibmw 1 = "fib: 1" `trace` return 1+fibmw n = ("fib: " ++ show n) `trace` do+  f1 <- fibmw `memo` (n-1)+  f2 <- fibmw `memo` (n-2)+  tell $ show n+  return (f1+f2)++evalFibmw :: Integer -> (Integer, String)+evalFibmw = startEvalMemo . runWriterT . fibmw++runFibmw = startRunMemo . runWriterT . fibmw+++-- | Can also be defined with polymorphic monad classes+fibmc :: (Num t, Num b, MonadCont m, MonadMemo t b m) => t -> m b+fibmc 0 = "fib: 0" `trace` return 0+fibmc 1 = "fib: 1" `trace` return 1+fibmc n = ("fib: " ++ show n) `trace` do+  f1 <- fibmc `memo` (n-1)+  f2 <- callCC $ \ break -> do+          if n == 4 then break 42 else fibmc `memo` (n-2)+  return (f1+f2)++evalFibmc :: Integer -> Integer+evalFibmc = startEvalMemo . (`runContT`return) . fibmc++runFibmc = startRunMemo . (`runContT`return) . fibmc+++fibmr :: (Num t, Num a, MonadMemo t a m, MonadReader a m) => t -> m a+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) $ fibmr `memo` (n-2)          +  f1 <- fibmr `memo` (n-1)+  f2 <- fibmr `memo` (n-2)+  return (p1+f1+f2+p2)++evalFibmr :: Integer -> Integer -> Integer+evalFibmr r = startEvalMemo . (`runReaderT` r) . fibmr++runFibmr r = startRunMemo . (`runReaderT` r) . fibmr+++++-- Ackerman function+ack :: Integer -> Integer -> Integer+ack 0 n = n+1+ack m 0 = ack (m-1) 1+ack m n = ack (m-1) (ack m (n-1))++ackm :: (Integer,Integer) -> Memo (Integer,Integer) Integer Integer+ackm (0,n) = return (n+1)+ackm (m,0) = ackm `memo` ((m-1),1)+ackm (m,n) = do+  n1 <- ackm `memo` (m,(n-1))+  ackm `memo` ((m-1),n1)++evalAckm :: Integer -> Integer -> Integer+evalAckm n m = startEvalMemo $ ackm (n,m)++runAckm n m = startRunMemo $ ackm (n,m)
+ Control/Monad/Memo/Test/Main.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE FlexibleInstances #-}++module Control.Monad.Memo.Test.Main+(+       run+) where++import Test.QuickCheck+import System.Random++import Control.Monad.Memo+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Control.Monad.Cont+import Control.Monad.List+++newtype SmallInt n = SmallInt { toInt::n } deriving Show++instance (Num n, Random n) => Arbitrary (SmallInt n) where+    arbitrary = fmap SmallInt $ choose (0,10)++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 +++-- | 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)) $ fibmr `memo` (n-2)          +  f1 <- fibmr `memo` (n-1)+  f2 <- fibmr `memo` (n-2)+  return (p1+f1+f2+p2)++runFibmr r = startEvalMemo . (`runReaderT`r) . fibmr++prop_ReaderEqv :: SmallInt Int -> SmallInt Int -> Bool+prop_ReaderEqv r n =+    ((`runReader`(toInt r)) . fibr  $ (toInt n)) == (startEvalMemo . (`runReaderT`(toInt r)) . fibmr $ (toInt 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 <- fibmw `memo` (n-1)+  f2 <- fibmw `memo` (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 <- fibmc `memo` (n-1)+  f2 <- callCC $ \ break -> do+          if n == 4 then break 42 else fibmc `memo` (n-2)+  return (f1+f2)++prop_ContEqv :: SmallInt Int -> Bool+prop_ContEqv n =+    ((`runCont`id) . fibc . toInt $ n) == (startEvalMemo . (`runContT`return) . fibmc . toInt $ 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 $ \s -> s+1+  return (f1+f2+s)++fibms 0 = return 0+fibms 1 = return 1+fibms n = do+  s <- get+  f1 <- fibms `memo` (n-1)+  f2 <- fibms `memo` (n-2)+  modify $ \s -> s+1+  return (f1+f2+s)++prop_StateEqv :: SmallInt Int -> SmallInt Int -> Bool+prop_StateEqv s n =+    ((`runState`(toInt s)) . fibs . toInt $ n) == (startEvalMemo . (`runStateT`(toInt s)) . fibms . toInt $ n)+++++-- | With ListT+--+data Tree a = Leaf !a | Fork (Tree a) (Tree a) deriving Eq++partitions as = [ splitAt n as | n <- [1..length as - 1 ]]++unfringe [a] = [Leaf a]+unfringe as  = do+  (l,k) <- partitions as+  t <- unfringe l+  u <- unfringe k+  return (Fork t u)++unfringem [a] = return (Leaf a)+unfringem as = do+  (l,k) <- ListT $ return (partitions as)+  t <- unfringem `memo` l+  u <- unfringem `memo` k+  return (Fork t u)++prop_ListEqv :: SmallList Char -> Bool+prop_ListEqv ls =+    unfringe (toList ls) == (startEvalMemo . runListT . unfringem $ (toList ls))+++-- | Mutual recursion+f :: Int -> (Int,String)+f 0 = (1,"+")+f (n+1)	=(g(n,fst(f n)),"-" ++ snd(f n))+g :: (Int, Int) -> Int+g (0, m)  = m + 1+g (n+1,m) = fst(f n)-g(n,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+1) = do+  fn <- fm `memol0` n+  g <- gm `memol1` (n , fst fn)+  return (g , "-" ++ snd fn)++gm :: (Int,Int) -> MemoFG Int+gm (0,m) = return (m+1) +gm (n+1,m) = do+  fn <- fm `memol0` n+  g <- gm `memol1` (n,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++++run :: IO ()+run = do+  quickCheck prop_ReaderEqv+  quickCheck prop_WriterEqv+  quickCheck prop_ContEqv+  quickCheck prop_StateEqv+  quickCheck prop_ListEqv+  quickCheck prop_MutualFEqv
+ Control/Monad/Trans/Memo/Strict.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction,+MultiParamTypeClasses, FlexibleInstances #-}++module Control.Monad.Trans.Memo.Strict+(+ +MemoT(..),+runMemoT,+startRunMemoT,+evalMemoT,+startEvalMemoT,++Memo,+runMemo,+startRunMemo,+evalMemo,+startEvalMemo,++) where+++import Data.Tuple+import Data.Ord+import Data.Function+import Control.Applicative+import Control.Monad.State.Strict+import Control.Monad.Identity+import qualified Data.Map as M ++import Control.Monad.Memo.Class++++newtype MemoT k v m a = MemoT { toStateT :: StateT (M.Map k v) m a }+++runMemoT :: MemoT k v m a -> M.Map k v -> m (a, M.Map k v)+runMemoT = runStateT . toStateT++startRunMemoT :: MemoT k v m a -> m (a, M.Map k v)+startRunMemoT = (`runMemoT` M.empty)++type Memo k v = MemoT k v Identity++runMemo :: Memo k v a -> M.Map k v -> (a, M.Map k v)+runMemo m = runIdentity . runMemoT m++startRunMemo :: Memo k v a -> (a, M.Map k v)+startRunMemo = (`runMemo`M.empty)++evalMemoT :: (Monad m) => MemoT k v m a -> M.Map k v -> m a+evalMemoT m s = runMemoT m s >>= return . fst++startEvalMemoT :: (Monad m) => MemoT k v m a -> m a+startEvalMemoT = (`evalMemoT` M.empty)++evalMemo :: Memo k v a -> M.Map k v -> a+evalMemo m = runIdentity . evalMemoT m++startEvalMemo :: Memo k v a -> a+startEvalMemo = (`evalMemo`M.empty)+++++instance (Functor m) => Functor (MemoT k v m) where+    fmap f m = MemoT $ fmap f (toStateT m)++instance (Functor m, Monad m) => Applicative (MemoT k v m) where+    pure  = return +    (<*>) = ap++instance (Functor m, MonadPlus m) => Alternative (MemoT k v m) where+    empty = mzero+    (<|>) = mplus++instance (Monad m) => Monad (MemoT k v m) where+    return = MemoT . return+    m >>= k = MemoT $ (toStateT m) >>= (toStateT . k) +    m >> n = MemoT $ (toStateT m) >> (toStateT n) ++instance (MonadPlus m) => MonadPlus (MemoT k v m) where+    mzero       = MemoT mzero+    m `mplus` n = MemoT $ toStateT m `mplus` toStateT n++instance (MonadFix m) => MonadFix (MemoT k v m) where+    mfix f = MemoT $ mfix (toStateT . f)+++instance (Monad m, Ord k) => MonadCache k v (MemoT k v m) where+    lookup k = MemoT $ get >>= return . M.lookup k+    add k v  = MemoT $ modify $ \m -> M.insert k v m++instance (Monad m, Ord k) => MonadMemo k v (MemoT k v m) where+    memo = memol0+++instance (MonadIO m) => MonadIO (MemoT k v m) where+    liftIO = lift . liftIO++instance MonadTrans (MemoT k v) where+    lift = MemoT . lift
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,7 @@+import Distribution.Simple+import Test.Main+++main = defaultMainWithHooks simpleUserHooks { runTests = runt }++runt _ _ _ _ = run
+ monad-memo.cabal view
@@ -0,0 +1,75 @@+-- The name of the package.+Name:                monad-memo++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.1.0++-- A short (one-line) description of the package.+Synopsis:            Memoization monad transformer++-- A longer description of the package.+Description:        Memoization monad transformer supporting mutual recursive function definitions+		    and most of the standard monad transformers        ++-- URL for the project homepage or repository.+Homepage:         http://code.google.com/p/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++-- A copyright notice.+-- Copyright:           ++Category:            Control++Build-type:          Simple+++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.2+++Flag test-suite+  Description: Enable QuickCheck test suite run once package is built+  Default:     False++Flag examples+  Description: Builds examples+  Default:     False+++Library+  -- Modules exported by the library.+  Exposed-modules:+     Control.Monad.Memo,+     Control.Monad.Memo.Class,+     Control.Monad.Trans.Memo.Strict++  if flag(test-suite)+     Exposed-modules: Control.Monad.Memo.Test.Main+  if flag(examples)+     Exposed-modules: Control.Monad.Memo.Example.Main+  +  -- Packages needed in order to build this package.+  Build-depends:+     base >= 3.0 && < 5,+     mtl >= 2.0,+     transformers >= 0.2,++     containers >= 0.3,++     random >= 1.0,+     QuickCheck >= 2.0       +