{-# 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 import Control.Monad.Memo.Vector.Expandable import Criterion.Main import Criterion.Config -- Fibonacci numbers -------------------- {-# 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) -- 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]