monad-memo 0.3.0 → 0.4.0

raw patch · 29 files changed

+3191/−757 lines, 29 filesdep +arraydep +criteriondep +primitivedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: array, criterion, primitive, vector

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES +6/−0
• Control/Monad/Memo.hs +71/−10
• Control/Monad/Memo/Array.hs +188/−0
• Control/Monad/Memo/Array/Instances.hs +31/−0
• Control/Monad/Memo/Class.hs +15/−18
• Control/Monad/Memo/Example.hs +0/−359
• Control/Monad/Memo/Test.hs +0/−250
• Control/Monad/Memo/Vector.hs +179/−0
• Control/Monad/Memo/Vector/Expandable.hs +206/−0
• Control/Monad/Memo/Vector/Instances.hs +43/−0
• Control/Monad/Memo/Vector/Unsafe.hs +177/−0
• Control/Monad/Trans/Memo/Map.hs +35/−19
• Control/Monad/Trans/Memo/ReaderCache.hs +85/−0
• Control/Monad/Trans/Memo/State.hs +33/−42
• Control/Monad/Trans/Memo/StateCache.hs +105/−0
• Data/MapLike.hs +1/−1
• Data/MapLike/Instances.hs +2/−0
• Data/MaybeLike.hs +34/−0
• Data/MaybeLike/Instances.hs +176/−0
• Example/Basic.hs +555/−0
• Example/Customisation/Array.hs +88/−0
• Example/Customisation/MaybeLike.hs +64/−0
• Example/Customisation/Vector.hs +83/−0
• README.md +366/−0
• Tests.hs +0/−8
• benchmark/Main.hs +108/−0
• monad-memo.cabal +84/−50
• test/Main.hs +8/−0
• test/MemoTest.hs +448/−0

@@ -6,3 +6,9 @@ 0.3.0 - Added generalized MemoStateT transformer (to host any Data.MapLike cache-container) - MemoT is now MemoStateT instantiated with Data.Map++0.4.0+- ArrayCache: mutable array-based MonadCache for top performance+- VectorCache (and flavours) vector-based MonadCache for even better performance+- Bug fixes in transformer implementations (Reader, State, RWS)+- Simple benchmark included

@@ -17,10 +17,11 @@     module Control.Monad,     module Control.Monad.Trans,     module Data.MapLike,+    module Data.MaybeLike,     -- * MonadMemo class     MonadMemo(..),     -- * Generalized Memo monad-    MemoState(..),+    MemoState,     runMemoState,     evalMemoState,     -- * Generalized MemoStateT monad transformer@@ -34,11 +35,36 @@     startRunMemo,     startEvalMemo,     -- * Map-based MemoT monad transformer-    MemoT(..),+    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,@@ -61,26 +87,30 @@      -- * 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.Strict (---    MemoT(..), runMemoT, startRunMemoT, evalMemoT, startEvalMemoT,---    Memo, runMemo, startRunMemo, evalMemo, startEvalMemo )--import Control.Monad.Trans.Memo.State -- (---    MemoT(..), runMemoT, evalMemoT,---    Memo, runMemo, evalMemo )+import Control.Monad.Trans.Memo.State  import Control.Monad.Trans.Memo.Map -import Data.MapLike+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 + {- $fibExample Memoization can be specified whenever monadic computation is taking place. Including recursive definition. Classic example: Fibonacci number function:@@ -200,5 +230,36 @@ > >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)  -}

@@ -0,0 +1,188 @@+{- |+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.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans+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++-- | 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++-- | 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)

