monad-memo 0.1.1 → 0.2.0

raw patch · 6 files changed

+436/−61 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Monad/Memo.hs +44/−17
• Control/Monad/Memo/Class.hs +47/−7
• Control/Monad/Memo/Example.hs +79/−29
• Control/Monad/Memo/Test.hs +250/−0
• Tests.hs +8/−0
• monad-memo.cabal +8/−8

@@ -29,8 +29,11 @@     startRunMemoT,     startEvalMemoT,     module Control.Monad,-    module Control.Monad.Fix,     module Control.Monad.Trans,+    -- * Adapter for memoization of multi-argument functions+    for2,+    for3,+    for4,     -- * Memoization cache level access functions              memoln,     memol0,@@ -46,6 +49,9 @@      -- * Example 3: Combining Memo with other transformers     -- $transExample++    -- * Example 4: Memoization of multi-argument function+    -- $multiExample     ) where  import Control.Monad.Memo.Class@@ -54,9 +60,8 @@     MemoT(..), runMemoT, startRunMemoT, evalMemoT, startEvalMemoT,     Memo, runMemo, startRunMemo, evalMemo, startEvalMemo ) -import Control.Monad.Trans import Control.Monad-import Control.Monad.Fix+import Control.Monad.Trans  {- $fibExample Memoization can be specified whenever monadic computation is taking place.@@ -84,8 +89,8 @@ >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = do->  n1 <- fibm `memo` (n-1)->  n2 <- fibm `memo` (n-2)+>  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@@ -113,19 +118,19 @@ >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->  fn <- fibm2 `memol0` floor (n-1)   -- uses current transformer (memol_0_): MemoFib+>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 = "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)        -- and 0st (the current) for fibm2->  f2 <- fibm2 `memol0` (n-2)+>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 = startEvalMemo . startEvalMemoT . fibm2@@ -141,8 +146,8 @@ >fibmw 0 = return 0 >fibmw 1 = return 1 >fibmw n = do->  f1 <- fibmw `memo` (n-1)->  f2 <- fibmw `memo` (n-2)+>  f1 <- memo fibmw (n-1)+>  f2 <- memo fibmw (n-2) >  tell $ show n >  return (f1+f2) @@ -150,3 +155,25 @@  -} +{- $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 :: 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++-}

@@ -13,7 +13,7 @@  {-# LANGUAGE NoImplicitPrelude, TupleSections,   MultiParamTypeClasses, FunctionalDependencies,-  UndecidableInstances, FlexibleInstances, RankNTypes #-}+  UndecidableInstances, FlexibleInstances, FlexibleContexts, RankNTypes #-}   module Control.Monad.Memo.Class@@ -22,12 +22,16 @@       MonadCache(..),       MonadMemo(..), +      for2,+      for3,+      for4,+       memoln,       memol0,       memol1,       memol2,       memol3,-      memol4+      memol4,  ) where @@ -50,6 +54,9 @@ import Control.Monad.Trans.Writer.Strict as Strict  +import Control.Arrow+import Prelude (undefined)+ class Monad m => MonadCache k v m | m -> k, m -> v where     lookup :: k -> m (Maybe v)     add :: k -> v -> m ()@@ -69,11 +76,45 @@                 fl $ add (fk k) r                 return r +memoln2 :: (MonadCache k v m1, Monad m1, Monad m2) =>+           (forall a.m1 a -> m2 a) -> (k -> m2 v) -> k -> m2 v+memoln2 fl f k = do+  mr <- fl $ lookup k+  case mr of+    Just r -> return r+    Nothing -> do+                r <- f k+                fl $ add k r+                return r++memov2 f k = do+  mr <- lookup k+  case mr of+    Just r -> return r+    Nothing -> do+                r <- f k+                add 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 a b = m (\(a,b) -> f a b) (a,b)++-- | 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 memol0     :: (MonadCache k v m, Monad m) =>        (k -> m v) -> k -> m v-memol0 = memoln id id+memol0 = memoln2 id   -- | Uses the 1st transformer in stack for memoization cache@@ -82,7 +123,7 @@         MonadCache k v m,         Monad (t1 m)) =>        (k -> t1 m v) -> k -> t1 m v-memol1 = memoln lift id+memol1 = memoln2 lift   -- | Uses the 2nd transformer in stack for memoization cache@@ -124,7 +165,6 @@ memol4 = memoln (lift.lift.lift.lift) id  - instance (MonadCache k v m) => MonadMemo k v (IdentityT m) where     memo f = IdentityT . memol0 (runIdentityT . f) @@ -134,8 +174,8 @@ 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 (MonadCache k [v] m) => MonadMemo k v (ListT m) where+    memo f = ListT . memol0 (runListT . f)  instance (Error e, MonadCache k  (Either e v) m) => MonadMemo k v (ErrorT e m) where     memo f = ErrorT . memol0 (runErrorT . f)

@@ -70,6 +70,10 @@          ackm,          evalAckm, +         -- * Levensthein distance +         editDistance,+         editDistancem,+ ) where  import Control.Monad.Memo.Class@@ -80,17 +84,18 @@ import Control.Monad.Reader import Control.Monad.Writer +import Control.Applicative+ 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)+  n1 <- memo fibm (n-1)+  n2 <- memo fibm (n-2)   return (n1+n2)  evalFibm :: Integer -> Integer@@ -122,8 +127,8 @@ 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+  t <- memo unfringem l+  u <- memo unfringem k   return (Fork t u)  evalUnfringem :: (Ord t, Show t) => [t] -> [Tree t]@@ -152,15 +157,15 @@ fm :: Int -> MemoFG (Int,String) fm 0 = return (1,"+") fm n = do-  fn <- fm `memol0` (n-1)-  gn <- gm `memol1` ((n-1) , fst fn)+  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 <- fm `memol0` (n-1)-  gn <- gm `memol1` ((n-1),m)+  fn <- memol0 fm (n-1)+  gn <- memol1 gm ((n-1),m)   return $ fst fn - gn  evalAll = startEvalMemo . startEvalMemoT@@ -174,9 +179,32 @@ 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@@ -210,8 +238,8 @@ 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)+  f1 <- memo fibmw (n-1)+  f2 <- memo fibmw (n-2)   tell $ show n   return (f1+f2) @@ -226,9 +254,9 @@ 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)+  f1 <- memo fibmc (n-1)   f2 <- callCC $ \ break -> do-          if n == 4 then break 42 else fibmc `memo` (n-2)+          if n == 4 then break 42 else memo fibmc (n-2)   return (f1+f2)  evalFibmc :: Integer -> Integer@@ -243,9 +271,9 @@ 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)+  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@@ -267,8 +295,8 @@ 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)+  n1 <- memo fibmi (n-1)+  n2 <- memo fibmi (n-2)   let r = n1+n2   print r >> return r @@ -277,20 +305,42 @@   -- Ackerman function-ack :: Integer -> Integer -> Integer+ack :: 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 :: (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)+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 :: Integer -> Integer -> Integer-evalAckm n m = startEvalMemo $ ackm (n,m)+evalAckm :: (Num n, Ord n) => n -> n -> n+evalAckm n m = startEvalMemo $ ackm n m -runAckm n m = startRunMemo $ ackm (n,m)+runAckm n m = startRunMemo $ ackm n m+++-- | 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

