monad-memo 0.4.0 → 0.4.1
raw patch · 12 files changed
+997/−846 lines, 12 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES +3/−0
- Control/Monad/Memo.hs +11/−10
- Example/Basic.hs +0/−555
- Example/Customisation/Array.hs +0/−88
- Example/Customisation/MaybeLike.hs +0/−64
- Example/Customisation/Vector.hs +0/−83
- benchmark/Main.hs +170/−31
- example/Basic.hs +555/−0
- example/Customisation/Array.hs +88/−0
- example/Customisation/MaybeLike.hs +64/−0
- example/Customisation/Vector.hs +83/−0
- monad-memo.cabal +23/−15
CHANGES view
@@ -12,3 +12,6 @@ - VectorCache (and flavours) vector-based MonadCache for even better performance - Bug fixes in transformer implementations (Reader, State, RWS) - Simple benchmark included+0.4.1+- Documentation fixes+- `Example` is renamed to `example` and is excluded from package's module hierarchy
Control/Monad/Memo.hs view
@@ -7,8 +7,7 @@ Stability : experimental Portability : non-portable (multi-param classes, functional dependencies) -Exports all necessary bits and pieces (default set) for memoization.-It should be suficient to import just thim module to be able to ad memoization to your monadic code+Importing just this module is sufficient for most cases of the package usage -} @@ -116,14 +115,14 @@ Including recursive definition. Classic example: Fibonacci number function: Here is simple non-monadic definition of it ->fib :: (Num n) => n -> n+>fib :: (Eq n, Num n) => n -> n >fib 0 = 0 >fib 1 = 1 >fib n = fib (n-1) + fib (n-2) To use 'Memo' monad we need to convert it into monadic form: ->fibm :: (Num n, Monad m) => n -> m n+>fibm :: (Eq n, Num n, Monad m) => n -> m n >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = do@@ -133,7 +132,7 @@ Then we can specify which computation we want to memoize with 'memo' (both recursive calls to (n-1) and (n-2)): ->fibm :: (Num n, Ord n) => n -> Memo n n n+>fibm :: (Eq n, Num n, Ord n) => n -> Memo n n n >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = do@@ -145,11 +144,11 @@ Then it can be run with 'startEvalMemo' ->startEvalMemo . fibm $ 5+>startEvalMemo (fibm 100) Or using applicative form: ->fibm :: (Num n, Ord n) => n -> Memo n n n+>fibm :: (Eq n, Num n, Ord n) => n -> Memo n n n >fibm 0 = return 0 >fibm 1 = return 1 >fibm n = (+) <$> memo fibm (n-1) <*> memo fibm (n-2)@@ -176,7 +175,7 @@ >boo 0 = return "" >boo n = do > n1 <- memol1 boo (n-1) -- uses next in stack transformer (memol_1_): MemoBoo is nested in MemoFib-> fn <- memol0 fibm2 floor (n-1) -- uses current transformer (memol_0_): MemoFib+> fn <- memol0 fibm2 (floor (n-1)) -- uses current transformer (memol_0_): MemoFib > return (show fn ++ n1) >fibm2 :: Integer -> MemoFB Integer @@ -188,6 +187,7 @@ > f2 <- memol0 fibm2 (n-2) > return (f1 + f2 + floor (read l)) +>evalFibM2 :: Integer -> Integer >evalFibM2 = startEvalMemo . startEvalMemoT . fibm2 -}@@ -197,7 +197,7 @@ With 'MonadWriter': ->fibmw :: (Num n, MonadWriter String m, MonadMemo n n m) => n -> m n+>fibmw :: (MonadWriter String m, MonadMemo Integer Integer m) => Integer -> m Integer >fibmw 0 = return 0 >fibmw 1 = return 1 >fibmw n = do@@ -206,6 +206,7 @@ > tell $ show n > return (f1+f2) +>evalFibmw :: Integer -> (Integer, String) >evalFibmw = startEvalMemo . runWriterT . fibmw -}@@ -215,7 +216,7 @@ For two-argument function we can use 'for2' function adapter: >-- Ackerman function classic definition->ack :: Num n => n -> n -> n+>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))
− Example/Basic.hs
@@ -1,555 +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)--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)
− Example/Customisation/Array.hs
@@ -1,88 +0,0 @@-{- |-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)-
− Example/Customisation/MaybeLike.hs
@@ -1,64 +0,0 @@-{- |-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)
− Example/Customisation/Vector.hs
@@ -1,83 +0,0 @@-{- |-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)
benchmark/Main.hs view
@@ -1,9 +1,12 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE FlexibleContexts, BangPatterns #-} module Main (main) where +import Data.Int import Data.Word+import Data.List import qualified Data.IntMap as IM+import Data.Array import Control.Monad.ST import Control.Monad.Memo import Control.Monad.Memo.Vector.Unsafe@@ -11,37 +14,10 @@ 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- ]- ]- ]- +-- Fibonacci numbers+--------------------+ {-# INLINE fibm #-} fibm 0 = return 0 fibm 1 = return 1@@ -106,3 +82,166 @@ fibSTUVE :: Int -> Word fibSTUVE n = runST $ startEvalUVectorMemo (fibm n)+++-- 0-1 Knapsack problem+-----------------------++{-# INLINE knap #-}+knap ws vs w = m (l-1) w+ where+ l = length ws+ wa = listArray (0,l-1) ws+ va = listArray (0,l-1) vs+ {-# INLINE m #-}+ m 0 _ = return 0+ m !i !w+ | wa ! i > w = for2 memo m (i-1) w+ | otherwise = do+ !m1 <- for2 memo m (i-1) w+ !m2 <- for2 memo m (i-1) (w - wa ! i)+ return (m1 `max` (m2 + va ! i))++knapM :: [Int] -> [Int] -> Int -> Int+knapM ws vs w = startEvalMemo (knap ws vs w)++knapSTA :: [Int] -> [Int] -> Int -> Int+knapSTA ws vs w = runST $ evalArrayMemo (knap ws vs w) ((0,0), ((length ws),w))++knapSTUA :: [Int] -> [Int] -> Int -> Int+knapSTUA ws vs w = runST $ evalUArrayMemo (knap ws vs w) ((0,0), ((length ws),w))++knapIOA :: [Int] -> [Int] -> Int -> IO Int+knapIOA ws vs w = evalArrayMemo (knap ws vs w) ((0,0), ((length ws),w))++knapIOUA :: [Int] -> [Int] -> Int -> IO Int+knapIOUA ws vs w = evalUArrayMemo (knap ws vs w) ((0,0), ((length ws),w))+++-- Longest common subsequence+-----------------------------++{-# INLINE lcsm2 #-}+lcsm2 :: MonadMemo (Int,Int) Int m => [Int] -> [Int] -> m Int+lcsm2 as bs = lcs la lb+ where+ la = length as+ lb = length bs+ aa = listArray (1,la) as+ ba = listArray (1,lb) bs+ {-# INLINE lcs #-}+ lcs 0 _ = return 0+ lcs _ 0 = return 0+ lcs ia ib+ | (aa!ia) == (ba!ib) = succ `liftM` for2 memo lcs (ia-1) (ib-1)+ | otherwise = do+ !l1 <- for2 memo lcs (ia-1) ib+ !l2 <- for2 memo lcs ia (ib-1)+ return (l1 `max` l2)++lcsM :: [Int] -> [Int] -> Int+lcsM as bs = startEvalMemo (lcsm2 as bs)++lcsSTA :: [Int] -> [Int] -> Int+lcsSTA as bs = runST $ evalArrayMemo (lcsm2 as bs) ((0,0), (length as, length bs))++lcsSTUA :: [Int] -> [Int] -> Int+lcsSTUA as bs = runST $ evalUArrayMemo (lcsm2 as bs) ((0,0), (length as, length bs))++{-# INLINE lcsm #-}+lcsm :: MonadMemo Int Int m => [Int] -> [Int] -> m Int+lcsm as bs = lcs la lb+ where+ la = genericLength as+ lb = genericLength bs+ aa = listArray (1,la) as+ ba = listArray (1,lb) bs+ {-# INLINE lcs #-}+ lcs 0 _ = return 0+ lcs _ 0 = return 0+ lcs ia ib+ | (aa!ia) == (ba!ib) = succ `liftM` mlcs (ia-1) (ib-1)+ | otherwise = do+ l1 <- mlcs (ia-1) ib+ l2 <- mlcs ia (ib-1)+ return (l1 `max` l2)+ mlcs ai bi =+ memo (\abi -> + let (!ai,!bi) = abi `quotRem` lb+ in lcs ai bi) (ai*lb + bi)++lcsIM :: [Int] -> [Int] -> Int+lcsIM as bs = evalMemoState (lcsm as bs) IM.empty++lcsSTUV :: [Int] -> [Int] -> Int+lcsSTUV as bs = runST $ evalUVectorMemo (lcsm as bs) ((length as + 1) * (length bs + 1))++lcsSTUVE :: [Int] -> [Int] -> Int+lcsSTUVE as bs = runST $ startEvalUVectorMemo (lcsm as bs)++++main = defaultMainWith defaultConfig (return ()) [+ bgroup "fib" [+ bgroup "pure" [+ bench "Map" $ whnf fibM n+ , bench "IntMap" $ whnf fibIM n+ ]+ , bgroup "ST" [+ bench "Array" $ whnf fibSTA n+ , bench "UArray" $ whnf fibSTUA n+ , bench "Vector" $ whnf fibSTV n+ , bench "UVector" $ whnf fibSTUV n+ , bench "Vector unsafe" $ whnf fibSTVU n+ , bench "UVector unsafe" $ whnf fibSTUVU n+ , bench "Vector exp" $ whnf fibSTVE n+ , bench "UVector exp" $ whnf fibSTUVE n+ ]+ , bgroup "IO" [+ bench "Array" $ 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+ ]+ ]+ , bgroup "knapsack" [+ bgroup "pure" [+ bench "Map" $ whnf (knapM ws vs) w+ ]+ , bgroup "ST" [+ bench "Array" $ whnf (knapSTA ws vs) w+ , bench "UArray" $ whnf (knapSTUA ws vs) w+ ]+ , bgroup "IO" [+ bench "Array" $ knapIOA ws vs w+ , bench "UArray" $ knapIOUA ws vs w+ ]+ ]+ , bgroup "LCS" [+ bgroup "pure" [+ bench "Map" $ whnf (lcsM as) bs+ , bench "IntMap" $ whnf (lcsIM as) bs+ ]+ , bgroup "ST" [+ bench "Array" $ whnf (lcsSTA as) bs+ , bench "UArray" $ whnf (lcsSTUA as) bs+ , bench "UVector exp" $ whnf (lcsSTUVE as) bs+ , bench "UVector" $ whnf (lcsSTUV as) bs+ ]+ ]+ ]+ where+ -- fib arg+ n = 50000+ -- knapsac args+ ws = [1..100]+ vs = [1..100]+ w = 400+ -- LCS args+ as = [1..200]+ bs = [100,102..400]+
+ example/Basic.hs view
@@ -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)
+ example/Customisation/Array.hs view
@@ -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)+
+ example/Customisation/MaybeLike.hs view
@@ -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)
+ example/Customisation/Vector.hs view
@@ -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)
monad-memo.cabal view
@@ -1,12 +1,32 @@ Name: monad-memo -Version: 0.4.0+Version: 0.4.1 -- A short (one-line) description of the package. Synopsis: Memoization monad transformer -- A longer description of the package.-Description: Memoization monad transformer supporting most of the standard monad transformers and a range of memoization cache types: from default pure maps to extremely fast mutable vectors +Description:+ Memoization monad transformer supporting most of the standard monad transformers and a range of memoization cache types: from default pure maps to extremely fast mutable vectors+ .+ To add memoization behaviour to a monadic function:+ .+ 1) Add 'Control.Monad.Memo.memo' combinator at the point when memoization is required (i.e. recursive call)+ .+ >import Control.Monad.Memo+ >+ >fibm 0 = return 0+ >fibm 1 = return 1+ >fibm n = do+ > n1 <- memo fibm (n-1)+ > n2 <- memo fibm (n-2)+ > return (n1+n2)+ .+ 2) Use approprite /*eval*/ or /*run*/ function to evaluate resulting `MonadMemo` monad:+ .+ >startEvalMemo (fibm 100)+ .+ See detailed description and examples: "Control.Monad.Memo" -- URL for the project homepage or repository. Homepage: https://github.com/EduardSergeev/monad-memo@@ -44,11 +64,7 @@ source-repository this type: git location: https://github.com/EduardSergeev/monad-memo.git- tag: 0.4.0--Flag examples- description: Builds examples- default: False+ tag: 0.4.1 Library@@ -78,14 +94,6 @@ Data.MapLike.Instances, Data.MaybeLike, Data.MaybeLike.Instances-- if flag(examples)- exposed-modules:- Example.Basic,- Example.Customisation.MaybeLike,- Example.Customisation.Array,- Example.Customisation.Vector- ghc-options: -O2 Test-Suite tests type: exitcode-stdio-1.0