{- | 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 -- *** 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 -- *** 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)