1{- | 2Module : Sample.Memo 3Copyright : (c) Eduard Sergeev 2011 4License : BSD-style (see the file LICENSE) 5 6Maintainer : eduard.sergeev@gmail.com 7Stability : experimental 8Portability : non-portable (multi-param classes, functional dependencies) 9 10Some basic examples of 'monad-memo' usage 11 12-} 13 14{-# LANGUAGE FlexibleContexts #-} 15 16module Example.Basic 17 ( 18 -- * Memoized Fibonacci number function 19 fibm, 20 evalFibm, 21 runFibm, 22 23 -- * Combining ListT and MemoT transformers 24 -- | 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> 25 26 -- *** Non-memoized original definition 27 Tree(..), 28 fringe, 29 unfringe, 30 31 -- *** Memoized definition 32 unfringem, 33 evalUnfringem, 34 35 -- * Mutualy recursive function definitions 36 -- | 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> 37 38 -- *** Non-memoized original definition 39 f, g, 40 41 -- *** Memoized definition 42 MemoF, 43 MemoG, 44 MemoFG, 45 fm, gm, 46 evalFm, 47 evalGm, 48 49 -- * Fibonacci with mutual recursive addition 50 MemoFib, 51 MemoBoo, 52 MemoFB, 53 boo, 54 fibm2, 55 evalFibM2, 56 57 -- * Fibonacci with `Memo` and `Writer` 58 fibmw, 59 evalFibmw, 60 61 -- * Fibonacci with MonadMemo and MonadCont 62 fibmc, 63 evalFibmc, 64 65 -- * Tribonacci with constant factor through Reader plus memoization via Memo 66 fibmr, 67 evalFibmr, 68 69 -- * Ackerman function 70 ack, 71 ackm, 72 evalAckm, 73 74 -- * Levensthein distance 75 editDistance, 76 editDistancem, 77 78 -- * Travelling salesman problem 79 evalTsp, 80 evalTspSTU, 81 82 -- * Different MonadCache for the same monadic function 83 -- ** `Data.IntMap`-based 84 evalFibmIM, 85 -- ** `ArrayCache`-based 86 evalFibmSTA, 87 evalFibmIOA, 88 runFibmIOA, 89 evalFibmIOUA, 90 runFibmIOUA, 91 evalFibmSTUA, 92 runFibmSTUA, 93 -- ** `VectorCache`-based 94 evalFibmSTV, 95 evalFibmSTUV, 96 evalFibmIOV, 97 evalFibmIOUV 98 99) where 100 101import Control.Monad.Identity 102import Control.Monad.List 103import Control.Monad.Cont 104import Control.Monad.Reader 105import Control.Monad.Writer 106import Control.Monad.ST 107import qualified Data.Map as M 108import qualified Data.IntMap as IM 109import Data.Array.ST 110import Data.Array.Unboxed 111import qualified Data.Vector as V 112import qualified Data.Vector.Unboxed as UV 113 114import Control.Applicative 115 116import Debug.Trace 117import Data.Array.MArray 118import Data.Array.IO 119 120import Control.Monad.Memo 121import Control.Monad.Memo.Vector.Expandable as EV 122 123 124 125 126-- infix form 127fibm' :: (Num n, Ord n) => n -> Memo n n n 128fibm' 0 = return 0 129fibm' 1 = return 1 130fibm' n = memo fibm' (n-1) `mp` memo fibm' (n-2) 131 where mp = liftM2 (+) 132 133-- applicative form 134fibm'' :: (Num n, Ord n) => n -> Memo n n n 135fibm'' 0 = return 0 136fibm'' 1 = return 1 137fibm'' n = (+) <$> memo fibm'' (n-1) <*> memo fibm'' (n-2) 138 139 140-- 141data Tree a = Leaf !a | Fork !(Tree a) !(Tree a) deriving (Show,Eq) 142 143fringe :: Tree a -> [a] 144fringe (Leaf a) = [a] 145fringe (Fork t u) = fringe t ++ fringe u 146 147partitions as = [ splitAt n as | n <- [1..length as - 1 ]] 148 149-- | Non-memoized version (Uses ListT monad - returns a list of 'Tree') 150unfringe :: (Show t) => [t] -> [Tree t] 151unfringe [a] = show [a] `trace` [Leaf a] 152unfringe as = show as `trace` do 153 (l,k) <- partitions as 154 t <- unfringe l 155 u <- unfringe k 156 return (Fork t u) 157 158 159-- | Mixes memoization with ListT monad: 160-- memoizes the result as list of 'Tree' (e.g. @k :: [t]@, @v :: [Tree t]@) 161unfringem :: (Ord t, Show t) => [t] -> ListT (Memo [t] [Tree t]) (Tree t) 162unfringem [a] = show [a] `trace` return (Leaf a) 163unfringem as = show as `trace` do 164 (l,k) <- ListT $ return (partitions as) 165 t <- memo unfringem l 166 u <- memo unfringem k 167 return (Fork t u) 168 169evalUnfringem :: (Ord t, Show t) => [t] -> [Tree t] 170evalUnfringem = startEvalMemo . runListT . unfringem 171 172 173-- | 'f' depends on 'g' 174f :: Int -> (Int,String) 175f 0 = (1,"+") 176f n = (g(n,fst(f (n-1))),"-" ++ snd(f (n-1))) 177 178-- | 'g' depends on 'f' 179g :: (Int, Int) -> Int 180g (0, m) = m + 1 181g (n,m) = fst(f (n-1))-g((n-1),m) 182 183-- | Memo-cache for 'fm' 184type MemoF = MemoT Int (Int,String) 185-- | Memo-cache for 'gm' 186type MemoG = MemoT (Int,Int) Int 187 188-- | Combined stack of caches (transformers) 189-- Stacks two 'MemoT' transformers in one monad to be used in both 'gm' and 'fm' monadic functions 190type MemoFG = MemoF (MemoG Identity) 191 192fm :: Int -> MemoFG (Int,String) 193fm 0 = return (1,"+") 194fm n = do 195 fn <- memol0 fm (n-1) 196 gn <- memol1 gm ((n-1) , fst fn) 197 return (gn , "-" ++ snd fn) 198 199gm :: (Int,Int) -> MemoFG Int 200gm (0,m) = return (m+1) 201gm (n,m) = do 202 fn <- memol0 fm (n-1) 203 gn <- memol1 gm ((n-1),m) 204 return $ fst fn - gn 205 206evalAll = startEvalMemo . startEvalMemoT 207 208-- | Function to run 'fm' computation 209evalFm :: Int -> (Int, String) 210evalFm = evalAll . fm 211 212-- | Function to run 'gm' computation 213evalGm :: (Int,Int) -> Int 214evalGm = evalAll . gm 215 216 217fm2 :: Int -> MemoFG (Int,String) 218fm2 0 = return (1,"+") 219fm2 n = do 220 fn <- memol0 fm2 (n-1) 221 gn <- for2 memol1 gm2 (n-1) (fst fn) 222 return (gn , "-" ++ snd fn) 223 224-- | Same as @gm@ but in curried form 225gm2 :: Int -> Int -> MemoFG Int 226gm2 0 m = return (m+1) 227gm2 n m = do 228 fn <- memol0 fm2 (n-1) 229 gn <- for2 memol1 gm2 (n-1) m 230 return $ fst fn - gn 231 232 233evalFm2 :: Int -> (Int, String) 234evalFm2 = evalAll . fm2 235 236evalGm2 :: Int -> Int -> Int 237evalGm2 n m = evalAll $ gm2 n m 238 239 240 241 242 243-- 244type MemoFib = MemoT Integer Integer 245type MemoBoo = MemoT Double String 246type MemoFB = MemoFib (MemoBoo Identity) 247 248boo :: Double -> MemoFB String 249boo 0 = "boo: 0" `trace` return "" 250boo n = ("boo: " ++ show n) `trace` do 251 n1 <- boo `memol1` (n-1) 252 fn <- fibm2 `memol0` floor (n-1) 253 return (show fn ++ n1) 254 255fibm2 :: Integer -> MemoFB Integer 256fibm2 0 = "fib: 0" `trace` return 0 257fibm2 1 = "fib: 1" `trace` return 1 258fibm2 n = ("fib: " ++ show n) `trace` do 259 l <- boo `memol1` fromInteger n 260 f1 <- fibm2 `memol0` (n-1) 261 f2 <- fibm2 `memol0` (n-2) 262 return (f1 + f2 + floor (read l)) 263 264evalFibM2 :: Integer -> Integer 265evalFibM2 = startEvalMemo . startEvalMemoT . fibm2 266 267 268 269 270-- | Plus MonadWriter 271fibmw 0 = "fib: 0" `trace` tell "0" >> return 0 272fibmw 1 = "fib: 1" `trace` tell "1" >> return 1 273fibmw n = ("fib: " ++ show n) `trace` do 274 f1 <- fibmw (n-1) 275 f2 <- fibmw (n-2) 276 tell $ show n 277 return (f1+f2) 278 279 280evalFibmw :: Integer -> (Integer, String) 281evalFibmw = startEvalMemo . runWriterT . fibmw 282 283t1 n = startEvalMemo . runWriterT $ fibmw n >> fibmw 1 284t2 n = runWriter $ fibmw n >> fibmw 1 285 286runFibmw n = startRunMemo . runWriterT $ fibmw n >> fibmw 1 287 288evalFibmwSTA n = runST $ evalArrayMemo (runWriterT (fibmw n)) (0,n) 289 290evalFibmwSTV n = runST $ evalVectorMemo (runWriterT (fibmw n)) (n+1) 291 292runFibmwST :: Integer -> ((Integer,String), Array Integer (Maybe (Integer,String))) 293runFibmwST n = runST $ do 294 (a,arr) <- runArrayMemo (runWriterT (fibmw n)) (0,n) 295 iarr <- freeze arr 296 return (a,iarr) 297 298evalFibmwIO :: Integer -> IO (Integer, String) 299evalFibmwIO n = evalArrayMemo (runWriterT (fibmw n)) (0,n) 300 301 302-- | Can also be defined with polymorphic monad classes 303-- MonadCont here 304fibmc :: (Eq k, Num k, Show k, Num n, MonadCont m, MonadMemo k n m) => k -> m n 305fibmc 0 = "fib: 0" `trace` return 0 306fibmc 1 = "fib: 1" `trace` return 1 307fibmc n = ("fib: " ++ show n) `trace` do 308 f1 <- memo fibmc (n-1) 309 f2 <- callCC $ \ break -> do 310 if n == 4 then break 42 else memo fibmc (n-2) 311 return (f1+f2) 312 313evalFibmc :: Integer -> Integer 314evalFibmc = startEvalMemo . (`runContT`return) . fibmc 315 316runFibmc = startRunMemo . (`runContT`return) . fibmc 317 318evalFibmcIO :: Integer -> IO Integer 319evalFibmcIO n = (`evalArrayMemo`(0,n)) . (`runContT`return) . fibmc $ n 320 321evalFibmcST :: Integer -> Integer 322evalFibmcST n = runST $ (`evalArrayMemo`(0,n)) $ (`runContT`return) $ fibmc n 323 324 325fibmr :: (Eq k, Num k, Show k, Num n, MonadMemo k n m, MonadReader n m) => k -> m n 326fibmr 0 = "fib: 0" `trace` return 0 327fibmr 1 = "fib: 1" `trace` return 1 328fibmr 2 = "fib: 2" `trace` return 1 329fibmr n = ("fib: " ++ show n) `trace` do 330 p1 <- ask 331 p2 <- local (const p1) $ memo fibmr (n-2) 332 f1 <- memo fibmr (n-1) 333 f2 <- memo fibmr (n-2) 334 return (p1+f1+f2+p2) 335 336evalFibmr :: Integer -> Integer -> Integer 337evalFibmr r = startEvalMemo . (`runReaderT` r) . fibmr 338 339runFibmr r = startRunMemo . (`runReaderT` r) . fibmr 340 341 342 343fibi 0 = print 0 >> return 0 344fibi 1 = print 1 >> return 1 345fibi n = do 346 n1 <- fibi (n-1) 347 n2 <- fibi (n-2) 348 let r = n1+n2 349 print r >> return r 350 351 352fibmi 0 = print 0 >> return 0 353fibmi 1 = print 1 >> return 1 354fibmi n = do 355 n1 <- memo fibmi (n-1) 356 n2 <- memo fibmi (n-2) 357 let r = n1+n2 358 print r >> return r 359 360 361 362 363 364-- | Ackerman function 365ack :: (Eq n, Num n) => n -> n -> n 366ack 0 n = n+1 367ack m 0 = ack (m-1) 1 368ack m n = ack (m-1) (ack m (n-1)) 369 370ackm :: (Num n, Ord n, MonadMemo (n, n) n m) => n -> n -> m n 371ackm 0 n = return (n+1) 372ackm m 0 = for2 memo ackm (m-1) 1 373ackm m n = do 374 n1 <- for2 memo ackm m (n-1) 375 for2 memo ackm (m-1) n1 376 377evalAckm :: (Num n, Ord n) => n -> n -> n 378evalAckm n m = startEvalMemo $ ackm n m 379 380runAckm n m = startRunMemo $ ackm n m 381 382evalAckmST :: Int -> Int -> Int 383evalAckmST n m = runST $ evalUArrayMemo (ackm n m) ((0,0),(4,100000)) 384 385 386-- | Levensthein distance - recursive definition 387editDistance [] ys = length ys 388editDistance xs [] = length xs 389editDistance (x:xs) (y:ys) 390 | x == y = editDistance xs ys 391 | otherwise = minimum [ 392 1 + editDistance xs (y:ys), 393 1 + editDistance (x:xs) ys, 394 1 + editDistance xs ys] 395 396-- | Levensthein distance - with memoization 397editDistancem [] ys = return $ length ys 398editDistancem xs [] = return $ length xs 399editDistancem (x:xs) (y:ys) 400 | x == y = for2 memo editDistancem xs ys 401 | otherwise = ((+1) . minimum) <$> sequence [ 402 for2 memo editDistancem xs (y:ys), 403 for2 memo editDistancem (x:xs) ys, 404 for2 memo editDistancem xs ys] 405 406runEditDistancem xs ys = startEvalMemo $ editDistancem xs ys 407 408 409-- | Travelling salesman problem 410tsp gph mp t ss 411 | ss == (mp ! t) = return (gph ! (1,t)) 412 | otherwise = do 413 krs <- mapM (\k -> for2 memo (tsp gph mp) k ss' >>= \r -> return (k,r)) (elms ss') 414 return $ minimum [ r + gph ! (k,t) | (k,r) <- krs] 415 where 416 ss' = ss - (mp ! t) 417 418elms ss = go 1 ss 419 where 420 go b 1 = [b] 421 go b ss = 422 case ss `quotRem` 2 of 423 (q,1) -> b : go (b+1) q 424 (q,0) -> go (b+1) q 425 426calcTsp dim = do 427 rs <- mapM (\k -> for2 memo (tsp gph mp) k (ss-1)) [2..n] 428 return $ minimum [ r + gph ! (k,1) | (r,k) <- zip rs [2..n]] 429 where 430 n = dim^2 431 cities = [(x*dim+y+1, (fromIntegral x, fromIntegral y)) 432 | x <- [0..dim-1], y <- [0..dim-1]] 433 dists = [((c1,c2), sqrt ((x1-x2)^2 + (y1-y2)^2)) 434 | (c1,(x1,y1)) <- cities, (c2,(x2,y2)) <- cities] 435 gph = array ((1,1),(n,n)) dists :: UArray (Int,Int) Float 436 mp = array (1,n) [(i,2^(i-1)) | i <- [1..n]] :: UArray Int Int 437 ss = 2^n-1 438 439evalTsp = startEvalMemo . calcTsp 440 441evalTspSTU dim = runST $ evalUArrayMemo (calcTsp dim) ((1,1),(n,2^n-1)) 442 where n = dim^2 443 444evalTspIOU :: Int -> IO Float 445evalTspIOU dim = evalUArrayMemo (calcTsp dim) ((1,1),(n,2^n-1)) 446 where n = dim^2 447 448 449-- | Different `MonadCache` implementations 450-- The same monadic funtion can be called using different MonadeCache implementation 451 452fibm :: (Eq k, Num k, Num n, MonadMemo k n m) => k -> m n 453fibm 0 = return 0 454fibm 1 = return 1 455fibm n = do 456 n1 <- memo fibm (n-1) 457 n2 <- memo fibm (n-2) 458 return (n1+n2) 459 460 461evalFibm :: Integer -> Integer 462evalFibm = startEvalMemo . fibm 463 464runFibm :: Integer -> (Integer, M.Map Integer Integer) 465runFibm = startRunMemo . fibm 466 467evalFibmIM :: Int -> Int 468evalFibmIM n = evalMemoState (fibm n) IM.empty 469 470evalFibmSTA :: Integer -> Integer 471evalFibmSTA n = runST $ evalArrayMemo (fibm n) (0,n) 472 473runFibmSTA :: Integer -> (Integer, Array Integer (Maybe Integer)) 474runFibmSTA n = runST $ do 475 (a,arr) <- runArrayMemo (fibm n) (0,n) 476 iarr <- freeze arr 477 return (a, iarr) 478 479 480evalFibmIOA :: Integer -> IO Integer 481evalFibmIOA n = evalArrayMemo (fibm n) (0,n) 482 483runFibmIOA :: Integer -> IO (Integer, Array Integer (Maybe Integer)) 484runFibmIOA n = do 485 (r, arr) <- runArrayMemo (fibm n) (0,n) 486 iarr <- freeze arr 487 return (r, iarr) 488 489evalFibmIOUA :: Int -> IO Int 490evalFibmIOUA n = evalUArrayMemo (fibm n) (0,n) 491 492runFibmIOUA :: Int -> IO (Int, UArray Int Int) 493runFibmIOUA n = do 494 (r, arr) <- runUArrayMemo (fibm n) (0,n) 495 iarr <- freeze arr 496 return (r, iarr) 497 498evalFibmSTUA :: Int -> Int 499evalFibmSTUA n = runST $ evalUArrayMemo (fibm n) (0,n) 500 501runFibmSTUA :: Int -> (Int, UArray Int Int) 502runFibmSTUA n = runST $ do 503 (a,arr) <- runUArrayMemo (fibm n) (0,n) 504 iarr <- freeze arr 505 return (a,iarr) 506 507 508evalFibmSTV :: Int -> Integer 509evalFibmSTV n = runST $ evalVectorMemo (fibm n) (n+1) 510 511evalFibmIOV :: Int -> IO Integer 512evalFibmIOV n = evalVectorMemo (fibm n) (n+1) 513 514evalFibmSTUV :: Int -> Int 515evalFibmSTUV n = runST $ evalUVectorMemo (fibm n) (n+1) 516 517runFibmSTUV :: Int -> (Int, UV.Vector Int) 518runFibmSTUV n = runST $ do 519 (a,vec) <- runUVectorMemo (fibm n) (n+1) 520 ivec <- UV.freeze vec 521 return (a,ivec) 522 523evalFibmIOUV :: Int -> IO Int 524evalFibmIOUV n = evalUVectorMemo (fibm n) (n+1) 525 526runFibmIOUV :: Int -> IO (Int, UV.Vector Int) 527runFibmIOUV n = do 528 (a, vec) <- runUVectorMemo (fibm n) (n+1) 529 ivec <- UV.freeze vec 530 return (a, ivec) 531 532 533evalFibmSTEV :: Int -> Integer 534evalFibmSTEV n = runST $ EV.startEvalVectorMemo (fibm n) 535 536evalFibmIOEV :: Int -> IO Integer 537evalFibmIOEV n = EV.startEvalVectorMemo (fibm n) 538 539evalFibmSTEUV :: Int -> Int 540evalFibmSTEUV n = runST $ EV.startEvalUVectorMemo (fibm n) 541 542runFibmSTEUV :: Int -> (Int, UV.Vector Int) 543runFibmSTEUV n = runST $ do 544 (a,vec) <- EV.startRunUVectorMemo (fibm n) 545 ivec <- UV.freeze vec 546 return (a,ivec) 547 548evalFibmIOEUV :: Int -> IO Int 549evalFibmIOEUV n = EV.startEvalUVectorMemo (fibm n) 550 551runFibmIOEUV :: Int -> IO (Int, UV.Vector Int) 552runFibmIOEUV n = do 553 (a, vec) <- EV.startRunUVectorMemo (fibm n) 554 ivec <- UV.freeze vec 555 return (a, ivec)