@@ -0,0 +1,31 @@+{- |+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 #-}++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

@@ -67,6 +67,7 @@     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@@ -93,6 +94,7 @@   -- | Uses current monad's memoization cache+{-# INLINE memol0 #-} memol0     :: (MonadCache k v m, Monad m) =>        (k -> m v) -> k -> m v@@ -100,6 +102,7 @@   -- | Uses the 1st transformer in stack for memoization cache+{-# INLINE memol1 #-} memol1     :: (MonadTrans t1,         MonadCache k v m,@@ -109,6 +112,7 @@   -- | Uses the 2nd transformer in stack for memoization cache+{-# INLINE memol2 #-} memol2   :: (MonadTrans t1,       MonadTrans t2,@@ -119,6 +123,7 @@ memol2 = memoln (lift . lift) id  -- | Uses the 3rd transformer in stack for memoization cache+{-# INLINE memol3 #-} memol3   :: (MonadTrans t1,       MonadTrans t2,@@ -132,6 +137,7 @@   -- | Uses the 4th transformer in stack for memoization cache+{-# INLINE memol4 #-} memol4   :: (MonadTrans t1,       MonadTrans t2,@@ -162,9 +168,7 @@     memo f = ErrorT . memol0 (runErrorT . f)  instance (MonadCache (r,k) v m) => MonadMemo k v (ReaderT r m) where-    memo f k = do-      r <- ask-      memoln lift (r,) f k+    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)@@ -172,21 +176,14 @@ 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 m) => MonadMemo k v (SL.StateT s m) where-    memo f k = do-      s <- SL.get-      memoln lift (s,) f k+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 m) => MonadMemo k v (SS.StateT s m) where-    memo f k = do-      s <- SS.get-      memoln lift (s,) f 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,w,s,k) v m) => MonadMemo k v (RWSL.RWST r w s m) where---    memo f k = do---      r <- RWSL.ask---      s <- RWSL.get---      (_,w) <- RWSL.listen---      memoln lift (r,s,w,) f 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)   

@@ -1,359 +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 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,--         -- * Levensthein distance -         editDistance,-         editDistancem,--) where--import Control.Monad.Memo--import Control.Monad.Identity-import Control.Monad.List-import Control.Monad.Cont-import Control.Monad.Reader-import Control.Monad.Writer--import Control.Applicative--import Debug.Trace----fibm :: (Num n, MonadMemo n n m) => n -> 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---- 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------- | 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 <- memo fibmw (n-1)-  f2 <- memo fibmw (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 <- 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---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) $ 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 :: 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----- | 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

