module Test.Feat.Enumerate(
Part,
Index,
Enumerate(..),
module Control.Applicative,
module Data.Monoid,
pay,
mem,
mempay,
module Data.Typeable,
Tag(Source),
tag,
tagShare,
optimise
) where
import Control.Monad.TagShare(Sharing, runSharing, share)
import Test.Feat.Internals.Tag(Tag(Source))
import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Typeable
import Language.Haskell.TH
import Data.MemoCombinators
type Part = Int
type Index = Integer
data Enumerate a = Enumerate
{
card :: Part -> Index,
select :: Part -> Index -> a,
optimal :: Sharing Tag (Enumerate a)
} deriving Typeable
instance Functor Enumerate where
fmap f cf = cf
{select = \p n -> f (select cf p n)
, optimal = liftM (fmap f) (optimal cf) }
instance Monoid (Enumerate a) where
mempty = let e = Enumerate (\p -> 0)
(\p i -> error "select: empty")
(return e) in e
mappend = union
union :: Enumerate a -> Enumerate a -> Enumerate a
union a b = infinite part (liftM2 union (optimal a) (optimal b)) where
part p = finUnion (finite a p) (finite b p)
instance Applicative Enumerate where
pure = singleton
f <*> a = fmap (uncurry ($)) (cartesian f a)
cartesian :: Enumerate a -> Enumerate b -> Enumerate (a,b)
cartesian a b = infinite (\p -> foldl1 finUnion
[finCart (finite a x) (finite b (px))| x <- [0..p]])
(liftM2 cartesian (optimal a) (optimal b))
singleton :: a -> Enumerate a
singleton a = let e = Enumerate car sel (return e) in e
where car p = if p == 0 then 1 else 0
sel 0 0 = a
sel _ _ =
error "select: index out of bounds"
pay :: Enumerate a -> Enumerate a
pay sel = Enumerate
{ card = \p -> if p <= 0 then 0 else card sel (p1)
, select = \p -> select sel (p1)
, optimal = liftM pay (optimal sel)
}
mem :: Enumerate a -> Enumerate a
mem sel = sel
{ card = bits (card sel)
, optimal = fmap mem (optimal sel)
}
mempay :: Enumerate a -> Enumerate a
mempay = mem . pay
tag :: Q Exp
tag = location >>= makeTag where
makeTag Loc{ loc_package = p,
loc_module = m,
loc_start = (r,c) }
= [|Source p m r c|]
tagShare :: Typeable a => Tag -> Enumerate a -> Enumerate a
tagShare t e = e{optimal = share t (optimal e)}
optimise :: Enumerate a -> Enumerate a
optimise e = let e' = runSharing (optimal e) in
e'{optimal = return e'}
data Finite a = Finite {fCard :: Index, fSelect :: Index -> a}
finite :: Enumerate a -> Part -> Finite a
finite e p = Finite (card e p) (select e p)
infinite :: (Part -> Finite a) -> Sharing Tag (Enumerate a) -> Enumerate a
infinite f m = Enumerate (fCard . f) (fSelect . f) m
finUnion :: Finite a -> Finite a -> Finite a
finUnion f1 f2 = Finite car sel where
car = fCard f1 + fCard f2
sel i = if i < fCard f1
then fSelect f1 i
else fSelect f2 (ifCard f1)
finCart :: Finite a -> Finite b -> Finite (a,b)
finCart f1 f2 = Finite car sel where
car = fCard f1 * fCard f2
sel i = let (q, r) = (i `quotRem` fCard f2)
in (fSelect f1 q, fSelect f2 r)