Commit ab9eaa4a authored by Sven Keidel's avatar Sven Keidel

improve tests

parent ef2fa5c7
......@@ -7,6 +7,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -DTRACE #-}
module Control.Arrow.Transformer.FixpointCache(CacheArrow,runCacheArrow,runCacheArrow',liftCache) where
import Prelude hiding (id,(.),lookup)
......@@ -23,6 +25,11 @@ import Data.Order
import Data.Store (Store)
import qualified Data.Store as S
#ifdef TRACE
import Debug.Trace
import Text.Printf
#endif
newtype CacheArrow a b x y = CacheArrow (((Store a b,Store a b),x) -> (Store a b,y))
runCacheArrow :: CacheArrow a b x y -> (x -> y)
......@@ -52,13 +59,40 @@ instance ArrowChoice (CacheArrow i o) where
instance ArrowApply (CacheArrow i o) where
app = CacheArrow $ (\(io,(CacheArrow f,x)) -> (f,(io,x))) ^>> app
instance (Eq x, Hashable x, LowerBounded y, Complete y) => ArrowFix x y (CacheArrow x y) where
#ifdef TRACE
instance (Show x, Show y, Eq x, Hashable x, LowerBounded y, Complete y)
=> ArrowFix x y (CacheArrow x y) where
fixA f = proc x -> do
old <- getOutCache -< ()
setOutCache -< bottom
y <- localInCache (fix (f . memoize)) -< (old,x)
new <- getOutCache -< ()
if trace (printf "old: %s\nnew: %s" (show old) (show new)) (new old) -- We are in the reductive set of `f` and have overshot the fixpoint
then returnA -< y
else fixA f -< x
memoize :: (Show x, Show y, Eq x, Hashable x, LowerBounded y, Complete y) => CacheArrow x y x y -> CacheArrow x y x y
memoize f = proc x -> do
m <- lookupOutCache -< x
case m of
Just y -> do
returnA -< trace (printf "cache hit: %s -> %s" (show x) (show y)) y
Nothing -> do
yOld <- lookupInCache -< x
writeOutCache -< trace (printf "cache miss: %s, old value: %s, recompute ..." (show x) (show yOld))(x, fromMaybe bottom yOld)
y <- f -< x
updateOutCache -< trace (printf "cache miss: %s, old value: %s, new value: %s" (show x) (show yOld) (show y)) (x, y)
returnA -< y
#elif
instance (Eq x, Hashable x, LowerBounded y, Complete y)
=> ArrowFix x y (CacheArrow x y) where
fixA f = proc x -> do
old <- getOutCache -< ()
setOutCache -< bottom
y <- localInCache (fix (f . memoize)) -< (old,x)
new <- getOutCache -< ()
if new old -- We are in the reductive set of `f` and have overshot the fixpoint
if (new old) -- We are in the reductive set of `f` and have overshot the fixpoint
then returnA -< y
else fixA f -< x
......@@ -66,13 +100,15 @@ memoize :: (Eq x, Hashable x, LowerBounded y, Complete y) => CacheArrow x y x y
memoize f = proc x -> do
m <- lookupOutCache -< x
case m of
Just y -> returnA -< y
Just y -> do
returnA -< y
Nothing -> do
yOld <- lookupInCache -< x
writeOutCache -< (x, fromMaybe bottom yOld)
y <- f -< x
updateOutCache -< (x, y)
returnA -< y
#endif
lookupOutCache :: (Eq x, Hashable x) => CacheArrow x y x (Maybe y)
lookupOutCache = CacheArrow $ \((_,o),x) -> (o,S.lookup x o)
......
......@@ -7,7 +7,11 @@ import GHC.Generics
-- | Intervals represent ranges of numbers. Bot represents the empty interval
data Interval n = Bot | Interval n n
deriving (Eq,Show,Generic)
deriving (Eq,Generic)
instance Show n => Show (Interval n) where
show Bot = "⊥"
show (Interval n m) = "["++ show n ++ "," ++ show m ++"]"
instance PreOrd x => PreOrd (Interval x) where
Bot _ = True
......
......@@ -15,6 +15,7 @@ import Control.Arrow.Fail
import Control.Arrow.State
import Data.Interval (Interval)
import qualified Data.Interval as I
import Data.Sign (Sign)
import Data.Order
import Data.Error
......@@ -32,17 +33,25 @@ type StateCache x y = StateArrow Int (CacheArrow (Int,x) (Int,y)) x y
spec :: Spec
spec = do
describe "the analysis of the fibonacci numbers" $
let fib :: ArrowChoice c => c Int (Interval Int) -> c Int (Interval Int)
fib f = proc n -> case n of
0 -> returnA -< 0
1 -> returnA -< 1
_ -> do
x <- f -< n-1
y <- f -< n-2
returnA -< x + y
let fib f =
ifLowerThan 0
(proc _ -> returnA -< 0)
(ifEq 1 (proc _ -> returnA -< 1)
(proc n -> do
x <- f -< n-1
y <- f -< n-2
returnA -< x + y))
in it "should memoize numbers that have been computed before already" $ do
runCacheArrow (fixA fib :: Cache Int (Interval Int)) 10 `shouldBe` fix fib 10
runCacheArrow (fixA fib :: Cache Int (Interval Int)) 15 `shouldBe` fix fib 15
runCacheArrow (fixA fib :: Cache (Interval Int) (Interval Int)) (I.Interval 5 10) `shouldBe` I.Interval 5 55
-- runCacheArrow (fixA fib :: Cache (Interval Int) (Interval Int)) 15 `shouldBe` fix fib 15
describe "the analysis of the factorial function" $
let fact :: (ArrowChoice c, Complete (c (Interval Int,Interval Int) (Interval Int))) => c (Interval Int) (Interval Int) -> c (Interval Int) (Interval Int)
fact f = proc n -> do
ifLowerThan 0 (proc _ -> returnA -< 1)
(proc n -> do {x <- f -< (n-1); returnA -< n * x}) -< n
in it "absfact [5,10] should produce [fact 5,fact 10]" $ runCacheArrow (fixA fact :: Cache (Interval Int) (Interval Int)) (I.Interval 5 10) `shouldBe` I.Interval 120 3628800
describe "the analyis of a diverging program" $
let diverge :: Cache Int Sign -> Cache Int Sign
......@@ -76,3 +85,27 @@ spec = do
in it "should cache the state of the program" $
runCacheArrow' (runStateArrow (fixA timesTwo)) (0,5)
`shouldBe` (S.fromList [((n,5-n),(10-n,())) | n <- [1..5]],(10,()))
where
ifEq :: (ArrowChoice c, Complete (c (Interval Int, Interval Int) (Interval Int)), Complete (c (Interval Int,(Interval Int, Interval Int)) (Interval Int))) => Int -> c (Interval Int) (Interval Int) -> c (Interval Int) (Interval Int) -> c (Interval Int) (Interval Int)
ifEq l f g = proc b -> case b of
I.Bot -> returnA -< I.Bot
I.Interval m n
| m == l && n == l -> f -< b
| n < l || l < m -> g -< b
| otherwise -> joined f (joined g g) -< (I.Interval l l,(toBot $ I.Interval m (l-1), toBot $ I.Interval (l+1) n))
where
toBot :: Interval Int -> Interval Int
toBot I.Bot = bottom
toBot x@(I.Interval m n)
| n < m = bottom
| otherwise = x
ifLowerThan :: (ArrowChoice c, Complete (c (Interval Int,Interval Int) (Interval Int))) => Int -> c (Interval Int) (Interval Int) -> c (Interval Int) (Interval Int) -> c (Interval Int) (Interval Int)
ifLowerThan l f g = proc b -> case b of
I.Bot -> returnA -< I.Bot
I.Interval m n
| n <= l -> f -< b
| l < m -> g -< b
| otherwise -> joined f g -< (I.Interval m l, I.Interval (l+1) n)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment