module ADP.Fusion.GAPlike where
import Control.Monad.Primitive
import Data.Primitive.Types (Prim(..))
import Data.Vector.Fusion.Stream.Size
import GHC.Prim (Constraint)
import qualified Data.Vector.Fusion.Stream.Monadic as S
import qualified Data.Vector.Unboxed as VU
import Data.PrimitiveArray (PrimArrayOps(..), MPrimArrayOps(..))
import "PrimitiveArray" Data.Array.Repa.Index
import qualified Data.PrimitiveArray as PA
import qualified Data.PrimitiveArray.Zero.Unboxed as ZU
class Build x where
type BuildStack x :: *
type BuildStack x = None :. x
build :: x -> BuildStack x
default build :: (BuildStack x ~ (None :. x)) => x -> BuildStack x
build x = None :. x
class StreamElement x where
data StreamElm x :: *
type StreamTopIdx x :: *
type StreamArg x :: *
getTopIdx :: StreamElm x -> StreamTopIdx x
getArg :: StreamElm x -> StreamArg x
class (StreamConstraint x) => MkStream m x where
type StreamConstraint x :: Constraint
type StreamConstraint x = ()
mkStream :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)
mkStreamInner :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)
data None = None
data ArgZ = ArgZ
instance StreamElement None where
data StreamElm None = SeNone !Int
type StreamTopIdx None = Int
type StreamArg None = ArgZ
getTopIdx (SeNone k) = k
getArg _ = ArgZ
instance (Monad m) => MkStream m None where
mkStream None (i,j) = S.unfoldr step i where
step k
| k<=j = Just (SeNone i, j+1)
| otherwise = Nothing
mkStreamInner = mkStream
data Chr e = Chr !(VU.Vector e)
instance Build (Chr e)
instance (StreamElement x) => StreamElement (x:.Chr e) where
data StreamElm (x:.Chr e) = SeChr !(StreamElm x) !Int !e
type StreamTopIdx (x:.Chr e) = Int
type StreamArg (x:.Chr e) = StreamArg x :. e
getTopIdx (SeChr _ k _) = k
getArg (SeChr x _ e) = getArg x :. e
instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.Chr e) where
mkStream (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j1) where
mk :: StreamElm x -> m (StreamElm x, Int)
mk x = return (x, getTopIdx x)
step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))
step (x,k)
| k+1 == j = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)
| otherwise = return S.Done
mkStreamInner (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j1) where
mk :: StreamElm x -> m (StreamElm x, Int)
mk x = return (x, getTopIdx x)
step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))
step (x,k)
| k < j = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)
| otherwise = return $ S.Done
data E
data N
class TransToN t where
type TransTo t :: *
transToN :: t -> TransTo t
class TblType tt where
initDeltaIdx :: tt -> Int
instance TblType E where
initDeltaIdx _ = 0
instance TblType N where
initDeltaIdx _ = 1
data Tbl c es = Tbl !es
instance TransToN (Tbl c es) where
type TransTo (Tbl c es) = Tbl N es
transToN (Tbl es) = Tbl es
instance Build (Tbl c es)
instance (StreamElement x, PrimArrayOps arr DIM2 e, TblType c) => StreamElement (x:.Tbl c (arr DIM2 e)) where
data StreamElm (x:.Tbl c (arr DIM2 e)) = SeTbl !(StreamElm x) !Int !e
type StreamTopIdx (x:.Tbl c (arr DIM2 e)) = Int
type StreamArg (x:.Tbl c (arr DIM2 e)) = StreamArg x :. e
getTopIdx (SeTbl _ k _) = k
getArg (SeTbl x _ e) = getArg x :. e
instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, PrimArrayOps arr DIM2 e, TblType c) => MkStream m (x:.Tbl c (arr DIM2 e)) where
mkStream (x:.Tbl t) (i,j) = S.map step $ mkStreamInner x (i,j initDeltaIdx (undefined :: c)) where
step :: StreamElm x -> StreamElm (x:.Tbl c (arr DIM2 e))
step x = let k = getTopIdx x in SeTbl x j (t PA.! (Z:.k:.j))
mkStreamInner (x:.Tbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where
mk :: StreamElm x -> m (StreamElm x, Int)
mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))
step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Tbl c (arr DIM2 e))))
step (x,l)
| l<=j = return $ S.Yield (SeTbl x l (t PA.! (Z:.k:.l))) (x,l+1)
| otherwise = return $ S.Done
where k = getTopIdx x
data MTbl c es = MTbl !es
instance TransToN (MTbl c es) where
type TransTo (MTbl c es) = MTbl N es
transToN (MTbl es) = MTbl es
mtblN :: es -> MTbl N es
mtblN es = MTbl es
mtblE :: es -> MTbl E es
mtblE es = MTbl es
instance Build (MTbl c es)
instance (StreamElement x, MPrimArrayOps marr DIM2 e, TblType c) => StreamElement (x:.MTbl c (marr s DIM2 e)) where
data StreamElm (x:.MTbl c (marr s DIM2 e)) = SeMTbl !(StreamElm x) !Int !e
type StreamTopIdx (x:.MTbl c (marr s DIM2 e)) = Int
type StreamArg (x:.MTbl c (marr s DIM2 e)) = StreamArg x :. e
getTopIdx (SeMTbl _ k _) = k
getArg (SeMTbl x _ e) = getArg x :. e
instance
( Monad m
, PrimMonad m
, MkStream m x
, StreamElement x
, StreamTopIdx x ~ Int
, MPrimArrayOps marr DIM2 e
, TblType c
, s ~ PrimState m
) => MkStream m (x:.MTbl c (marr s DIM2 e)) where
mkStream (x:.MTbl t) (i,j) = S.mapM step $ mkStreamInner x (i,j initDeltaIdx (undefined :: c)) where
step :: StreamElm x -> m (StreamElm (x:.MTbl c (marr s DIM2 e)))
step x = let k = getTopIdx x in PA.readM t (Z:.k:.j) >>= \e -> return $ SeMTbl x j e
mkStreamInner (x:.MTbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where
mk :: StreamElm x -> m (StreamElm x, Int)
mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))
step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.MTbl c (marr s DIM2 e))))
step (x,l)
| l<=j = readM t (Z:.k:.l) >>= \e -> return $ S.Yield (SeMTbl x l e) (x,l+1)
| otherwise = return $ S.Done
where k = getTopIdx x
tNtoE :: Tbl N x -> Tbl E x
tNtoE (Tbl x) = Tbl x
tEtoN :: Tbl E x -> Tbl N x
tEtoN (Tbl x) = Tbl x
data Empty = Empty
instance Build Empty where
type BuildStack Empty = Empty
build c = c
instance StreamElement (Empty) where
data StreamElm Empty = SeEmpty !Int
type StreamTopIdx Empty = Int
type StreamArg Empty = ArgZ :. ()
getTopIdx (SeEmpty k) = k
getArg (SeEmpty _) = ArgZ :. ()
instance (Monad m) => MkStream m (Empty) where
mkStream Empty (i,j) = S.unfoldr step i where
step k
| k==j = Just (SeEmpty k, j+1)
| otherwise = Nothing
mkStreamInner = error "undefined for Empty"
data RestrictedRegion e = RRegion !Int !Int !(VU.Vector e)
instance Build (RestrictedRegion e)
instance (StreamElement x) => StreamElement (x:.RestrictedRegion e) where
data StreamElm (x:.RestrictedRegion e) = SeResRegion !(StreamElm x) !Int (VU.Vector e)
type StreamTopIdx (x:.RestrictedRegion e) = Int
type StreamArg (x:.RestrictedRegion e) = StreamArg x :. (VU.Vector e)
getTopIdx (SeResRegion _ k _) = k
getArg (SeResRegion x _ e) = getArg x :. e
instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.RestrictedRegion e) where
mkStream (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j1) where
mk :: StreamElm x -> m (StreamElm x, Int)
mk x = return (x, getTopIdx x)
step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))
step (x,k)
| k+minR <= j && k+maxR >= j = return $ S.Yield (SeResRegion x k (VU.unsafeSlice k (max maxR (jk)) xs)) (x,j+1)
| otherwise = return S.Done
mkStreamInner (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j) where
mk :: StreamElm x -> m (StreamElm x, Int)
mk x = return (x, getTopIdx x + minR)
step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))
step (x,l)
| l<=j && (lk)<=maxR = return $ S.Yield (SeResRegion x l (VU.unsafeSlice k (lk) xs)) (x,j+1)
| otherwise = return S.Done
where k = getTopIdx x
data BTtbl c t g = BTtbl t g
instance TransToN (BTtbl c t g) where
type TransTo (BTtbl c t g) = BTtbl N t g
transToN (BTtbl t g) = BTtbl t g
bttblN :: t -> g -> BTtbl N t g
bttblN t g = BTtbl t g
bttblE :: t -> g -> BTtbl E t g
bttblE t g = BTtbl t g
instance Build (BTtbl c t g)
type BTfun m b = (Int,Int) -> m (S.Stream m b)
instance (Monad m, StreamElement x, TblType c) => StreamElement (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where
data StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = SeBTtbl !(StreamElm x) !Int !e (m (S.Stream m b))
type StreamTopIdx (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = Int
type StreamArg (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = StreamArg x :. (e, m (S.Stream m b))
getTopIdx (SeBTtbl _ k _ _) = k
getArg (SeBTtbl x _ e g) = getArg x :. (e,g)
instance
( Monad m
, MkStream m x
, StreamElement x
, VU.Unbox e
, StreamTopIdx x ~ Int
, TblType c
) => MkStream m (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where
mkStream (x:.BTtbl t g) (i,j) = S.map step $ mkStreamInner x (i,j initDeltaIdx (undefined :: c)) where
step :: StreamElm x -> StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))
step x = let k = getTopIdx x in SeBTtbl x j (t PA.! (Z:.k:.j)) (g (k,j))
mkStreamInner (x:.BTtbl t g) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where
mk :: StreamElm x -> m (StreamElm x, Int)
mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))
step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))))
step (x,l)
| l<=j = return $ S.Yield (SeBTtbl x l (t PA.! (Z:.k:.l)) (g (k,l))) (x,l+1)
| otherwise = return $ S.Done
where k = getTopIdx x
instance Build x => Build (x,y) where
type BuildStack (x,y) = BuildStack x :. y
build (x,y) = build x :. y
infixl 8 <<<
(<<<) f t ij = S.map (\s -> apply f $ getArg s) $ mkStream (build t) ij
infixl 7 |||
(|||) xs ys ij = xs ij S.++ ys ij
infixl 6 ...
(...) s h ij = h $ s ij
infixl 6 ..@
(..@) s h ij = h ij $ s ij
infixl 9 ~~
(~~) = (,)
infixl 9 %
(%) = (,)
class Apply x where
type Fun x :: *
apply :: Fun x -> x
instance Apply (ArgZ:.a -> res) where
type Fun (ArgZ:.a -> res) = a -> res
apply fun (ArgZ:.a) = fun a
instance Apply (ArgZ:.a:.b -> res) where
type Fun (ArgZ:.a:.b -> res) = a->b -> res
apply fun (ArgZ:.a:.b) = fun a b
instance Apply (ArgZ:.a:.b:.c -> res) where
type Fun (ArgZ:.a:.b:.c -> res) = a->b->c -> res
apply fun (ArgZ:.a:.b:.c) = fun a b c
instance Apply (ArgZ:.a:.b:.c:.d -> res) where
type Fun (ArgZ:.a:.b:.c:.d -> res) = a->b->c->d -> res
apply fun (ArgZ:.a:.b:.c:.d) = fun a b c d
instance Apply (ArgZ:.a:.b:.c:.d:.e -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res
apply fun (ArgZ:.a:.b:.c:.d:.e) = fun a b c d e
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f) = fun a b c d e f
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n
instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where
type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res
apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o