@@ -0,0 +1,250 @@+{-# LANGUAGE FlexibleInstances #-}++module Control.Monad.Memo.Test+(+       tests+) 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++import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++++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)) $ 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 -> 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 <- 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)++++-- | 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 <- memo fibms (n-1)+  f2 <- memo fibms (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 <- memo unfringem l+  u <- memo unfringem 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 =(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 = evalAll . fm2+evalGm2 n m = evalAll $ 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+++++tests = [+        testGroup "Transformers" [+                       testProperty "ReaderEqv"  prop_ReaderEqv,+                       testProperty "WriterEqv"  prop_WriterEqv,+                       testProperty "ContEqv"    prop_ContEqv,+                       testProperty "ListEqv"    prop_ListEqv,+                       testProperty "StateEqv"   prop_StateEqv+                      ],+        testGroup "Others" [+                       testProperty "MutualFGEqv"       prop_MutualFEqv,+                       testProperty "MutualCurryFGEqv"  prop_Mutual2FEqv+                       ]+    ]

@@ -0,0 +1,8 @@++module Main where++import Control.Monad.Memo.Test+import Test.Framework (defaultMain)+++main = defaultMain tests

@@ -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.1+Version:             0.2.0  -- A short (one-line) description of the package. Synopsis:            Memoization monad transformer@@ -38,14 +38,14 @@ -- Constraint on the version of Cabal needed to build this package. Cabal-version:       >=1.10 +Extra-source-files:+	Tests.hs,+	Control/Monad/Memo/Test.hs+ 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- Flag examples   description: Builds examples   default:     False@@ -66,12 +66,11 @@    if flag(examples)      exposed-modules: Control.Monad.Memo.Example-    Test-Suite tests   default-language:	Haskell2010-  type: exitcode-stdio-1.0-  main-is: Tests.hs+  type:			exitcode-stdio-1.0+  main-is:		Tests.hs   build-depends:       base >= 3.0 && < 5,      mtl >= 2.0,@@ -81,3 +80,4 @@      QuickCheck >= 2.0,      test-framework-quickcheck2 >= 0.2.9,      test-framework >= 0.3.3+  other-modules:	Control.Monad.Memo.Test