monad-memo 0.1.0 → 0.1.1
raw patch · 7 files changed
+334/−513 lines, 7 filesdep +test-frameworkdep +test-framework-quickcheck2setup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: test-framework, test-framework-quickcheck2
API changes (from Hackage documentation)
Files
- Control/Monad/Memo.hs +9/−8
- Control/Monad/Memo/Class.hs +1/−0
- Control/Monad/Memo/Example.hs +296/−0
- Control/Monad/Memo/Example/Main.hs +0/−271
- Control/Monad/Memo/Test/Main.hs +0/−209
- Setup.hs +1/−6
- monad-memo.cabal +27/−19
Control/Monad/Memo.hs view
@@ -115,17 +115,17 @@ >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)+> n1 <- boo `memol1` (n-1) -- uses next in stack transformer (memol_1_): MemoBoo is nested in MemoFib+> fn <- fibm2 `memol0` floor (n-1) -- uses current transformer (memol_0_): MemoFib+> 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 -- 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) --+> l <- boo `memol1` fromInteger n -- as in 'boo' we need to use 1st nested transformer here+> f1 <- fibm2 `memol0` (n-1) -- and 0st (the current) for fibm2+> f2 <- fibm2 `memol0` (n-2) > return (f1 + f2 + floor (read l)) >evalFibM2 = startEvalMemo . startEvalMemoT . fibm2@@ -133,10 +133,11 @@ -} {- $transExample-Being transformer, @MemoT@ can be used with other monads and transformers:+'MonadMemo' can be combined with other monads and transformers: -With @Writer@:+With 'MonadWriter': +>fibmw :: (Num n, MonadWriter String m, MonadMemo n n m) => n -> m n >fibmw 0 = return 0 >fibmw 1 = return 1 >fibmw n = do
Control/Monad/Memo/Class.hs view
@@ -120,6 +120,7 @@ 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 :: (MonadTrans t4, MonadCache k v 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
+ Control/Monad/Memo/Example.hs view
@@ -0,0 +1,296 @@+{- |+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 FlexibleContexts #-}++module Control.Monad.Memo.Example+ (+ -- * 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 :: (Num n, MonadMemo n n m) => n -> m 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 = (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 <- fm `memol0` (n-1)+ gn <- gm `memol1` ((n-1) , fst fn)+ return (gn , "-" ++ snd fn)++gm :: (Int,Int) -> MemoFG Int+gm (0,m) = return (m+1) +gm (n,m) = do+ fn <- fm `memol0` (n-1)+ gn <- gm `memol1` ((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++++++--+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 :: (Num n, MonadWriter String m, MonadMemo n n m) => n -> m n+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 `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++++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 <- fibmi `memo` (n-1)+ n2 <- fibmi `memo` (n-2)+ let r = n1+n2+ print r >> return r++++++-- 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 :: (Num n, Ord n, MonadMemo (n, n) n m) => (n, n) -> m n+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/Example/Main.hs
@@ -1,271 +0,0 @@-{- |-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
@@ -1,209 +0,0 @@-{-# 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
Setup.hs view
@@ -1,7 +1,2 @@ import Distribution.Simple-import Test.Main---main = defaultMainWithHooks simpleUserHooks { runTests = runt }--runt _ _ _ _ = run+main = defaultMain
monad-memo.cabal view
@@ -4,7 +4,7 @@ -- 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+Version: 0.1.1 -- A short (one-line) description of the package. Synopsis: Memoization monad transformer@@ -29,8 +29,6 @@ -- and patches. Maintainer: Eduard.Sergeev@gmail.com --- A copyright notice.--- Copyright: Category: Control @@ -38,38 +36,48 @@ -- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.2+Cabal-version: >=1.10 +source-repository head+ type: svn+ location: http://monad-memo.googlecode.com/svn/trunk/ Flag test-suite- Description: Enable QuickCheck test suite run once package is built- Default: False+ description: Enable QuickCheck test suite run once package is built+ default: False Flag examples- Description: Builds examples- Default: False+ description: Builds examples+ default: False Library- -- Modules exported by the library.- Exposed-modules:+ default-language: Haskell2010+ build-depends:+ base >= 3.0 && < 5,+ mtl >= 2.0,+ transformers >= 0.2,+ containers >= 0.3++ 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+ exposed-modules: Control.Monad.Memo.Example - -- Packages needed in order to build this package.- Build-depends:++Test-Suite tests+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ build-depends: base >= 3.0 && < 5, mtl >= 2.0, transformers >= 0.2,- containers >= 0.3,- random >= 1.0,- QuickCheck >= 2.0 - + QuickCheck >= 2.0,+ test-framework-quickcheck2 >= 0.2.9,+ test-framework >= 0.3.3