@@ -1,250 +0,0 @@-{-# 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,179 @@+{- |+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+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)

@@ -0,0 +1,206 @@+{- |+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.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans+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)

@@ -0,0 +1,43 @@+{- |+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 #-}++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

@@ -0,0 +1,177 @@+{- |+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+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)

@@ -7,20 +7,22 @@ Stability   :  experimental Portability :  non-portable (multi-param classes, functional dependencies) -MemoT as a specialization of MemoStateT with Data.Map as a container+Specialization of `MemoStateT` with `Data.Map` as a container  -} -{-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} -module Control.Monad.Trans.Memo.Map (+module Control.Monad.Trans.Memo.Map+( +   -- * MemoT monad transformer    MemoT,    runMemoT,    evalMemoT,    startRunMemoT,    startEvalMemoT,-+   -- * Memo monad    Memo,    runMemo,    evalMemo,@@ -29,42 +31,56 @@  ) where -import Data.Ord-import Data.MapLike.Instances- import Control.Monad.Identity 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 -type Memo k v = MemoT k v Identity---runMemoT :: MemoT k v m a -> M.Map k v -> m (a, M.Map 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 -runMemo :: Memo k v a -> M.Map k v -> (a, M.Map k v)-runMemo = runMemoState--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 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)

@@ -0,0 +1,85 @@+{- |+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 - similar to `Control.Monad.Trans.Reader.ReaderT` but optimised for carrying cache container++-}++{-# LANGUAGE NoImplicitPrelude, BangPatterns #-}++module Control.Monad.Trans.Memo.ReaderCache+(++  ReaderCache(..),+  container++) where++import Data.Function+import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans+++-- | Generic memoization cache which uses provided container+-- This is pretty much identical to `Control.Monad.Trans.Reader.ReaderT`,+-- but is tuned to speed up implementations which use unboxed mutable containers+newtype ReaderCache c m a = ReaderCache { evalReaderCache :: c -> m a }++-- | Returns internal container+container :: Monad m => ReaderCache c m c+{-# INLINE container #-}+container = ReaderCache $ \ !c -> return c+++instance (Functor m) => Functor (ReaderCache c m) where+    {-# INLINE fmap #-}+    fmap f m = ReaderCache $ \ !c -> fmap f (evalReaderCache m c)++instance (Applicative m) => Applicative (ReaderCache arr m) where+    {-# INLINE pure #-}+    pure a  = ReaderCache $ \_ -> pure a+    {-# INLINE (<*>) #-}+    f <*> v = ReaderCache $ \ !c -> evalReaderCache f c <*> evalReaderCache v c++instance (Alternative m) => Alternative (ReaderCache c m) where+    {-# INLINE empty #-}+    empty   = ReaderCache $ const empty+    {-# INLINE (<|>) #-}+    m <|> n = ReaderCache $ \ !c -> evalReaderCache m c <|> evalReaderCache n c++instance (Monad m) => Monad (ReaderCache c m) where+    {-# INLINE return #-}+    return a = ReaderCache $ \ !c -> return a+    {-# INLINE (>>=) #-}+    m >>= k  = ReaderCache $ \ !c -> do+        a <- evalReaderCache m c+        evalReaderCache (k a) c+    {-# INLINE (>>) #-}+    m >> k   = ReaderCache $ \ !c -> do+        evalReaderCache m c+        evalReaderCache k c++instance (MonadPlus m) => MonadPlus (ReaderCache c m) where+    {-# INLINE mzero #-}+    mzero       = lift mzero+    {-# INLINE mplus #-}+    m `mplus` n = ReaderCache $ \ !c -> evalReaderCache m c `mplus` evalReaderCache n c++instance (MonadFix m) => MonadFix (ReaderCache c m) where+    mfix f = ReaderCache $ \ !c -> mfix $ \a -> evalReaderCache (f a) c++instance MonadTrans (ReaderCache c) where+    {-# INLINE lift #-}+    lift = ReaderCache . const++instance (MonadIO m) => MonadIO (ReaderCache c m) where+    {-# INLINE liftIO #-}+    liftIO = lift . liftIO

@@ -11,87 +11,78 @@  -} -{-# LANGUAGE NoImplicitPrelude, MultiParamTypeClasses, FlexibleInstances #-}+{-# 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.Ord import Data.Function import Control.Applicative-import Control.Monad.State.Strict+import Control.Monad+import Control.Monad.Trans import Control.Monad.Identity  import qualified Data.MapLike as M import Control.Monad.Memo.Class+import Control.Monad.Trans.Memo.StateCache  --- MonadMemo and MonadCache implementation using std. 'Control.Monad.State' transformer with generic 'Data.MapLike' container for a cache-newtype MemoStateT c k v m a = MemoStateT { toStateT :: StateT c m a }+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) -runMemoStateT :: MemoStateT c k v m a -> c -> m (a, c)-runMemoStateT = runStateT . toStateT -evalMemoStateT :: (Monad m) => MemoStateT c k v m a -> c -> m a+-- | 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 (Functor m) => Functor (MemoStateT c k v m) where-    fmap f m = MemoStateT $ fmap f (toStateT m)--instance (Functor m, Monad m) => Applicative (MemoStateT c k v m) where-    pure  = return -    (<*>) = ap--instance (Functor m, MonadPlus m) => Alternative (MemoStateT l k v m) where-    empty = mzero-    (<|>) = mplus--instance (Monad m) => Monad (MemoStateT l k v m) where-    return = MemoStateT . return-    m >>= k = MemoStateT $ (toStateT m) >>= (toStateT . k) -    m >> n = MemoStateT $ (toStateT m) >> (toStateT n) --instance (MonadPlus m) => MonadPlus (MemoStateT l k v m) where-    mzero       = MemoStateT mzero-    m `mplus` n = MemoStateT $ toStateT m `mplus` toStateT n--instance (MonadFix m) => MonadFix (MemoStateT l k v m) where-    mfix f = MemoStateT $ mfix (toStateT . f)-- instance (Monad m, M.MapLike c k v) => MonadCache k v (MemoStateT c k v m) where-    lookup k = MemoStateT $ get >>= return . M.lookup k-    add k v  = MemoStateT $ modify $ \m -> M.add k v m+    {-# 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 = memol0---instance (MonadIO m) => MonadIO (MemoStateT l k v m) where-    liftIO = lift . liftIO--instance MonadTrans (MemoStateT l k v) where-    lift = MemoStateT . lift

@@ -0,0 +1,105 @@+{- |+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 - similar to `Control.Monad.Trans.State.Strict.StateT` but optimised for carrying cache container++-}++{-# LANGUAGE NoImplicitPrelude, BangPatterns #-}++module Control.Monad.Trans.Memo.StateCache+(+ +    StateCache(..),+    container,+    setContainer,+    evalStateCache++) where++import Data.Function+import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans++-- | Generic memoization cache which uses provided container which can also be updated by the computation.+-- This is pretty much identical to `Control.Monad.Trans.State.Strict.StateT`,+-- but is tuned to speed up implementations which use unboxed mutable containers+newtype StateCache c m a = StateCache { runStateCache :: c -> m (a, c) }++-- | Evaluates computation discarding the resulting container +evalStateCache :: Monad m => StateCache c m a -> c -> m a+{-# INLINE evalStateCache #-}+evalStateCache m !c = do+    (a, _) <- runStateCache m c+    return a++-- | Returns internal container+container :: Monad m => StateCache c m c+{-# INLINE container #-}+container = StateCache $ \ !c -> return (c, c)++-- | Assigns new value to internal container+setContainer :: Monad m => c -> StateCache c m ()+{-# INLINE setContainer #-}+setContainer c = StateCache $ \_ -> return ((), c)+++instance (Functor m) => Functor (StateCache c m) where+    {-# INLINE fmap #-}+    fmap f m = StateCache $ \ !c ->+        fmap (\ (a, c') -> (f a, c')) (runStateCache m c)++instance (Functor m, Monad m) => Applicative (StateCache c m) where+    {-# INLINE pure #-}+    pure = return+    {-# INLINE (<*>) #-}+    fa <*> aa = StateCache $ \ !c -> do+        (f, c') <- runStateCache fa c+        (a, c'') <- runStateCache aa c'+        return (f a, c'')+       +instance (Functor m, MonadPlus m) => Alternative (StateCache c m) where+    {-# INLINE empty #-}+    empty = mzero+    {-# INLINE (<|>) #-}+    (<|>) = mplus++instance (Monad m) => Monad (StateCache c m) where+    {-# INLINE return #-}+    return a = StateCache $ \ !c -> return (a, c)+    {-# INLINE (>>=) #-}+    m >>= k  = StateCache $ \ !c -> do+        (a, !c') <- runStateCache m c+        runStateCache (k a) c'+    {-# INLINE (>>) #-}+    m >> n   = StateCache $ \ !c -> do+        (_, !c') <- runStateCache m c+        runStateCache n c'         +    fail str = StateCache $ \_ -> fail str++instance (MonadPlus m) => MonadPlus (StateCache c m) where+    {-# INLINE mzero #-}+    mzero       = StateCache $ const mzero+    {-# INLINE mplus #-}+    m `mplus` n = StateCache $ \ !c -> runStateCache m c `mplus` runStateCache n c++instance (MonadFix m) => MonadFix (StateCache c m) where+    mfix f = StateCache $ \ !c -> mfix $ \ ~(a, _) -> runStateCache (f a) c++instance MonadTrans (StateCache c) where+    {-# INLINE lift #-}+    lift m = StateCache $ \ !c -> do+        a <- m+        return (a, c)++instance (MonadIO m) => MonadIO (StateCache c m) where+    {-# INLINE liftIO #-}+    liftIO = lift . liftIO

@@ -21,7 +21,7 @@  import Data.Maybe --- | And abstract interface to the container which can store 'v' indexed by 'k'+-- | 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

@@ -33,5 +33,7 @@  -- | 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

@@ -0,0 +1,34 @@+{- |+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

@@ -0,0 +1,176 @@+{- |+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 = v

@@ -0,0 +1,555 @@+{- |+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 <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,++         -- * 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++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)

@@ -0,0 +1,88 @@+{- |+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)+

@@ -0,0 +1,64 @@+{- |+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)

@@ -0,0 +1,83 @@+{- |+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)

@@ -0,0 +1,366 @@+## 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:++    "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+* 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)

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

@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}++module Main (main) where++import Data.Word+import qualified Data.IntMap as IM+import Control.Monad.ST+import Control.Monad.Memo+import Control.Monad.Memo.Vector.Unsafe+import Control.Monad.Memo.Vector.Expandable+import Criterion.Main+import Criterion.Config++n = 50000++main = defaultMainWith defaultConfig (return ()) [+         bgroup "fib" [+           bgroup "pure" [+             bench "Memo" $ whnf fibM n+           , bench "IntMap State" $ 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" $ fibIOA n+           , bench "UArray" $ fibIOUA n+           , bench "Vector" $ fibIOV n+           , bench "UVector" $ fibIOUV n+           , bench "Vector unsafe" $ fibIOVU n+           , bench "UVector unsafe" $ fibIOUVU n+           , bench "Vector exp" $ fibIOVE n+           , bench "UVector exp" $ fibIOUVE n+           ]+         ]+       ]+        +{-# 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)++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++fibIOUV :: Int -> IO Word+fibIOUV n = evalUVectorMemo (fibm n) n++fibSTV :: Int -> Word+fibSTV n = runST $ evalVectorMemo (fibm n) n++fibSTUV :: Int -> Word+fibSTUV n = runST $ evalUVectorMemo (fibm n) n+++fibIOVU :: Int -> IO Word+fibIOVU n = unsafeEvalVectorMemo (fibm n) n++fibIOUVU :: Int -> IO Word+fibIOUVU n = unsafeEvalUVectorMemo (fibm n) n++fibSTVU :: Int -> Word+fibSTVU n = runST $ unsafeEvalVectorMemo (fibm n) n++fibSTUVU :: Int -> Word+fibSTUVU n = runST $ unsafeEvalUVectorMemo (fibm n) n+++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)

@@ -1,87 +1,121 @@--- The name of the package.-Name:                monad-memo+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.3.0+Version:            0.4.0  -- A short (one-line) description of the package.-Synopsis:            Memoization monad transformer+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        +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   -- URL for the project homepage or repository.-Homepage:         http://code.google.com/p/monad-memo+Homepage:           https://github.com/EduardSergeev/monad-memo  -- The license under which the package is released.-License:             BSD3+License:            BSD3  -- The file containing the license text.-License-file:        LICENSE+License-file:       LICENSE  -- The package author(s).-Author:              Eduard Sergeev+Author:             Eduard Sergeev  -- An email address to which users can send suggestions, bug reports, -- and patches.-Maintainer:          Eduard.Sergeev@gmail.com-+Maintainer:         eduard.sergeev@gmail.com -Category:            Control+Category:           Control, Monad -Build-type:          Simple+Build-type:         Simple   -- Constraint on the version of Cabal needed to build this package.-Cabal-version:       >=1.10+Cabal-version:      >=1.8 +Tested-with:        GHC==7.0.4, GHC==7.4.2, GHC==7.6.2+ Extra-source-files:-	Tests.hs,-	Control/Monad/Memo/Test.hs,-	CHANGES+	  CHANGES  source-repository head-  type:		  svn-  location:	  http://monad-memo.googlecode.com/svn/trunk/+  type:             git+  location:	    https://github.com/EduardSergeev/monad-memo.git +source-repository this+  type:             git+  location:         https://github.com/EduardSergeev/monad-memo.git+  tag:              0.4.0+ Flag examples-  description: Builds examples-  default:     False+  description:      Builds examples+  default:          False   Library-  default-language:	Haskell2010   build-depends:-     base >= 3.0 && < 5,-     mtl >= 2.0,-     transformers >= 0.2,-     containers >= 0.3-+          base >= 3.0 && <= 5.0,+          mtl >= 2.0,+          transformers >= 0.2,+          containers >= 0.3,+          array >= 0.3,+          vector >= 0.7,+          primitive >= 0.3+     exposed-modules:-     Control.Monad.Memo,-     Control.Monad.Memo.Class,-     Control.Monad.Trans.Memo.State,-     Control.Monad.Trans.Memo.Map,-     Data.MapLike,-     Data.MapLike.Instances+          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    if flag(examples)-     exposed-modules: Control.Monad.Memo.Example+     exposed-modules:+          Example.Basic,+          Example.Customisation.MaybeLike,+          Example.Customisation.Array,+          Example.Customisation.Vector+  ghc-options:      -O2  Test-Suite tests-  default-language:	Haskell2010-  type:			exitcode-stdio-1.0-  main-is:		Tests.hs+  type:             exitcode-stdio-1.0+  hs-source-dirs:   . test+  main-is:          Main.hs   build-depends: -     base >= 3.0 && < 5,-     mtl >= 2.0,-     transformers >= 0.2,-     containers >= 0.3,-     random >= 1.0,-     QuickCheck >= 2.0,-     test-framework-quickcheck2 >= 0.2.9,-     test-framework >= 0.3.3-  other-modules:	Control.Monad.Memo.Test+          base >= 3.0 && <= 5.0,+          mtl >= 2.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+++Benchmark all+  type:             exitcode-stdio-1.0+  hs-source-dirs:   . benchmark+  main-is:          Main.hs+  build-depends:+          base >= 3.0 && <= 5.0,+          mtl >= 2.0,+          transformers >= 0.2,+          containers >= 0.3,+          array >= 0.3,+          vector >= 0.7,+          primitive >= 0.3,+          criterion >= 0.6+  ghc-options:      -O2

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

@@ -0,0 +1,448 @@+{-# LANGUAGE FlexibleInstances #-}++module MemoTest+(+       tests+) where++import qualified Data.IntMap as IM+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Control.Monad.Cont+import Control.Monad.List+import Control.Monad.ST++import Test.QuickCheck+import Test.QuickCheck.Monadic+import System.Random+import Test.Framework (defaultMain, 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 -> Bool+prop_ReaderEqv (SmallInt r) (SmallInt n) =+    ((`runReader` r) . fibr  $ n) == (startEvalMemo . (`runReaderT` r) . fibmr $ 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 $ \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 (SmallInt s) (SmallInt n) =+    ((`runState`s) . fibs $ n) == (startEvalMemo . (`runStateT`s) . fibms $ 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 (SmallList ls) =+    unfringe ls == (startEvalMemo . runListT . unfringem $ 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++-- | 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)++fibSTUAD :: Int -> Double+fibSTUAD 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++prop_STVEqv :: MedInt Int -> Bool+prop_STVEqv (MedInt n) = fibMap n == fibSTV n++fibSTUV :: Int -> Int+fibSTUV n = runST $ evalUVectorMemo (fibm n) n++prop_STUVEqv :: MedInt Int -> Bool+prop_STUVEqv (MedInt n) = fibMap n == fibSTUV n++fibIOV :: Int -> IO Integer+fibIOV n = evalVectorMemo (fibm n) n++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++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++prop_STUSVEqv :: MedInt Int -> Bool+prop_STUSVEqv (MedInt n) = fibMap n == fibSTUSV n++fibSTUSUV :: Int -> Int+fibSTUSUV n = runST $ UV.unsafeEvalUVectorMemo (fibm n) n++prop_STUSUVEqv :: MedInt Int -> Bool+prop_STUSUVEqv (MedInt n) = fibMap n == fibSTUSUV n++fibIOUSV :: Int -> IO Integer+fibIOUSV n = UV.unsafeEvalVectorMemo (fibm n) n++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++prop_IOUSUVEqv :: MedInt Int -> Property+prop_IOUSUVEqv (MedInt n) = monadicIO $ do+                           r <- run $ fibIOUSUV n+                           assert $ r == fibMap 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 "ListEqv"           prop_ListEqv,+                       testProperty "StateEqv"          prop_StateEqv+                      ],+        testGroup "Others" [+                       testProperty "MutualFGEqv"       prop_MutualFEqv,+                       testProperty "MutualCurryFGEqv"  prop_Mutual2FEqv+                       ],+        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 "Exp STVector cache"    prop_STEVEqv,+                                      testProperty "Exp STUVector cache"   prop_STEUVEqv,+                                      testProperty "Exp IOVector cache"    prop_IOEVEqv,+                                      testProperty "Exp IOUVector cache"   prop_IOEUVEqv+                                     ]+                      ]+    ]