summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristianHoener <>2015-11-20 20:55:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-11-20 20:55:00 (GMT)
commite481d422ce30585dfaa7f6bf580c78fc610f1a7f (patch)
tree8c66f168ea63ecb860b3823d71d53cc54cfcbfe0
parent7e22872a837b0cea1123f05c3732148dd44a7be7 (diff)
version 0.5.0.00.5.0.0
-rw-r--r--ADP/Fusion/Base.hs4
-rw-r--r--ADP/Fusion/Base/Classes.hs38
-rw-r--r--ADP/Fusion/Base/Multi.hs151
-rw-r--r--ADP/Fusion/Base/Point.hs69
-rw-r--r--ADP/Fusion/Base/Set.hs125
-rw-r--r--ADP/Fusion/Base/Subword.hs110
-rw-r--r--ADP/Fusion/Base/Term.hs55
-rw-r--r--ADP/Fusion/Base/TyLvlIx.hs77
-rw-r--r--ADP/Fusion/Base/Unit.hs96
-rw-r--r--ADP/Fusion/QuickCheck/Set.hs248
-rw-r--r--ADP/Fusion/SynVar/Array.hs340
-rw-r--r--ADP/Fusion/SynVar/Array/Point.hs79
-rw-r--r--ADP/Fusion/SynVar/Array/Set.hs164
-rw-r--r--ADP/Fusion/SynVar/Array/Subword.hs318
-rw-r--r--ADP/Fusion/SynVar/Array/TermSymbol.hs150
-rw-r--r--ADP/Fusion/SynVar/Array/Type.hs60
-rw-r--r--ADP/Fusion/SynVar/Fill.hs10
-rw-r--r--ADP/Fusion/SynVar/Indices.hs22
-rw-r--r--ADP/Fusion/SynVar/Indices/Classes.hs76
-rw-r--r--ADP/Fusion/SynVar/Indices/Point.hs73
-rw-r--r--ADP/Fusion/SynVar/Indices/Set0.hs160
-rw-r--r--ADP/Fusion/SynVar/Indices/Subword.hs220
-rw-r--r--ADP/Fusion/SynVar/Indices/Unit.hs58
-rw-r--r--ADP/Fusion/SynVar/Recursive/Subword.hs1
-rw-r--r--ADP/Fusion/SynVar/Split/Subword.hs72
-rw-r--r--ADP/Fusion/SynVar/Split/Type.hs10
-rw-r--r--ADP/Fusion/Term/Chr.hs2
-rw-r--r--ADP/Fusion/Term/Chr/Point.hs115
-rw-r--r--ADP/Fusion/Term/Chr/Set0.hs64
-rw-r--r--ADP/Fusion/Term/Chr/Subword.hs119
-rw-r--r--ADP/Fusion/Term/Chr/Type.hs8
-rw-r--r--ADP/Fusion/Term/Deletion.hs2
-rw-r--r--ADP/Fusion/Term/Deletion/Point.hs72
-rw-r--r--ADP/Fusion/Term/Deletion/Subword.hs85
-rw-r--r--ADP/Fusion/Term/Deletion/Type.hs2
-rw-r--r--ADP/Fusion/Term/Deletion/Unit.hs55
-rw-r--r--ADP/Fusion/Term/Edge/Set.hs35
-rw-r--r--ADP/Fusion/Term/Edge/Type.hs2
-rw-r--r--ADP/Fusion/Term/Epsilon.hs4
-rw-r--r--ADP/Fusion/Term/Epsilon/Point.hs72
-rw-r--r--ADP/Fusion/Term/Epsilon/Set.hs98
-rw-r--r--ADP/Fusion/Term/Epsilon/Subword.hs63
-rw-r--r--ADP/Fusion/Term/Epsilon/Type.hs2
-rw-r--r--ADP/Fusion/Term/Epsilon/Unit.hs55
-rw-r--r--ADP/Fusion/Term/PeekIndex/Subword.hs6
-rw-r--r--ADP/Fusion/Term/PeekIndex/Type.hs2
-rw-r--r--ADP/Fusion/Term/Strng/Point.hs95
-rw-r--r--ADP/Fusion/Term/Strng/Subword.hs46
-rw-r--r--ADP/Fusion/Term/Strng/Type.hs2
-rw-r--r--ADPfusion.cabal57
-rw-r--r--changelog.md9
-rw-r--r--src/Durbin.hs6
-rw-r--r--src/NeedlemanWunsch.hs11
-rw-r--r--src/Nussinov.hs6
-rw-r--r--src/OverlappingPalindromes.hs5
-rw-r--r--src/PartNussinov.hs35
-rw-r--r--src/Pseudoknot.hs11
-rw-r--r--src/SplitTests.hs5
-rw-r--r--tests/QuickCheck/Common.hs (renamed from ADP/Fusion/QuickCheck/Common.hs)2
-rw-r--r--tests/QuickCheck/Point.hs (renamed from ADP/Fusion/QuickCheck/Point.hs)212
-rw-r--r--tests/QuickCheck/Set.hs314
-rw-r--r--tests/QuickCheck/Subword.hs (renamed from ADP/Fusion/QuickCheck/Subword.hs)141
-rw-r--r--tests/performance.hs6
-rw-r--r--tests/properties.hs85
64 files changed, 2769 insertions, 1928 deletions
diff --git a/ADP/Fusion/Base.hs b/ADP/Fusion/Base.hs
index 9cd4a49..5c6571e 100644
--- a/ADP/Fusion/Base.hs
+++ b/ADP/Fusion/Base.hs
@@ -5,6 +5,8 @@ module ADP.Fusion.Base
, module ADP.Fusion.Base.Point
, module ADP.Fusion.Base.Set
, module ADP.Fusion.Base.Subword
+ , module ADP.Fusion.Base.TyLvlIx
+ , module ADP.Fusion.Base.Unit
) where
import ADP.Fusion.Base.Classes
@@ -12,4 +14,6 @@ import ADP.Fusion.Base.Multi
import ADP.Fusion.Base.Point
import ADP.Fusion.Base.Set
import ADP.Fusion.Base.Subword
+import ADP.Fusion.Base.TyLvlIx
+import ADP.Fusion.Base.Unit
diff --git a/ADP/Fusion/Base/Classes.hs b/ADP/Fusion/Base/Classes.hs
index 59de6fd..6d5aaee 100644
--- a/ADP/Fusion/Base/Classes.hs
+++ b/ADP/Fusion/Base/Classes.hs
@@ -2,7 +2,6 @@
module ADP.Fusion.Base.Classes where
import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Size
import qualified Data.Vector.Fusion.Stream.Monadic as S
import Data.PrimitiveArray
@@ -14,13 +13,16 @@ data OutsideContext s
| ORightOf s
| OFirstLeft s
| OLeftOf s
+ deriving (Show)
data InsideContext s
= IStatic s
| IVariable s
+ deriving (Show)
data ComplementContext
= Complemented
+ deriving (Show)
class RuleContext i where
type Context i :: *
@@ -93,18 +95,18 @@ deriving instance Show ix => Show (Elm S ix)
-- elements. If 'b' is false, we discard all stream elements.
staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a
-staticCheck b (S.Stream step t n) = b `seq` S.Stream snew (CheckLeft (b:.t)) (toMax n) where
+staticCheck b (S.Stream step t) = b `seq` S.Stream snew (CheckLeft b t) where
{-# Inline [0] snew #-}
- snew (CheckLeft (False:._)) = return $ S.Done
- snew (CheckLeft (True :.s)) = return $ S.Skip (CheckRight s)
- snew (CheckRight s ) = do r <- step s
- case r of
- S.Yield x s' -> return $ S.Yield x (CheckRight s')
- S.Skip s' -> return $ S.Skip (CheckRight s')
- S.Done -> return $ S.Done
+ snew (CheckLeft False _) = return $ S.Done
+ snew (CheckLeft True s) = return $ S.Skip (CheckRight s)
+ snew (CheckRight s ) = do r <- step s
+ case r of
+ S.Yield x s' -> return $ S.Yield x (CheckRight s')
+ S.Skip s' -> return $ S.Skip (CheckRight s')
+ S.Done -> return $ S.Done
{-# INLINE staticCheck #-}
-data StaticCheck a b = CheckLeft a | CheckRight b
+data StaticCheck a b = CheckLeft Bool a | CheckRight b
-- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if
@@ -123,6 +125,10 @@ minSize NonEmpty = 1
minSize _ = 0
{-# INLINE minSize #-}
+-- |
+--
+-- TODO Rewrite to generalize easily over multi-dim cases.
+
class ModifyConstraint t where
toNonEmpty :: t -> t
toEmpty :: t -> t
@@ -131,14 +137,12 @@ class ModifyConstraint t where
type family TblConstraint x :: *
-type instance TblConstraint (is:.i) = TblConstraint is :. TblConstraint i
-type instance TblConstraint Z = Z
-type instance TblConstraint (Outside o) = TblConstraint o
-type instance TblConstraint (Complement o) = TblConstraint o
+type instance TblConstraint (is:.i) = TblConstraint is :. TblConstraint i
+type instance TblConstraint Z = Z
-- TODO move into the sub-modules
-type instance TblConstraint PointL = TableConstraint
-type instance TblConstraint PointR = TableConstraint
-type instance TblConstraint Subword = TableConstraint
+type instance TblConstraint (PointL t) = TableConstraint
+type instance TblConstraint (PointR t) = TableConstraint
+type instance TblConstraint (Subword t) = TableConstraint
diff --git a/ADP/Fusion/Base/Multi.hs b/ADP/Fusion/Base/Multi.hs
index 92729b8..d97ae0f 100644
--- a/ADP/Fusion/Base/Multi.hs
+++ b/ADP/Fusion/Base/Multi.hs
@@ -2,11 +2,15 @@
module ADP.Fusion.Base.Multi where
import qualified Data.Vector.Fusion.Stream.Monadic as S
+import Data.Vector.Fusion.Stream.Monadic
import Data.Strict.Tuple
+import Data.Proxy
+import Prelude hiding (map)
-import Data.PrimitiveArray
+import Data.PrimitiveArray hiding (map)
import ADP.Fusion.Base.Classes
+import ADP.Fusion.Base.TyLvlIx
@@ -30,6 +34,7 @@ instance Build (TermSymbol a b)
type family TermArg x :: *
type instance TermArg M = Z
+type instance TermArg (TermSymbol a b) = TermArg a :. TermArg b
instance (Element ls i) => Element (ls :!: TermSymbol a b) i where
data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !i !i !(Elm ls i)
@@ -46,13 +51,19 @@ instance
( Monad m
, MkStream m ls i
, Element ls i
- , TerminalStream m (TermSymbol a b) i
+-- , TerminalStream m (TermSymbol a b) i
, TermStaticVar (TermSymbol a b) i
+ , TermStream m (TermSymbol a b) i i
) => MkStream m (ls :!: TermSymbol a b) i where
mkStream (ls :!: ts) sv lu i
+ = map (\(TState sS _ _ ii oo ee) -> ElmTS ee ii oo sS)
+ . termStream ts sv lu i
+ {-
= S.map fromTerminalStream
. terminalStream ts sv i
. S.map toTerminalStream
+ -}
+ . map (\s -> TState s (getIdx s) (getOmx s) Z Z Z)
$ mkStream ls (termStaticVar ts sv i) lu (termStreamIndex ts sv i)
{-# Inline mkStream #-}
@@ -64,25 +75,14 @@ class TerminalStream m t i where
iPackTerminalStream a sv (ii:._) = terminalStream a sv ii . S.map (\(S5 s zi zo (is:.i) (os:.o) ) -> S5 s (zi:.i) (zo:.o) is os )
{-# Inline iPackTerminalStream #-}
-oPackTerminalStream a sv (O (is:.i)) = terminalStream a sv (O is) . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))
-{-# Inline oPackTerminalStream #-}
-
instance (Monad m) => TerminalStream m M Z where
terminalStream M _ Z = S.map (\(S5 s j1 j2 Z Z) -> S6 s j1 j2 Z Z Z)
{-# INLINE terminalStream #-}
-instance (Monad m) => TerminalStream m M (Outside Z) where
- terminalStream M _ (O Z) = S.map (\(S5 s j1 j2 (O Z) (O Z)) -> S6 s j1 j2 (O Z) (O Z) Z)
- {-# INLINE terminalStream #-}
-
instance Monad m => MkStream m S Z where
mkStream _ _ _ _ = S.singleton (ElmS Z Z)
{-# INLINE mkStream #-}
-instance Monad m => MkStream m S (Outside Z) where
- mkStream _ _ _ _ = S.singleton (ElmS (O Z) (O Z))
- {-# INLINE mkStream #-}
-
-- | For multi-dimensional terminals we need to be able to calculate how the
-- static/variable signal changes and if the index for the inner part needs to
-- be modified.
@@ -97,12 +97,6 @@ instance TermStaticVar M Z where
{-# INLINE termStaticVar #-}
{-# INLINE termStreamIndex #-}
-instance TermStaticVar M (Outside Z) where
- termStaticVar _ _ _ = Z
- termStreamIndex _ _ _ = O Z
- {-# INLINE termStaticVar #-}
- {-# INLINE termStreamIndex #-}
-
instance
( TermStaticVar a is
, TermStaticVar b i
@@ -112,23 +106,17 @@ instance
{-# INLINE termStaticVar #-}
{-# INLINE termStreamIndex #-}
-instance
- ( TermStaticVar a (Outside is)
- , TermStaticVar b (Outside i)
- ) => TermStaticVar (TermSymbol a b) (Outside (is:.i)) where
- termStaticVar (a:|b) (vs:.v) (O (is:.i)) = termStaticVar a vs (O is) :. termStaticVar b v (O i)
- termStreamIndex (a:|b) (vs:.v) (O (is:.i)) =
- let (O js) = termStreamIndex a vs (O is)
- (O j) = termStreamIndex b v (O i)
- in O (js:.j)
- {-# INLINE termStaticVar #-}
- {-# INLINE termStreamIndex #-}
+data S3 a b c = S3 !a !b !c
-data S4 a b c d = S4 !a !b !c !d
+data S4 a b c d = S4 !a !b !c !d
-data S5 a b c d e = S5 !a !b !c !d !e
+data S5 a b c d e = S5 !a !b !c !d !e
-data S6 a b c d e f = S6 !a !b !c !d !e !f
+data S6 a b c d e f = S6 !a !b !c !d !e !f
+
+data S7 a b c d e f g = S7 !a !b !c !d !e !f !g
+
+data S8 a b c d e f g h = S8 !a !b !c !d !e !f !g !h
fromTerminalStream (S6 s Z Z i o e) = ElmTS e i o s
{-# INLINE fromTerminalStream #-}
@@ -141,49 +129,82 @@ instance RuleContext Z where
initialContext _ = Z
{-# INLINE initialContext #-}
-instance RuleContext (Outside Z) where
- type Context (Outside Z) = Z
- initialContext _ = Z
- {-# INLINE initialContext #-}
-
instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where
type Context (is:.i) = Context is:.Context i
initialContext (is:.i) = initialContext is:.initialContext i
{-# INLINE initialContext #-}
-instance (RuleContext (Outside is), RuleContext (Outside i)) => RuleContext (Outside (is:.i)) where
- type Context (Outside (is:.i)) = Context (Outside is):.Context (Outside i)
- initialContext (O (is:.i)) = initialContext (O is):.initialContext (O i)
- {-# INLINE initialContext #-}
-
-class TableStaticVar i where
- tableStaticVar :: Context i -> i -> Context i
- tableStreamIndex :: TblConstraint i -> Context i -> i -> i
+class TableStaticVar u i where
+ tableStaticVar :: Proxy u -> TblConstraint u -> Context i -> i -> Context i
+ tableStreamIndex :: Proxy u -> TblConstraint u -> Context i -> i -> i
-instance TableStaticVar Z where
- tableStaticVar _ _ = Z
- tableStreamIndex _ _ _ = Z
+instance TableStaticVar u Z where
+ tableStaticVar _ _ _ _ = Z
+ tableStreamIndex _ _ _ _ = Z
{-# INLINE [0] tableStaticVar #-}
{-# INLINE [0] tableStreamIndex #-}
-instance TableStaticVar (Outside Z) where
- tableStaticVar _ _ = Z
- tableStreamIndex _ _ _ = O Z
+instance (TableStaticVar us is, TableStaticVar u i) => TableStaticVar (us:.u) (is:.i) where
+ tableStaticVar _ (cs:.c) (vs:.v) (is:.i) = tableStaticVar (Proxy :: Proxy us) cs vs is :. tableStaticVar (Proxy :: Proxy u) c v i
+ tableStreamIndex _ (cs:.c) (vs:.v) (is:.i) = tableStreamIndex (Proxy :: Proxy us) cs vs is :. tableStreamIndex (Proxy :: Proxy u) c v i
{-# INLINE [0] tableStaticVar #-}
{-# INLINE [0] tableStreamIndex #-}
-instance (TableStaticVar is, TableStaticVar i) => TableStaticVar (is:.i) where
- tableStaticVar (vs:.v) (is:.i) = tableStaticVar vs is :. tableStaticVar v i
- tableStreamIndex (cs:.c) (vs:.v) (is:.i) = tableStreamIndex cs vs is :. tableStreamIndex c v i
- {-# INLINE [0] tableStaticVar #-}
- {-# INLINE [0] tableStreamIndex #-}
-instance (TableStaticVar (Outside is), TableStaticVar (Outside i)) => TableStaticVar (Outside (is:.i)) where
- tableStaticVar (vs:.v) (O (is:.i)) = tableStaticVar vs (O is) :. tableStaticVar v (O i)
- tableStreamIndex (cs:.c) (vs:.v) (O (is:.i)) =
- let (O js) = tableStreamIndex cs vs (O is)
- (O j) = tableStreamIndex c v (O i)
- in O (js:.j)
- {-# INLINE [0] tableStaticVar #-}
- {-# INLINE [0] tableStreamIndex #-}
+
+data TermState s a i e = TState
+ { tS :: !s -- | state coming in from the left
+ , tIx :: !a -- | @I/C@ index from @sS@
+ , tOx :: !a -- | @O@ index from @sS@
+-- , tt :: !u -- | @I/C@ building up state to index the @table@.
+ , iIx :: !i -- | @I/C@ building up state to hand over to next symbol
+ , iOx :: !i -- | @O@ building up state to hand over to next symbol
+ , eTS :: !e -- | element data
+ }
+
+class TermStream m t a i where
+ termStream :: t -> Context i -> i -> i -> Stream m (TermState s a Z Z) -> Stream m (TermState s a i (TermArg t))
+
+instance TermStream m M a Z where
+ termStream _ _ _ _ = id
+ {-# Inline termStream #-}
+
+-- |
+--
+-- TODO need @t -> ElmType t@ type function
+--
+-- TODO need to actually return an @ElmType t@ can do that instead of
+-- returning @u@ !!!
+
+addTermStream1
+ :: ( Monad m
+ , TermStream m (TermSymbol M t) (Z:.a) (Z:.i)
+ , s ~ Elm x0 a
+ , Element x0 a
+ )
+ => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,i,i)
+addTermStream1 t c u i
+ = map (\(TState sS _ _ (Z:.ii) (Z:.oo) (Z:.ee)) -> (sS,ee,ii,oo))
+ . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i)
+ . map (\s -> TState s (Z:.getIdx s) (Z:.getOmx s) Z Z Z)
+{-# Inline addTermStream1 #-}
+
+-- | @Term MkStream@ context
+
+type TmkCtx1 m ls t i
+ = ( Monad m
+ , MkStream m ls i
+ , TermStream m (TermSymbol M t) (Z:.i) (Z:.i)
+ , Element ls i
+ , TermStaticVar t i
+ )
+
+-- | @Term TermStream@ context
+
+type TstCtx1 m ts a is i
+ = ( Monad m
+ , TermStream m ts a is
+ , GetIndex a (is:.i)
+ , GetIx a (is:.i) ~ i
+ )
diff --git a/ADP/Fusion/Base/Point.hs b/ADP/Fusion/Base/Point.hs
index e85fb75..b9c7cff 100644
--- a/ADP/Fusion/Base/Point.hs
+++ b/ADP/Fusion/Base/Point.hs
@@ -1,8 +1,7 @@
module ADP.Fusion.Base.Point where
-import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..),flatten)
-import Data.Vector.Fusion.Stream.Size
+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))
import Debug.Trace
import Prelude hiding (map,filter)
@@ -13,35 +12,35 @@ import ADP.Fusion.Base.Multi
-instance RuleContext PointL where
- type Context PointL = InsideContext Int
+instance RuleContext (PointL I) where
+ type Context (PointL I) = InsideContext Int
initialContext _ = IStatic 0
{-# Inline initialContext #-}
-instance RuleContext (Outside PointL) where
- type Context (Outside PointL) = OutsideContext Int
+instance RuleContext (PointL O) where
+ type Context (PointL O) = OutsideContext Int
initialContext _ = OStatic 0
{-# Inline initialContext #-}
-instance RuleContext (Complement PointL) where
- type Context (Complement PointL) = ComplementContext
+instance RuleContext (PointL C) where
+ type Context (PointL C) = ComplementContext
initialContext _ = Complemented
{-# Inline initialContext #-}
-instance (Monad m) => MkStream m S PointL where
+instance (Monad m) => MkStream m S (PointL I) where
mkStream S (IStatic d) (PointL u) (PointL j)
= staticCheck (j>=0 && j<=d) . singleton $ ElmS (PointL 0) (PointL 0)
mkStream S (IVariable _) (PointL u) (PointL j)
= staticCheck (0<=j) . singleton $ ElmS (PointL 0) (PointL 0)
{-# Inline mkStream #-}
-instance (Monad m) => MkStream m S (Outside PointL) where
- mkStream S (OStatic d) (O (PointL u)) (O (PointL i))
- = staticCheck (i>=0 && i+d<=u && u == i) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)
- mkStream S (OFirstLeft d) (O (PointL u)) (O (PointL i))
- = staticCheck (i>=0 && i+d<=u) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)
+instance (Monad m) => MkStream m S (PointL O) where
+ mkStream S (OStatic d) (PointL u) (PointL i)
+ = staticCheck (i>=0 && i+d<=u && u == i) . singleton $ ElmS (PointL i) (PointL $ i+d)
+ mkStream S (OFirstLeft d) (PointL u) (PointL i)
+ = staticCheck (i>=0 && i+d<=u) . singleton $ ElmS (PointL i) (PointL $ i+d)
{-# Inline mkStream #-}
@@ -49,8 +48,8 @@ instance (Monad m) => MkStream m S (Outside PointL) where
instance
( Monad m
, MkStream m S is
- , Context (is:.PointL) ~ (Context is:.(InsideContext Int))
- ) => MkStream m S (is:.PointL) where
+-- , Context (is:.PointL) ~ (Context is:.(InsideContext Int))
+ ) => MkStream m S (is:.PointL I) where
mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i)
= staticCheck (i>=0 && i<=d && i<=u)
. map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))
@@ -76,37 +75,37 @@ instance
instance
( Monad m
- , MkStream m S (Outside is)
- , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)
- ) => MkStream m S (Outside (is:.PointL)) where
- mkStream S (vs:.OStatic d) (O (lus:.PointL u)) (O (is:.PointL i))
+ , MkStream m S is
+-- , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)
+ ) => MkStream m S (is:.PointL O) where
+ mkStream S (vs:.OStatic d) (lus:.PointL u) (is:.PointL i)
= staticCheck (i>=0 && i+d == u)
- . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))
- $ mkStream S vs (O lus) (O is)
- mkStream S (vs:.OFirstLeft d) (O (us:.PointL u)) (O (is:.PointL i))
+ . map (\(ElmS zi zo) -> ElmS (zi:.PointL i) (zo:.(PointL $ i+d)))
+ $ mkStream S vs lus is
+ mkStream S (vs:.OFirstLeft d) (us:.PointL u) (is:.PointL i)
= staticCheck (i>=0 && i+d<=u)
- . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))
- $ mkStream S vs (O us) (O is)
+ . map (\(ElmS zi zo) -> ElmS (zi:.PointL i) (zo:.(PointL $ i+d)))
+ $ mkStream S vs us is
{-# Inline mkStream #-}
-instance TableStaticVar PointL where
- tableStaticVar (IStatic d) _ = IVariable d
- tableStaticVar (IVariable d) _ = IVariable d
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (PointL I) where
+ tableStaticVar _ _ (IStatic d) _ = IVariable d
+ tableStaticVar _ _ (IVariable d) _ = IVariable d
-- NOTE this code used to destroy fusion. If we inline tableStreamIndex
-- very late (after 'mkStream', probably) then everything works out.
- tableStreamIndex c _ (PointL j)
+ tableStreamIndex _ c _ (PointL j)
| c==EmptyOk = PointL j
| c==NonEmpty = PointL $ j-1
| c==OnlyZero = PointL j -- this should then actually request a size in 'tableStaticVar' ...
{-# INLINE [0] tableStaticVar #-}
{-# INLINE [0] tableStreamIndex #-}
-instance TableStaticVar (Outside PointL) where
- tableStaticVar (OStatic d) _ = OFirstLeft d
- tableStreamIndex c _ (O (PointL j))
- | c==EmptyOk = O (PointL j)
- | c==NonEmpty = O (PointL $ j-1)
- | c==OnlyZero = O (PointL j) -- this should then actually request a size in 'tableStaticVar' ...
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (PointL O) where
+ tableStaticVar _ _ (OStatic d) _ = OFirstLeft d
+ tableStreamIndex _ c _ (PointL j)
+ | c==EmptyOk = (PointL j)
+ | c==NonEmpty = (PointL $ j-1)
+ | c==OnlyZero = (PointL j) -- this should then actually request a size in 'tableStaticVar' ...
{-# INLINE [0] tableStaticVar #-}
{-# INLINE [0] tableStreamIndex #-}
diff --git a/ADP/Fusion/Base/Set.hs b/ADP/Fusion/Base/Set.hs
index 824ac98..2b2fc30 100644
--- a/ADP/Fusion/Base/Set.hs
+++ b/ADP/Fusion/Base/Set.hs
@@ -6,52 +6,57 @@
module ADP.Fusion.Base.Set where
import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)
-import Data.Vector.Fusion.Stream.Size
import Debug.Trace
import Prelude hiding (map,filter)
import Data.Bits
+import Data.Bits.Ordered
-import Data.PrimitiveArray
+import Data.PrimitiveArray hiding (map)
import ADP.Fusion.Base.Classes
import ADP.Fusion.Base.Multi
-type instance TblConstraint BitSet = TableConstraint
-type instance TblConstraint (BitSet:>Interface i:>Interface j) = TableConstraint
+type instance TblConstraint (BitSet t) = TableConstraint
+type instance TblConstraint (BS2 i j t) = TableConstraint
-instance RuleContext BitSet where
- type Context BitSet = InsideContext Int
+instance RuleContext (BitSet I) where
+ type Context (BitSet I) = InsideContext Int
initialContext _ = IStatic 0
{-# Inline initialContext #-}
-instance RuleContext (Outside BitSet) where
- type Context (Outside BitSet) = OutsideContext ()
- initialContext _ = OStatic ()
+-- | The @Int@ in an @OutsideContext@ counts how many bits need to be fixed
+-- statically. I.e. if the bits @{1,2}@ are set in @X -> Y t@, and @t@ has
+-- size @1@, then @Y@ will have @{1,2,3}@, @{1,2,4}@ and so on, with @t@
+-- having @3, 4, ...@ as values.
+
+instance RuleContext (BitSet O) where
+ type Context (BitSet O) = OutsideContext Int
+ initialContext _ = OStatic 0
{-# Inline initialContext #-}
-instance RuleContext (Complement BitSet) where
- type Context (Complement BitSet) = ComplementContext
+instance RuleContext (BitSet C) where
+ type Context (BitSet C) = ComplementContext
initialContext _ = Complemented
{-# Inline initialContext #-}
-instance RuleContext (BS2I First Last) where
- type Context (BS2I First Last) = InsideContext Int
+instance RuleContext (BS2 First Last I) where
+ type Context (BS2 First Last I) = InsideContext Int
initialContext _ = IStatic 0
{-# Inline initialContext #-}
-instance RuleContext (Outside (BS2I First Last)) where
- type Context (Outside (BS2I First Last)) = OutsideContext ()
+instance RuleContext (BS2 First Last O) where
+ type Context (BS2 First Last O) = OutsideContext ()
initialContext _ = OStatic ()
{-# Inline initialContext #-}
-instance RuleContext (Complement (BS2I First Last)) where
- type Context (Complement (BS2I First Last)) = ComplementContext
+instance RuleContext (BS2 First Last C) where
+ type Context (BS2 First Last C) = ComplementContext
initialContext _ = Complemented
{-# Inline initialContext #-}
@@ -59,44 +64,102 @@ instance RuleContext (Complement (BS2I First Last)) where
instance
( Monad m
- ) => MkStream m S BitSet where
- mkStream S (IStatic c) u s
- = staticCheck (c <= popCount s) . singleton $ ElmS s 0
- mkStream S (IVariable c) u s
- = staticCheck (c <= popCount s) . singleton $ ElmS 0 0
+ ) => MkStream m S (BitSet I) where
+ -- | We enumerate all sets that have @popCount s - rb@ bits. Since we are
+ -- @IStatic@ we only have static objects following. These will fill in
+ -- the missing bits. Each object will fill a fixed number of bits, until
+ -- @s@ has been recovered. Otherwise we would have an @IVariable@
+ -- context.
+ mkStream S (IStatic rb) u s
+ = staticCheck (rb <= ps) . map (\k -> ElmS (popShiftL s k) 0) $ unfoldr go strt
+ where strt = Just $ BitSet $ 2^(ps - rb) - 1
+ ps = popCount s
+ go Nothing = Nothing
+ go (Just k) = Just $ (k, popPermutation ps k)
+ -- | Once we are variable, we do not reserve any bits, just check that
+ -- the total reservation (if any) works.
+ mkStream S (IVariable rb) u s
+ = staticCheck (rb <= popCount s) . singleton $ ElmS 0 0
{-# Inline mkStream #-}
+-- | Initial index construction for outside Bitsets. Bits set to @0@
+-- indicate hole-space. The last bitset, the one accessed by @axiom@, is
+-- @BitSet 0@.
+--
+-- We need to be careful with reserved bits! Reserved bits are @0@ bits
+-- that can be switched to @1@. This means that @rb@ + popCount s <=
+-- popCount u@.
+--
+-- @OStatic@'s happen when we only have terminals on the r.h.s. That is,
+-- with @X -> end@.
+--
+-- TODO test all of this via quickcheck!
+
+instance
+ ( Monad m
+ ) => MkStream m S (BitSet O) where
+ -- | Same argument as above for @BitSet O@ construction.
+ mkStream S (OStatic rb) u s
+ = staticCheck (rb + popCount s <= popCount u) . singleton $ ElmS s s
+ mkStream S (ORightOf _) u s
+ = error "ADP.Fusion.Base.Set: Entered ORightOf/BitSet (this is probably wrong because it means we have an outside cfg with only terminals on the r.h.s, and the terminals are not a single Outside-Epsilon)"
+ mkStream S (OFirstLeft rb) u s
+ = staticCheck (rb + popCount s <= popCount u) . singleton $ ElmS s s
+-- mkStream S (OLeftOf rp) u s
+-- = staticCheck (popCount s + rp <= popCount u) . singleton $ ElmS s s
+ {-# Inline mkStream #-}
+instance
+ ( Monad m
+ ) => MkStream m S (BitSet C) where
instance
( Monad m
- ) => MkStream m S (BS2I First Last) where
- mkStream S (IStatic rp) u sij@(s:>Iter i:>j)
- = staticCheck (popCount s == 0 && rp == 0) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i
- mkStream S (IVariable rp) u sij@(s:>Iter i:>j)
- = staticCheck (popCount s >= rp) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i
+ ) => MkStream m S (BS2 First Last I) where
+ mkStream S (IStatic rp) u sij@(BS2 s (Iter i) _)
+ = staticCheck (popCount s == 0 && rp == 0) . singleton $ ElmS (BS2 0 (Iter i) (Iter i)) undefbs2i
+ mkStream S (IVariable rp) u sij@(BS2 s (Iter i) _)
+ = staticCheck (popCount s >= rp) . singleton $ ElmS (BS2 0 (Iter i) (Iter i)) undefbs2i
{-# Inline mkStream #-}
instance
( Monad m
- ) => MkStream m S (Outside (BS2I First Last)) where
+ ) => MkStream m S (BS2 First Last O) where
instance
( Monad m
- ) => MkStream m S (Complement (BS2I First Last)) where
+ ) => MkStream m S (BS2 First Last C) where
-- | An undefined bitset with 2 interfaces.
-undefbs2i :: BS2I f l
-undefbs2i = (-1) :> (-1) :> (-1)
+undefbs2i :: BS2 f l t
+undefbs2i = BS2 (-1) (-1) (-1)
{-# Inline undefbs2i #-}
undefi :: Interface i
undefi = (-1)
{-# Inline undefi #-}
+instance TableStaticVar (u O) (BitSet O) where
+ tableStaticVar _ _ (OStatic d) _ = OFirstLeft d
+ tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d
+ tableStreamIndex _ c _ bs = bs
+ {-# INLINE [0] tableStaticVar #-}
+ {-# INLINE [0] tableStreamIndex #-}
+
+instance TableStaticVar (u I) (BitSet O) where
+
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (BitSet I) where
+ tableStaticVar _ c (IStatic d) _ = IVariable $ d - minSize c -- TODO rly?
+ tableStaticVar _ _ (IVariable d) _ = IVariable $ d
+ tableStreamIndex _ c _ bitSet = bitSet -- TODO rly?
+ {-# INLINE [0] tableStaticVar #-}
+ {-# INLINE [0] tableStreamIndex #-}
+
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (BS2 i j I) where
+
-- | We sometimes need
data ThisThatNaught a b = This a | That b | Naught
diff --git a/ADP/Fusion/Base/Subword.hs b/ADP/Fusion/Base/Subword.hs
index 829b126..cccaafb 100644
--- a/ADP/Fusion/Base/Subword.hs
+++ b/ADP/Fusion/Base/Subword.hs
@@ -5,7 +5,6 @@
module ADP.Fusion.Base.Subword where
import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)
-import Data.Vector.Fusion.Stream.Size
import Debug.Trace
import Prelude hiding (map,filter)
@@ -16,55 +15,62 @@ import ADP.Fusion.Base.Multi
-instance RuleContext Subword where
- type Context Subword = InsideContext ()
+instance RuleContext (Subword I) where
+ type Context (Subword I) = InsideContext ()
initialContext _ = IStatic ()
{-# Inline initialContext #-}
-instance RuleContext (Outside Subword) where
- type Context (Outside Subword) = OutsideContext (Int:.Int)
+instance RuleContext (Subword O) where
+ type Context (Subword O) = OutsideContext (Int:.Int)
initialContext _ = OStatic (0:.0)
{-# Inline initialContext #-}
-instance RuleContext (Complement Subword) where
- type Context (Complement Subword) = ComplementContext
+instance RuleContext (Subword C) where
+ type Context (Subword C) = ComplementContext
initialContext _ = Complemented
{-# Inline initialContext #-}
--- TODO write instance
--- instance RuleContext (Complement Subword)
+-- | NOTE it seems that a static check within an @IVariable@ context
+-- destroys fusion; maybe because of the outer flatten? We don't actually
+-- need a static check anyway because the next flatten takes care of
+-- conditional checks. @filter@ on the other hand, does work.
+--
+-- TODO test with and without filter using quickcheck
+--
+-- TODO shouldn't the new @staticCheck@ impl handle this?
-
-instance (Monad m) => MkStream m S Subword where
+instance (Monad m) => MkStream m S (Subword I) where
mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j))
- = staticCheck (i>=0 && i==j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)
- -- NOTE it seems that a static check within an @IVariable@ context
- -- destroys fusion; maybe because of the outer flatten? We don't actually
- -- need a static check anyway because the next flatten takes care of
- -- conditional checks. @filter@ on the other hand, does work.
- -- TODO test with and without filter using quickcheck
+ = staticCheck (i>=0 && i==j && j<=h)
+ . singleton
+ $ ElmS (subword i i) (subword 0 0)
mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j))
= filter (const $ 0<=i && i<=j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)
{-# Inline mkStream #-}
-instance (Monad m) => MkStream m S (Outside Subword) where
- mkStream S (OStatic (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
- = staticCheck (i==0 && j+dj==h) . singleton $ ElmS (O $ subword i j) (O $ Subword (i:.j+dj))
- mkStream S (OFirstLeft (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
+instance (Monad m) => MkStream m S (Subword O) where
+ mkStream S (OStatic (di:.dj)) (Subword (_:.h)) (Subword (i:.j))
+ = staticCheck (i==0 && j+dj==h) . singleton $ ElmS (subword i j) (Subword (i:.j+dj))
+ mkStream S (OFirstLeft (di:.dj)) (Subword (_:.h)) (Subword (i:.j))
= let i' = i-di
- in staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton $ ElmS (O $ subword i' i') (O $ subword i' i')
- mkStream S (OLeftOf (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
+ in staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton $ ElmS (subword i' i') (subword i' i')
+ mkStream S (OLeftOf (di:.dj)) (Subword (_:.h)) (Subword (i:.j))
= let i' = i-di
in staticCheck (0 <= i' && i<=j && j+dj<=h)
- $ map (\k -> ElmS (O $ subword 0 k) (O $ subword k j))
+ $ map (\k -> ElmS (subword 0 k) (subword k j))
$ enumFromStepN 0 1 (i'+1)
+ mkStream S e _ _ = error $ show e ++ "maybe only inside syntactic terminals on the RHS of an outside rule?" -- TODO mostly because I'm not sure if that would be useful
{-# Inline mkStream #-}
-instance (Monad m) => MkStream m S (Complement Subword) where
- mkStream S Complemented (C (Subword (_:.h))) (C (Subword (i:.j)))
- = map (\(k,l) -> ElmS (C $ subword k l) (C $ subword k l))
+-- |
+--
+-- TODO The @go@ here needs an explanation.
+
+instance (Monad m) => MkStream m S (Subword C) where
+ mkStream S Complemented (Subword (_:.h)) (Subword (i:.j))
+ = map (\(k,l) -> ElmS (subword k l) (subword k l))
$ unfoldr go (i,i)
where go (k,l)
| k >h || k >j = Nothing
@@ -78,8 +84,8 @@ instance (Monad m) => MkStream m S (Complement Subword) where
instance
( Monad m
, MkStream m S is
- , Context (is:.Subword) ~ (Context is:.(InsideContext ()))
- ) => MkStream m S (is:.Subword) where
+-- , Context (is:.Subword) ~ (Context is:.(InsideContext ()))
+ ) => MkStream m S (is:.Subword I) where
mkStream S (vs:.IStatic ()) (lus:.Subword (_:.h)) (ixs:.Subword(i:.j))
= staticCheck (i>=0 && i==j && j<=h)
. map (\(ElmS zi zo) -> ElmS (zi:.subword i i) (zo:.subword 0 0))
@@ -90,13 +96,51 @@ instance
$ mkStream S vs lus ixs
{-# Inline mkStream #-}
-instance TableStaticVar Subword where
- tableStaticVar (IStatic d) _ = IVariable d
- tableStaticVar (IVariable d) _ = IVariable d
- tableStreamIndex c _ (Subword (i:.j))
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Subword I) where
+ tableStaticVar _ _ (IStatic d) _ = IVariable d
+ tableStaticVar _ _ (IVariable d) _ = IVariable d
+ tableStreamIndex _ c _ (Subword (i:.j))
| c==EmptyOk = subword i j
| c==NonEmpty = subword i (j-1)
| c==NonEmpty = error "A.F.B.Subword ???"
{-# INLINE [0] tableStaticVar #-}
{-# INLINE [0] tableStreamIndex #-}
+-- | This instance is chosen if we consider an outside table (i.e.
+-- a syntactic variable) in an outside index.
+--
+-- TODO @tableStreamIndex@ needs to be fixed
+
+instance TableStaticVar (u O) (Subword O) where
+ tableStaticVar _ _ (OStatic d) _ = OFirstLeft d
+ tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d
+ tableStreamIndex _ c _ (Subword (i:.j)) = subword i j
+ {-# INLINE [0] tableStaticVar #-}
+ {-# INLINE [0] tableStreamIndex #-}
+
+-- | This instance is chosen if we consider an inside table (i.e.
+-- a terminal symbol!) in an outside index.
+--
+-- TODO @tableStreamIndex@ needs to be fixed
+
+instance TableStaticVar (u I) (Subword O) where
+ tableStaticVar _ _ (OStatic d) _ = ORightOf d
+ tableStaticVar _ _ (ORightOf d) _ = ORightOf d
+ tableStaticVar _ _ (OFirstLeft d) _ = OLeftOf d
+ tableStaticVar _ _ (OLeftOf d) _ = OLeftOf d
+ tableStreamIndex _ c _ (Subword (i:.j)) = subword i j
+ {-# INLINE [0] tableStaticVar #-}
+ {-# INLINE [0] tableStreamIndex #-}
+
+instance TableStaticVar (u I) (Subword C) where
+ tableStaticVar _ _ _ _ = Complemented
+ tableStreamIndex _ c _ (Subword (i:.j)) = subword i j
+ {-# INLINE [0] tableStaticVar #-}
+ {-# INLINE [0] tableStreamIndex #-}
+
+instance TableStaticVar (u O) (Subword C) where
+ tableStaticVar _ _ _ _ = Complemented
+ tableStreamIndex _ c _ (Subword (i:.j)) = subword i j
+ {-# INLINE [0] tableStaticVar #-}
+ {-# INLINE [0] tableStreamIndex #-}
+
diff --git a/ADP/Fusion/Base/Term.hs b/ADP/Fusion/Base/Term.hs
new file mode 100644
index 0000000..91c1391
--- /dev/null
+++ b/ADP/Fusion/Base/Term.hs
@@ -0,0 +1,55 @@
+
+module ADP.Fusion.Base.Term where
+
+{-
+
+import Data.Vector.Fusion.Stream.Monadic
+import Prelude hiding (map)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base.Classes
+import ADP.Fusion.Base.Multi
+
+
+
+data TermState s a i e = TState
+ { sS :: !s -- | state coming in from the left
+ , sIx :: !a -- | @I/C@ index from @sS@
+ , sOx :: !a -- | @O@ index from @sS@
+-- , tt :: !u -- | @I/C@ building up state to index the @table@.
+ , iIx :: !i -- | @I/C@ building up state to hand over to next symbol
+ , iOx :: !i -- | @O@ building up state to hand over to next symbol
+ , eTS :: !e -- | element data
+ }
+
+class TermStream m t a i where
+ termStream :: t -> Context i -> i -> i -> Stream m (TermState s a Z Z) -> Stream m (TermState s a i (TermArg t))
+
+instance TermStream m M a Z where
+ termStream _ _ _ _ = id
+ {-# Inline termStream #-}
+
+-- |
+--
+-- TODO need @t -> ElmType t@ type function
+--
+-- TODO need to actually return an @ElmType t@ can do that instead of
+-- returning @u@ !!!
+
+addTermStream1
+ :: ( Monad m
+ , TermStream m (TermSymbol M t) (Z:.a) (Z:.i)
+ , s ~ Elm x0 a
+ , Element x0 a
+ )
+ => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,i,i)
+addTermStream1 t c u i
+ = map (\(TState sS _ _ (Z:.ii) (Z:.oo) (Z:.ee)) -> (sS,ee,ii,oo))
+ . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i)
+ . map (\s -> TState s (Z:.getIdx s) (Z:.getOmx s) Z Z Z)
+{-# Inline addTermStream1 #-}
+
+
+-}
+
diff --git a/ADP/Fusion/Base/TyLvlIx.hs b/ADP/Fusion/Base/TyLvlIx.hs
new file mode 100644
index 0000000..e03336f
--- /dev/null
+++ b/ADP/Fusion/Base/TyLvlIx.hs
@@ -0,0 +1,77 @@
+
+-- | Type-level indexing functionality
+
+module ADP.Fusion.Base.TyLvlIx where
+
+import Data.Proxy
+import GHC.TypeLits
+
+import Data.PrimitiveArray hiding (map)
+
+
+
+-- | Given some complete index list @ixTy@ and some lower-dimensional
+-- version @myTy@, walk down along @ixTy@ until we have @is:.i ~ ms:.m@ and
+-- return @m@.
+
+class GetIndexGo ixTy myTy (cmp :: Ordering) where
+ type ResolvedIx ixTy myTy cmp :: *
+ getIndexGo :: ixTy -> (Proxy myTy) -> (Proxy cmp) -> ResolvedIx ixTy myTy cmp
+
+instance GetIndexGo (ix:.i) (my:.m) EQ where
+ type ResolvedIx (ix:.i) (my:.m) EQ = i
+ getIndexGo (ix:.i) _ _ = i
+ {-# Inline getIndexGo #-}
+
+instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where
+ type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))
+ getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m))))
+ {-# Inline getIndexGo #-}
+
+instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where
+ type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z))
+ getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z)))
+ {-# Inline getIndexGo #-}
+
+instance GetIndexGo Z Z EQ where
+ type ResolvedIx Z Z EQ = Z
+ getIndexGo _ _ _ = Z
+ {-# Inline getIndexGo #-}
+
+-- | Wrap @GetIndexGo@ and the type-level shenanigans.
+
+type GetIndex l r = GetIndexGo l r (CmpNat (ToNat l) (ToNat r))
+
+type GetIx l r = ResolvedIx l r (CmpNat (ToNat l) (ToNat r))
+
+-- | Simplifying wrapper around @getIndexGo@.
+
+getIndex
+ :: forall ixTy myTy
+ . GetIndex ixTy myTy
+ => ixTy
+ -> Proxy myTy
+ -> GetIx ixTy myTy
+getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy)))
+{-# Inline getIndex #-}
+
+
+
+-- | Given some index structure @x@, return the dimensional number in
+-- @Nat@s.
+
+type family ToNat x :: Nat
+
+type instance ToNat Z = 0
+type instance ToNat (is:.i) = ToNat is + 1
+
+
+
+{-
+
+testggg :: (Z:.Int:.Char) -> Int
+testggg ab = getIndex ab (Proxy :: Proxy (Z:.Int)) -- (Z:.(3::Int))
+{-# NoInline testggg #-}
+
+-}
+
diff --git a/ADP/Fusion/Base/Unit.hs b/ADP/Fusion/Base/Unit.hs
new file mode 100644
index 0000000..e992dc7
--- /dev/null
+++ b/ADP/Fusion/Base/Unit.hs
@@ -0,0 +1,96 @@
+
+-- |
+--
+-- TODO the 'mkStream' instances here are probably wonky for everything
+-- that is non-static.
+
+module ADP.Fusion.Base.Unit where
+
+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..))
+import Debug.Trace
+import Prelude hiding (map,filter)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base.Classes
+import ADP.Fusion.Base.Multi
+
+
+
+instance RuleContext (Unit I) where
+ type Context (Unit I) = InsideContext ()
+ initialContext _ = IStatic ()
+ {-# Inline initialContext #-}
+
+instance RuleContext (Unit O) where
+ type Context (Unit O) = OutsideContext ()
+ initialContext _ = OStatic ()
+ {-# Inline initialContext #-}
+
+instance RuleContext (Unit C) where
+ type Context (Unit C) = ComplementContext
+ initialContext _ = Complemented
+ {-# Inline initialContext #-}
+
+
+
+instance (Monad m) => MkStream m S (Unit I) where
+ mkStream S _ Unit Unit = singleton $ ElmS Unit Unit
+ {-# Inline mkStream #-}
+
+instance (Monad m) => MkStream m S (Unit O) where
+ mkStream S _ Unit Unit = singleton $ ElmS Unit Unit
+ {-# Inline mkStream #-}
+
+instance (Monad m) => MkStream m S (Unit C) where
+ mkStream S _ Unit Unit = singleton $ ElmS Unit Unit
+ {-# Inline mkStream #-}
+
+instance
+ ( Monad m
+ , MkStream m S is
+ ) => MkStream m S (is:.Unit I) where
+ mkStream S (vs:._) (us:._) (is:._)
+ = map (\(ElmS zi zo) -> ElmS (zi:.Unit) (zo:.Unit))
+ $ mkStream S vs us is
+ {-# Inline mkStream #-}
+
+instance
+ ( Monad m
+ , MkStream m S is
+ ) => MkStream m S (is:.Unit O) where
+ mkStream S (vs:._) (us:._) (is:._)
+ = map (\(ElmS zi zo) -> ElmS (zi:.Unit) (zo:.Unit))
+ $ mkStream S vs us is
+ {-# Inline mkStream #-}
+
+instance
+ ( Monad m
+ , MkStream m S is
+ ) => MkStream m S (is:.Unit C) where
+ mkStream S (vs:._) (us:._) (is:._)
+ = map (\(ElmS zi zo) -> ElmS (zi:.Unit) (zo:.Unit))
+ $ mkStream S vs us is
+ {-# Inline mkStream #-}
+
+
+
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit I) where
+ tableStaticVar _ _ _ _ = IStatic ()
+ tableStreamIndex _ _ _ _ = Unit
+ {-# Inline [0] tableStaticVar #-}
+ {-# Inline [0] tableStreamIndex #-}
+
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit O) where
+ tableStaticVar _ _ _ _ = OStatic ()
+ tableStreamIndex _ _ _ _ = Unit
+ {-# Inline [0] tableStaticVar #-}
+ {-# Inline [0] tableStreamIndex #-}
+
+instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit C) where
+ tableStaticVar _ _ _ _ = Complemented
+ tableStreamIndex _ _ _ _ = Unit
+ {-# Inline [0] tableStaticVar #-}
+ {-# Inline [0] tableStreamIndex #-}
+
+
diff --git a/ADP/Fusion/QuickCheck/Set.hs b/ADP/Fusion/QuickCheck/Set.hs
deleted file mode 100644
index b81eb90..0000000
--- a/ADP/Fusion/QuickCheck/Set.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-
-{-# Options_GHC -O0 #-}
-
-module ADP.Fusion.QuickCheck.Set where
-
-import Data.Bits
-import Data.Vector.Fusion.Util
-import Debug.Trace
-import qualified Data.List as L
-import qualified Data.Vector.Fusion.Stream as S
-import qualified Data.Vector.Unboxed as VU
-import Test.QuickCheck hiding (NonEmpty)
-import Test.QuickCheck.All
-import Test.QuickCheck.Monadic
-
-import Data.Bits.Ordered
-import Data.PrimitiveArray
-
-import ADP.Fusion
-import ADP.Fusion.QuickCheck.Common
-
-
-
--- * BitSets without interfaces
-
--- ** Inside checks
-
-prop_b_ii ix@(BitSet _) = zs == ls where
- tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
- tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
- zs = ((,) <<< tia % tib ... S.toList) highestB ix
- ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
- | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
- , let kk = popShiftL ix (BitSet k)
- ]
-
-prop_b_ii_nn ix@(BitSet _) = zs == ls where
- tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
- tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
- zs = ((,) <<< tia % tib ... S.toList) highestB ix
- ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
- | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
- , let kk = popShiftL ix (BitSet k)
- , popCount kk > 0
- , popCount (ix `xor` kk) > 0
- ]
-
-prop_b_iii ix@(BitSet _) = zs == ls where
- tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
- tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
- tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
- zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix
- ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
- | k <- VU.toList . popCntSorted $ popCount ix
- , l <- VU.toList . popCntSorted $ popCount ix - popCount k
- , let kk = popShiftL ix (BitSet k)
- , let ll = popShiftL (ix `xor` kk) (BitSet l)
- , let mm = (ix `xor` (kk .|. ll))
- ]
-
-prop_b_iii_nnn ix@(BitSet _) = zs == ls where
- tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
- tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
- tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
- zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix
- ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
- | k <- VU.toList . popCntSorted $ popCount ix
- , l <- VU.toList . popCntSorted $ popCount ix - popCount k
- , let kk = popShiftL ix (BitSet k)
- , let ll = popShiftL (ix `xor` kk) (BitSet l)
- , let mm = (ix `xor` (kk .|. ll))
- , popCount kk > 0, popCount ll > 0, popCount mm > 0
- ]
-
-
--- * Outside checks
--- These checks are very similar to those in the @Subword@ module. We just
--- need to be a bit more careful, as indexed sets have overlap.
-
--- ** Two non-terminals.
---
--- @A_s -> B_(s\t) C_t (s\t) ++ t == s@
--- @s = 111 , s\t = 101, t = 010@
---
--- with @Z@ the full set.
--- @Z = 1111@
-
--- @B*_Z\(s\t) -> A*_Z\s C_t@
--- @Z\(s\t) = 1010, Z\s = 1000, t = 010@
-
-
-
-
--- * BitSets with two interfaces
-
--- ** Inside checks
-
-prop_bii_i :: BS2I First Last -> Bool
-prop_bii_i ix@(s:>i:>j) = zs == ls where
- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
- zs = (id <<< tia ... S.toList) highestBII ix
- ls = [ xsBII ! ix ]
-
-prop_bii_i_n :: BS2I First Last -> Bool
-prop_bii_i_n ix@(s:>i:>j) = zs == ls where
- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
- zs = (id <<< tia ... S.toList) highestBII ix
- ls = [ xsBII ! ix | popCount s > 0 ]
-
--- | Edges should never work as a single terminal element.
-
-prop_bii_e :: BS2I First Last -> Bool
-prop_bii_e ix@(s:>Iter i:>Iter j) = zs == ls where
- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
- zs = (id <<< e ... S.toList) highestBII ix
- ls = [] :: [ (Int,Int) ]
-
--- | Edges extend only in cases where in @i -> j@, @i@ actually happens to
--- be a true interface.
-
-prop_bii_ie :: BS2I First Last -> Bool
-prop_bii_ie ix@(s:>i:>Iter j) = zs == ls where
- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
- zs = ((,) <<< tia % e ... S.toList) highestBII ix
- ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )
- | let t = s `clearBit` j
- , k <- activeBitsL t ]
-
-prop_bii_ie_n :: BS2I First Last -> Bool
-prop_bii_ie_n ix@(s:>i:>Iter j) = zs == ls where
- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
- zs = ((,) <<< tia % e ... S.toList) highestBII ix
- ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )
- | let t = s `clearBit` j
- , popCount t >= 2
- , k <- activeBitsL t
- , k /= getIter i
- ]
-
-prop_bii_iee :: BS2I First Last -> Bool
-prop_bii_iee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
- zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix
- ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )
- | let tmp = (s `clearBit` j)
- , l <- activeBitsL tmp
- , l /= getIter i
- , let t = tmp `clearBit` l
- , k <- activeBitsL t
- , let kk = Iter k
- ]
-
-prop_bii_ieee :: BS2I First Last -> Bool
-prop_bii_ieee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
- zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix
- ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )
- | let tmpM = (s `clearBit` j)
- , m <- activeBitsL tmpM
- , m /= getIter i
- , let tmpL = (tmpM `clearBit` m)
- , l <- activeBitsL tmpL
- , l /= getIter i
- , let t = tmpL `clearBit` l
- , k <- activeBitsL t
- , let kk = Iter k
- ]
-
-prop_bii_iee_n :: BS2I First Last -> Bool
-prop_bii_iee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
- zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix
- ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )
- | let tmp = (s `clearBit` j)
- , l <- activeBitsL tmp
- , l /= getIter i
- , let t = tmp `clearBit` l
- , popCount t >= 2
- , k <- activeBitsL t
- , k /= getIter i
- , let kk = Iter k
- ]
-
-prop_bii_ieee_n :: BS2I First Last -> Bool
-prop_bii_ieee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
- zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix
- ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )
- | let tmpM = (s `clearBit` j)
- , m <- activeBitsL tmpM
- , m /= getIter i
- , let tmpL = (tmpM `clearBit` m)
- , l <- activeBitsL tmpL
- , l /= getIter i
- , let t = tmpL `clearBit` l
- , popCount t >= 2
- , k <- activeBitsL t
- , k /= getIter i
- , let kk = Iter k
- ]
-
--- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where
--- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
--- tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
--- zs = ((,) <<< tia % tib ... S.toList) highestBII ix
--- ls = [ ( xsBII ! kk , xsBII ! ll )
--- | k <- VU.toList . popCntSorted $ popCount s
--- , ki <- if k==0 then [0] else activeBitsL k
--- , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki)
--- , let kk = (BitSet k:>Iter ki:>Iter kj)
--- , let l = s `xor` BitSet k
--- , li <- if l==0 then [0] else activeBitsL l
--- , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li)
--- , let ll = (l:>Iter li:>Iter lj)
--- ]
-
-
-
--- * Helper functions
-
-highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary
-highestB = BitSet $ 2^(highBit+1) -1
-highestBII = highestB :> Iter (highBit-1) :> Iter (highBit-1) -- assuming @highBit >= 1@
-
-xsB :: Unboxed BitSet Int
-xsB = fromList (BitSet 0) highestB [ 0 .. ]
-
-xoB :: Unboxed (Outside BitSet) Int
-xoB = fromList (O (BitSet 0)) (O highestB) [ 0 .. ]
-
-xsBII :: Unboxed (BitSet:>Interface First:>Interface Last) Int
-xsBII = fromList (BitSet 0:>Iter 0:>Iter 0) highestBII [ 0 .. ]
-
--- * general quickcheck stuff
-
-options = stdArgs {maxSuccess = 1000}
-
-customCheck = quickCheckWithResult options
-
-return []
-allProps = $forAllProperties customCheck
-
diff --git a/ADP/Fusion/SynVar/Array.hs b/ADP/Fusion/SynVar/Array.hs
index 2ef22e6..9fc998c 100644
--- a/ADP/Fusion/SynVar/Array.hs
+++ b/ADP/Fusion/SynVar/Array.hs
@@ -1,293 +1,137 @@
module ADP.Fusion.SynVar.Array
( module ADP.Fusion.SynVar.Array.Type
- , module ADP.Fusion.SynVar.Array.Point
- , module ADP.Fusion.SynVar.Array.Set
- , module ADP.Fusion.SynVar.Array.Subword
+ , module ADP.Fusion.SynVar.Array
) where
-import ADP.Fusion.SynVar.Array.Point
-import ADP.Fusion.SynVar.Array.Set
-import ADP.Fusion.SynVar.Array.Subword
-import ADP.Fusion.SynVar.Array.TermSymbol
-import ADP.Fusion.SynVar.Array.Type
-
-{-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE RankNTypes #-}
+import Data.Proxy
+import Data.Strict.Tuple hiding (snd)
+import Data.Vector.Fusion.Stream.Monadic
+import Prelude hiding (map,mapM)
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-
--- | Tables in ADPfusion memoize results of parses. In the forward phase, table
--- cells are filled by a table-filling method from @Data.PrimitiveArray@. In
--- the backtracking phase, grammar rules are associated with tables to provide
--- efficient backtracking.
---
--- TODO multi-dim tables with 'OnlyZero' need a static check!
---
--- TODO PointL , PointR need sanity checks for boundaries
---
--- TODO the sanity checks are acutally a VERY BIG TODO since currently we do
--- not protect against stupidity at all!
---
--- TODO have boxed tables for top-down parsing.
---
--- TODO combine forward and backward phases to simplify the external interface
--- to the programmer.
---
--- TODO include the notion of @interfaces@ into tables. With Outside
--- grammars coming up now, we need this.
-
-module ADP.Fusion.Table.Array
--- ( MTbl (..)
--- , BtTbl (..)
- ( ITbl (..)
--- , Backtrack (..)
- , ToBT (..)
- ) where
+import Data.PrimitiveArray hiding (map)
-import Control.Exception(assert)
-import Control.Monad.Primitive (PrimMonad)
-import Data.Vector.Fusion.Stream.Size (Size(Unknown))
-import qualified Data.Vector as V
-import qualified Data.Vector.Generic as VG
-import qualified Data.Vector.Storable as VS
-import qualified Data.Vector.Unboxed as VU
-import GHC.Exts
-import Data.Bits
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Backtrack
+import ADP.Fusion.SynVar.Indices
-import Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR,topmostIndex, Outside(..))
-import qualified Data.PrimitiveArray as PA
+import ADP.Fusion.SynVar.Array.TermSymbol
+import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.Classes
-import ADP.Fusion.Multi.Classes
-import ADP.Fusion.Table.Axiom
-import ADP.Fusion.Table.Backtrack
-import ADP.Fusion.Table.Indices
-import Debug.Trace
+-- | Constraints needed to use @iTblStream@.
+type ITblCx m ls arr x u i =
+ ( TblConstraint u ~ TableConstraint
+ , TableStaticVar u i
+ , MkStream m ls i
+ , Element ls i
+ , AddIndexDense (Z:.i) (Z:.u) (Z:.i)
+ , PrimArrayOps arr u x
+ )
--- ** Mutable fill-phase tables.
+-- | General function for @ITbl@s with skalar indices.
--- | The backtracking version.
+iTblStream
+ :: forall m ls arr x u i . ITblCx m ls arr x u i
+ => Pair ls (ITbl m arr u x)
+ -> Context i
+ -> i
+ -> i
+ -> Stream m (Elm (ls :!: ITbl m arr u x) i)
+iTblStream (ls :!: ITbl _ _ c t _) vs us is
+ = map (\(s,tt,ii',oo') -> ElmITbl (t!tt) ii' oo' s)
+ . addIndexDense1 c vs us is
+ $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)
+{-# Inline iTblStream #-}
+-- | General function for @Backtrack ITbl@s with skalar indices.
+btITblStream
+ :: forall mB mF ls arr x r u i . ITblCx mB ls arr x u i
+ => Pair ls (Backtrack (ITbl mF arr u x) mF mB r)
+ -> Context i
+ -> i
+ -> i
+ -> Stream mB (Elm (ls :!: Backtrack (ITbl mF arr u x) mF mB r) i)
+btITblStream (ls :!: BtITbl c t bt) vs us is
+ = mapM (\(s,tt,ii',oo') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' oo' s)
+ . addIndexDense1 c vs us is
+ $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is)
+ where !us' = snd $ bounds t
+{-# Inline btITblStream #-}
--- TODO empty table @ms@ stuff
+-- ** Instances
instance
( Monad m
- , Element ls (BS2I First Last)
- , PA.PrimArrayOps arr (BS2I First Last) x
- , MkStream m ls (BS2I First Last)
- ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where
- -- outermost case. Grab inner indices, calculate the remainder of the
- -- set, return value
- mkStream (ls :!: ITbl c t _) Static s (BitSet b:>Interface i:>Interface j)
- = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z -- the bitset we get from the guy before us
- here = (BitSet (b `xor` zb .|. zj):>Interface zj:>Interface j) -- everything missing, set common interface
- in ElmITbl (t PA.! here) here z
- )
- $ mkStream ls (Variable Check Nothing) s (BitSet (clearBit b j):>Interface i:>Interface j)
- -- generate all possible subsets of the index. With A @Variable
- -- _ Nothing@, there is something to the right that will fill up the set.
- mkStream (ls :!: ITbl c t _) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
- = S.flatten mk step Unknown
- $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
- where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)
- step (_,Nothing) = return $ S.Done
- step (z,Just s ) = return $ S.Yield (ElmITbl (t PA.! s) s z) (z,succSet full s)
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- -- generate only those indices with the requested number of set bits
+ , ITblCx m ls arr x u (i I)
+ ) => MkStream m (ls :!: ITbl m arr u x) (i I) where
+ mkStream = iTblStream
{-# Inline mkStream #-}
instance
- ( Monad mB
- , Element ls (BS2I First Last)
- , PA.PrimArrayOps arr (BS2I First Last) x
- , MkStream mB ls (BS2I First Last)
- ) => MkStream mB (ls :!: BT (ITbl mF arr (BS2I First Last) x) mF mB r) (BS2I First Last) where
- mkStream (ls :!: BtITbl c arr bt) Static full (BitSet b:>Interface i:>Interface j)
- = S.map (\z -> let (BitSet zb:>Interface zi:>Interface zj) = getIdx z
- here = BitSet (clearBit b j):>Interface i:>Interface zj
- d = arr PA.! here
- in ElmBtITbl' d (bt full here) here z)
- $ mkStream ls (Variable Check Nothing) full (BitSet (clearBit b j):>Interface i:>Interface (-1))
- mkStream (ls :!: BtITbl c arr bt) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
- = S.flatten mk step Unknown
- $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
- where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)
- step (_,Nothing) = return $ S.Done
- step (z,Just s ) = return $ S.Yield (ElmBtITbl' (arr PA.! s) (bt full s) s z) (z,succSet full s)
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
+ ( Monad m
+ , ITblCx m ls arr x u (i O)
+ ) => MkStream m (ls :!: ITbl m arr u x) (i O) where
+ mkStream = iTblStream
{-# Inline mkStream #-}
instance
( Monad m
- , Element ls (Outside PointL)
- , PA.PrimArrayOps arr (Outside PointL) x
- , MkStream m ls (Outside PointL)
- ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where
- mkStream (ls :!: ITbl c t _) Static lu (O (PointL (i:.j)))
- = let ms = minSize c in seq ms $ seq t $
- S.mapM (\s -> let O (PointL (h:.k)) = getIdx s
- in return $ ElmITbl (t PA.! O (pointL k j)) (O $ pointL k j) s)
- $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)
--- mkStream _ _ _ _ = error "mkStream / ITbl / Outside PointL not implemented"
- {-# INLINE mkStream #-}
+ , ITblCx m ls arr x u (i C)
+ ) => MkStream m (ls :!: ITbl m arr u x) (i C) where
+ mkStream = iTblStream
+ {-# Inline mkStream #-}
instance
( Monad mB
- , Element ls (Outside PointL)
- , PA.PrimArrayOps arr (Outside PointL) x
- , MkStream mB ls (Outside PointL)
- ) => MkStream mB (ls :!: BT (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where
- mkStream (ls :!: BtITbl c arr bt) Static lu (O (PointL (i:.j)))
- = let ms = minSize c in ms `seq`
- S.map (\s -> let O (PointL (h:.k)) = getIdx s
- ix = O $ pointL k j
- d = arr PA.! ix
- in ElmBtITbl' d (bt lu ix) ix s)
- $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)
--- mkStream _ _ _ _ = error "mkStream / BT ITbl / Outside PointL not implemented"
- {-# INLINE mkStream #-}
-
--- | TODO As soon as we don't do static checking on @EmptyOk/NonEmpty@
--- anymore, this works! If we check @c@, we immediately have fusion
--- breaking down!
-
-{-
-instance
- ( Monad m
- , Element ls Subword
- , PA.PrimArrayOps arr Subword x
- , MkStream m ls Subword
- ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where
- mkStream (ls :!: ITbl c t _) Static lu (Subword (i:.j))
- = let ms = minSize c in ms `seq`
- S.mapM (\s -> let Subword (_:.l) = getIdx s
- in return $ ElmITbl (t PA.! subword l j) (subword l j) s)
- $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms) -- - minSize c)
- mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (Subword (i:.j))
- = let ms = minSize c
- {- data PBI a = PBI !a !(Int#)
- mk s = let (Subword (_:.l)) = getIdx s ; !(I# jlm) = j-l-ms in return $ PBI s jlm
- step !(PBI s z) | 1# <- z >=# 0# = do let (Subword (_:.k)) = getIdx s
- return $ S.Yield (ElmITbl (t PA.! subword k (j-(I# z))) (subword k $ j-(I# z)) s) (PBI s (z -# 1#))
- | otherwise = return S.Done
- -}
- {-
- mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)
- step (s:.z) | 1# <- z' >=# 0# = do let (Subword (_:.k)) = getIdx s
- return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)
- | otherwise = return S.Done
- where !(I# z') = z
- -}
- mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)
- step (s:.z) | z>=0 = do let (Subword (_:.k)) = getIdx s
- return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)
- | otherwise = return S.Done
- {-# INLINE [1] mk #-}
- {-# INLINE [1] step #-}
- in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
- {-# INLINE mkStream #-}
--}
+ , ITblCx mB ls arr x u (i I)
+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr u x) mF mB r) (i I) where
+ mkStream = btITblStream
+ {-# Inline mkStream #-}
-{-
instance
( Monad mB
- , Element ls Subword
- , MkStream mB ls Subword
- , PA.PrimArrayOps arr Subword x
- ) => MkStream mB (ls :!: BT (ITbl mF arr Subword x) mF mB r) Subword where
- mkStream (ls :!: BtITbl c arr bt) Static lu (Subword (i:.j))
- = let ms = minSize c in ms `seq`
- S.map (\s -> let (Subword (_:.l)) = getIdx s
- ix = subword l j
- d = arr PA.! ix
- in ElmBtITbl' d (bt lu ix) ix s)
- $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)
- mkStream (ls :!: BtITbl c arr bt) (Variable _ Nothing) lu (Subword (i:.j))
- = let ms = minSize c
- mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)
- step (s:.z)
- | z>=0 = do let (Subword (_:.k)) = getIdx s
- ix = subword k (j-z)
- d = arr PA.! ix
- return $ S.Yield (ElmBtITbl' d (bt lu ix) ix s) (s:.z-1)
- | otherwise = return $ S.Done
- {-# INLINE [1] mk #-}
- {-# INLINE [1] step #-}
- in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
- {-# INLINE mkStream #-}
--}
+ , ITblCx mB ls arr x u (i O)
+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr u x) mF mB r) (i O) where
+ mkStream = btITblStream
+ {-# Inline mkStream #-}
-{-
instance
- ( Monad m
- , Element ls (Outside Subword)
- , PA.PrimArrayOps arr Subword x
- , MkStream m ls (Outside Subword)
- ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where
- mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))
- = let ms = minSize c in ms `seq`
- S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s
- in return $ ElmITbl (t PA.! (subword l j)) (O $ subword l j) s)
- $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)
- mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))
- = let ms = minSize c
- mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)
- step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s
- return $ S.Yield (ElmITbl (t PA.! (subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)
- | otherwise = return S.Done
- {-# INLINE [1] mk #-}
- {-# INLINE [1] step #-}
- in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)
- {-# INLINE mkStream #-}
--}
+ ( Monad mB
+ , ITblCx mB ls arr x u (i C)
+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr u x) mF mB r) (i C) where
+ mkStream = btITblStream
+ {-# Inline mkStream #-}
-{-
-instance
- ( Monad m
- , Element ls (Outside Subword)
- , PA.PrimArrayOps arr (Outside Subword) x
- , MkStream m ls (Outside Subword)
- ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where
- mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))
- = let ms = minSize c in ms `seq`
- S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s
- in return $ ElmITbl (t PA.! (O $ subword l j)) (O $ subword l j) s)
- $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)
- mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))
- = let ms = minSize c
- mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)
- step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s
- return $ S.Yield (ElmITbl (t PA.! (O $ subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)
- | otherwise = return S.Done
- {-# INLINE [1] mk #-}
- {-# INLINE [1] step #-}
- in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)
- {-# INLINE mkStream #-}
--}
+instance ModifyConstraint (ITbl m arr (Subword t) x) where
+ toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f
+ toEmpty (ITbl b l _ arr f) = ITbl b l EmptyOk arr f
+ {-# Inline toNonEmpty #-}
+ {-# Inline toEmpty #-}
+instance ModifyConstraint (ITbl m arr (Z:.Subword t:.Subword t) x) where
+ toNonEmpty (ITbl b l _ arr f) = ITbl b l (Z:.NonEmpty:.NonEmpty) arr f
+ toEmpty (ITbl b l _ arr f) = ITbl b l (Z:.EmptyOk :.EmptyOk ) arr f
+ {-# Inline toNonEmpty #-}
+ {-# Inline toEmpty #-}
--- * Axiom for backtracking
+instance ModifyConstraint (Backtrack (ITbl mF arr (Subword t) x) mF mB r) where
+ toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt
+ toEmpty (BtITbl _ arr bt) = BtITbl EmptyOk arr bt
+ {-# Inline toNonEmpty #-}
+ {-# Inline toEmpty #-}
--}
+instance ModifyConstraint (Backtrack (ITbl mF arr (Z:.Subword t:.Subword t) x) mF mB r) where
+ toNonEmpty (BtITbl _ arr bt) = BtITbl (Z:.NonEmpty:.NonEmpty) arr bt
+ toEmpty (BtITbl _ arr bt) = BtITbl (Z:.EmptyOk :.EmptyOk ) arr bt
+ {-# Inline toNonEmpty #-}
+ {-# Inline toEmpty #-}
diff --git a/ADP/Fusion/SynVar/Array/Point.hs b/ADP/Fusion/SynVar/Array/Point.hs
deleted file mode 100644
index 413a716..0000000
--- a/ADP/Fusion/SynVar/Array/Point.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-
-module ADP.Fusion.SynVar.Array.Point where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Debug.Trace
-import Prelude hiding (map,mapM)
---import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-
-
-
-instance
- ( Monad m
- , Element ls PointL
- , PrimArrayOps arr PointL x
- , MkStream m ls PointL
- ) => MkStream m (ls :!: ITbl m arr PointL x) PointL where
- mkStream (ls :!: ITbl _ _ c t _) (IStatic d) u j@(PointL pj)
- = let ms = minSize c in ms `seq`
- map (ElmITbl (t!j) j (PointL 0))
- $ mkStream ls (IVariable d) u (PointL $ pj - ms)
- -- We can't really make sure that this is the only time we access the
- -- ITbl, so the user should know what they are doing.
- mkStream (ls :!: ITbl _ _ c t _) (IVariable d) u j@(PointL pj)
- = flatten mk step Unknown $ mkStream ls (IVariable d) u (delay_inline PointL $! pj - ms)
- where mk s = let PointL k = getIdx s in return (s :. k)
- step (s :. k)
- | k+ms>pj = return $ Done
- | otherwise = return $ Yield (ElmITbl (t!PointL k) (PointL k) (PointL 0) s) (s :. k+1)
- !ms = minSize c
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
-instance
- ( Monad mB
- , Element ls PointL
- , PrimArrayOps arr PointL x
- , MkStream mB ls PointL
- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr PointL x) mF mB r) PointL where
- mkStream (ls :!: BtITbl c t bt) (IStatic d) u j@(PointL pj)
- = let ms = minSize c in ms `seq`
- mapM (\s -> bt u j >>= \bb -> return $ ElmBtITbl (t!j) (bb {-bt u j-}) j (PointL 0) s)
- $ mkStream ls (IVariable d) u (PointL $ pj - ms)
- {-# INLINE mkStream #-}
-
-instance
- ( Monad m
- , Element ls (Outside PointL)
- , PrimArrayOps arr (Outside PointL) x
- , MkStream m ls (Outside PointL)
- ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where
- mkStream (ls :!: ITbl _ _ c t _) (OStatic d) u (O (PointL pj))
- = let ms = minSize c in ms `seq`
- map (\z -> let o = getOmx z
- in ElmITbl (t ! o) o o z)
- $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)
- {-# Inline mkStream #-}
-
-instance
- ( Monad mB
- , Element ls (Outside PointL)
- , PrimArrayOps arr (Outside PointL) x
- , MkStream mB ls (Outside PointL)
- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where
- mkStream (ls :!: BtITbl c t bt) (OStatic d) u (O (PointL pj))
- = let ms = minSize c in ms `seq`
- mapM (\s -> let o = getOmx s in bt u o >>= \bb -> return $ ElmBtITbl (t!o) (bb{-bt u o-}) o o s)
- $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)
- {-# INLINE mkStream #-}
-
diff --git a/ADP/Fusion/SynVar/Array/Set.hs b/ADP/Fusion/SynVar/Array/Set.hs
deleted file mode 100644
index 24b0a08..0000000
--- a/ADP/Fusion/SynVar/Array/Set.hs
+++ /dev/null
@@ -1,164 +0,0 @@
-
-module ADP.Fusion.SynVar.Array.Set where
-
-import Data.Bits
-import Data.Bits.Extras
-import Data.Bits.Ordered
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Debug.Trace
-import Prelude hiding (map)
-import Control.Applicative ((<$>))
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-
-
-
--- * Bitsets without any interfaces.
-
--- NOTE that we have to give as the filled index elements all bits that are
--- set in total, not just those we set right here. Otherwise the next
--- element will try a wrong set of indices.
---
--- NOTE even in the @IStatic@ case, we need to use flatten. If a node
--- requested a reserved bit, we need to free each reserved bit at least
--- once.
-
-instance
- ( Monad m
- , Element ls BitSet
- , PrimArrayOps arr BitSet x
- , MkStream m ls BitSet
- ) => MkStream m (ls :!: ITbl m arr BitSet x) BitSet where
- mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u s
- = flatten mk step Unknown $ mkStream ls (delay_inline IVariable $ rp - csize) u s
- where !csize | c==EmptyOk = 0
- | c==NonEmpty = 1
- mk z
- | cm < csize = return (z , mask , Nothing)
- | otherwise = return (z , mask , Just k )
- where k = (BitSet $ 2^cm-1)
- cm = popCount mask - rp
- mask = s `xor` (getIdx z)
- step (_,_,Nothing) = return $ Done
- step (z,mask,Just k)
- | pk > popCount s - rp = return $ Done
- | otherwise = let kk = popShiftL mask k
- in return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,setSucc (BitSet 0) (2^pk -1) k)
- where pk = popCount k
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- mkStream (ls :!: ITbl _ _ c t _) (IVariable rp) u s
- = flatten mk step Unknown $ mkStream ls (IVariable rp) u s
- where mk z
- | c==EmptyOk = return (z , mask , cm , Just 0 )
- | cm == 0 = return (z , mask , cm , Nothing) -- we are non-empty but have no free bits left
- | c==NonEmpty = return (z , mask , cm , Just 1 )
- where mask = s `xor` (getIdx z) -- bits that are still free
- cm = popCount mask
- step (z,mask,cm,Nothing) = return $ Done
- step (z,mask,cm,Just k )
- | popCount s < popCount (kk .|. getIdx z) + rp = return $ Done
- | otherwise = return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,cm,setSucc (BitSet 0) (2^cm -1) k)
- where kk = popShiftL mask k
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
-
-
--- * Bitsets with two interfaces.
---
--- NOTE These are annoying to get right, if you also want to have good
--- performance.
-
-instance
- ( Monad m
- , Element ls (BS2I First Last)
- , PrimArrayOps arr (BS2I First Last) x
- , MkStream m ls (BS2I First Last)
- , Show x
- ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where
- mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u sij@(s:>i:>j@(Iter jj))
- = flatten mk step Unknown $ mkStream ls (delay_inline IVariable rpn) u (delay_inline id $ tij)
- -- calculate new index. if we don't know the right-most interface
- -- anymore, than someone has taken it already. Also, if this
- -- synvar may be empty, do not modify the index. Otherwise, if
- -- @j@ is still known, remove it from the index set.
- where tij | jj == -1 = sij
- | c == EmptyOk = sij
- | c == NonEmpty = s `clearBit` jj :> i :> Iter (-1)
- -- In case we do not know the rightmost interface, we instead
- -- increase the number of reserved bits.
- rpn | jj == -1
- && c == NonEmpty = rp+1
- | otherwise = rp
- nec | c == NonEmpty = 1
- | c == EmptyOk = 0
- mk z
- -- in case we have a non-empty synvar but not enough bits, we
- -- shall have nothing. We only need one extra mask bit, because
- -- @j@ is still known.
- | popCount mask < 1 && c == NonEmpty && j >= 0 = return $ Naught
- -- If @j@ is not known we need two bits to be non-empty.
- | popCount mask < 2 && c == NonEmpty && j < 0 = return $ Naught
- -- Not enough bits to reserve.
- | popCount mask - rp < 0 = return $ Naught
- -- @j@ is still known, just create the sets ending in @j@
- | j >= 0 = return $ This (z,mask)
- -- @j@ is not known, we have a lot of work to do. Create the
- -- required @bits@ and prepare a @mask@ which will set the
- -- correct bits.
- | j < 0 = return $ That (z,mask,Just bits,maybeLsb bits)
- -- we somehow ended up with an improper state
- | otherwise = error $ show (sij,mask,bits)
- where (zs:>_:>Iter zk) = getIdx z
- mask = s `xor` zs
- bits = BitSet $ 2 ^ (popCount mask - rp - nec) - 1
- step Naught = return $ Done
- -- In case @j@ is known, we calculate the bits @msk@ that are not
- -- filled yet. We grab the previous right interface @zk@ and use
- -- it as the new left interface. We also use @j@ as the right
- -- interface. @ix@ holds everything that is now covered, withe
- -- the interface @i@ and @j@.
- step (This (z,mask)) = return $ Yield (ElmITbl (t!(msk:>k:>j)) ix undefbs2i z) Naught
- where (zs:>_:>zk) = getIdx z
- k = Iter $ getIter zk
- ix = (zs .|. msk) :> i :> j
- msk = if popCount mask == 0 then mask else mask `setBit` getIter k `setBit` jj
- -- whenever there is nothing more to do in the variable case.
- step (That (z,mask,Nothing,_)) = return $ Done
- -- We need to permute our population a bit. Once done, we grab
- -- the lowest significant bit.
- step (That (z,mask,Just bits,Nothing)) = return $ Skip (That (z,mask,nbts, maybeLsb =<< nbts))
- where nbts = popPermutation (popCount mask) bits
- -- The variable case.
- step (That (z,mask,Just bits,Just y))
- -- we do not have enough bits to be non-empty.
- | popCount bb < 2 && c == NonEmpty
- -- our two interfaces are the same, but we are non-empty in
- -- which case this shouldn't happen.
- || getIter kk == getIter yy && c == NonEmpty
- -- our pop-count plus reserved count doesn't match up with the
- -- mask. We skip this as well.
- || popCount bb + rp /= popCount mask = return $ Skip (That (z,mask,Just bits, maybeNextActive y bits))
- -- finally, we can create the index for the current stuff
- -- @bb:>kk:>yy@ and prepare the full index, going from @i@ to
- -- @yy@, because someone grabbed @j@ already. Must have been
- -- an @Edge@ or s.th. similar.
- | otherwise = return $ Yield (ElmITbl (t!(bb:>kk:>yy)) ((zs .|. bb):>i:>yy) undefbs2i z)
- (That (z,mask,Just bits, maybeNextActive y bits))
- where (zs:>_:>zk) = getIdx z
- kk = Iter $ getIter zk
- yy = Iter . lsb $ popShiftL mask (bit y)
- bb = popShiftL mask bits `setBit` getIter kk `setBit` getIter yy
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
diff --git a/ADP/Fusion/SynVar/Array/Subword.hs b/ADP/Fusion/SynVar/Array/Subword.hs
deleted file mode 100644
index b20ddbc..0000000
--- a/ADP/Fusion/SynVar/Array/Subword.hs
+++ /dev/null
@@ -1,318 +0,0 @@
-
-{-# Language MagicHash #-}
-
-module ADP.Fusion.SynVar.Array.Subword where
-
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Size
-import Data.Vector.Fusion.Util (delay_inline)
-import Data.Vector.Fusion.Stream.Monadic
-import Debug.Trace
-import Prelude hiding (map,mapM)
-
-import Data.PrimitiveArray hiding (map)
-
-import ADP.Fusion.Base
-import ADP.Fusion.SynVar.Array.Type
-import ADP.Fusion.SynVar.Backtrack
-
--- TODO think about what we are about to do
-import GHC.Prim (reallyUnsafePtrEquality#)
-
-
-
-
--- TODO delay inline @(subword i $ j - minSize c)@ or face fusion-breakage.
--- Can we just have @Inline [0] subword@ to fix this?
-
-instance
- ( Monad m
- , Element ls Subword
- , PrimArrayOps arr Subword x
- , MkStream m ls Subword
- ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where
- mkStream (ls :!: ITbl _ _ c t _) (IStatic ()) hh (Subword (i:.j))
- = map (\s -> let (Subword (_:.l)) = getIdx s
- in ElmITbl (t ! subword l j) (subword l j) (subword 0 0) s)
- $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
- mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
- where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)
- step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
- l = j - z
- kl = subword k l
- return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1)
- | otherwise = return $ Done
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
-instance
- ( Monad mB
- , Element ls Subword
- , MkStream mB ls Subword
- , PrimArrayOps arr Subword x
- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr Subword x) mF mB r) Subword where
- mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh ij@(Subword (i:.j))
- = mapM (\s -> let Subword (_:.l) = getIdx s
- lj = subword l j
- in bt hh lj >>= \ ~bb -> return $ ElmBtITbl (t ! lj) (bb {-bt hh lj-}) lj (subword 0 0) s)
- $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
- mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh ij@(Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
- where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)
- step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
- l = j - z
- kl = subword k l
- bt hh kl >>= \ ~bb -> return $ Yield (ElmBtITbl (t ! kl) (bb {-bt hh kl-}) kl (subword 0 0) s) (s:.z-1)
- | otherwise = return $ Done
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
-
-instance
- ( Monad m
- , Element ls (Outside Subword)
- , PrimArrayOps arr (Outside Subword) x
- , MkStream m ls (Outside Subword)
- ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where
- -- TODO what about @c / minSize@
- mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
- = map (\s -> let O (Subword (k:._)) = getOmx s
- kj = O $ Subword (k:.j+dj)
- in ElmITbl (t ! kj) (O $ Subword (i:.j+dj)) kj s) -- @ij@ or s.th. else shouldn't matter?
- $ mkStream ls (OFirstLeft (di:.dj)) u ij
- mkStream (ls :!: ITbl _ _ c t _) (ORightOf (di:.dj)) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
- = flatten mk step Unknown $ mkStream ls (OFirstLeft (di:.dj)) u ij
- where mk s = return (s:.j+dj)
- step (s:.l) | l <= h = do let (O (Subword (k:._))) = getIdx s
- kl = O $ Subword (k:.l)
- return $ Yield (ElmITbl (t ! kl) (O (Subword (j+dj:.j+dj))) kl s) (s:.l+1)
- | otherwise = return $ Done
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft d) u ij = error "Array/Outside Subword : OFirstLeft : should never be reached!"
- mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij = error "Array/Outside Subword : OLeftOf : should never be reached!"
- {-# Inline mkStream #-}
-
-
-
-instance
- ( Monad m
- , Element ls (Outside Subword)
- , PrimArrayOps arr Subword x
- , MkStream m ls (Outside Subword)
- ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where
- -- TODO what about @c / minSize@
- mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
- = map (\s -> let O (Subword (_:.k)) = getIdx s
- o@(O (Subword (_:.l))) = getOmx s
- kl = Subword (k-dj:.l-dj)
- in ElmITbl (t ! kl) (O (Subword (k:.l))) o s)
- $ mkStream ls (ORightOf (di:.dj)) u ij
- mkStream (ls :!: ITbl _ _ c t _) (ORightOf d) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
- = flatten mk step Unknown $ mkStream ls (ORightOf d) u ij
- where mk s = let O (Subword (_:.l)) = getIdx s
- in return (s :.l:.l + minSize c)
- step (s:.k:.l)
- | let O (Subword (_:.o)) = getOmx s
- , l <= o = do let kl = Subword (k:.l)
- return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.k:.l+1)
- | otherwise = return $ Done
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft (di:.dj)) u ij@(O (Subword (i:.j)))
- = map (\s -> let O (Subword (l:._)) = getOmx s
- O (Subword (_:.k)) = getIdx s
- kl = Subword (k:.i-di)
- in ElmITbl (t ! kl) (O kl) (getOmx s) s)
- $ mkStream ls (OLeftOf (di:.dj)) u ij
- mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij@(O (Subword (i:.j)))
- = flatten mk step Unknown $ mkStream ls (OLeftOf d) u ij
- where mk s = let O (Subword (_:.l)) = getIdx s in return (s:.l)
- step (s:.l) | l <= i = do let O (Subword (_:.k)) = getIdx s
- kl = Subword (k:.l)
- return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.l+1)
- | otherwise = return $ Done
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
-instance
- ( Monad m
- , Element ls (Complement Subword)
- , PrimArrayOps arr Subword x
- , MkStream m ls (Complement Subword)
- ) => MkStream m (ls :!: ITbl m arr Subword x) (Complement Subword) where
- mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
- = map (\s -> let (C ix) = getIdx s
- in ElmITbl (t ! ix) (C ix) (getOmx s) s)
- $ mkStream ls Complemented u ij
- {-# Inline mkStream #-}
-
-instance
- ( Monad m
- , Element ls (Complement Subword)
- , PrimArrayOps arr (Outside Subword) x
- , MkStream m ls (Complement Subword)
- ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Complement Subword) where
- mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
- = map (\s -> let (C ox) = getOmx s -- TODO shouldn't this be @getIdx@ as well? on the count of everything being terminals in Complement?
- in ElmITbl (t ! (O ox)) (getIdx s) (C ox) s)
- $ mkStream ls Complemented u ij
- {-# Inline mkStream #-}
-
-
-
-instance ModifyConstraint (ITbl m arr Subword x) where
- toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f
- toEmpty (ITbl b l _ arr f) = ITbl b l EmptyOk arr f
- {-# Inline toNonEmpty #-}
- {-# Inline toEmpty #-}
-
-instance ModifyConstraint (Backtrack (ITbl mF arr Subword x) mF mB r) where
- toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt
- toEmpty (BtITbl _ arr bt) = BtITbl EmptyOk arr bt
- {-# Inline toNonEmpty #-}
- {-# Inline toEmpty #-}
-
-
-
-instance
- ( Monad m
- , Element ls Subword -- (Z:.Subword:.Subword)
- , FirstSecond ls (arr (Z:.Subword:.Subword) x)
- , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
- , PrimArrayOps arr (Z:.Subword:.Subword) x
- , MkStream m ls Subword
- , Show x
- ) => MkStream m (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword where
- mkStream (ls :!: ITbl _ _ c t elm) (IStatic ()) hh (Subword (i:.j))
- = map (\s -> let (Subword (_:.l)) = getIdx s
- ab = if greenLight ls t
- then greenIdx ls (undefined :: Subword) t s
- else subword 0 0
- in -- traceShow ("13",ab,subword l j,t!(Z:.ab:.subword l j)) $
- ElmITbl (t ! (Z:.ab:.subword l j)) (subword l j) (subword 0 0) s)
- $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
- mkStream (ls :!: ITbl _ _ c t elm) (IVariable ()) hh (Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
- where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0)
- step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
- l = j - z
- kl = subword k l
- ab = if greenLight ls t
- then greenIdx ls (undefined :: Subword) t s
- else subword 0 0
- --traceShow ("02",ab,subword k l,t!(Z:.ab:.subword k l)) $
- return $ Yield (ElmITbl (t ! (Z:.ab:.kl)) kl (subword 0 0) s) (s:.z-1)
- | otherwise = return $ Done
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
-instance
- ( Monad mB
- , FirstSecond ls (arr (Z:.Subword:.Subword) x)
- , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
- , PrimArrayOps arr (Z:.Subword:.Subword) x
- , Element ls Subword
- , MkStream mB ls Subword
- , Show r
- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword where
- mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh (Subword (i:.j))
- = mapM (\s -> let (Subword (_:.l)) = getIdx s
- lj = subword l j
- light = greenLight ls t
- ab = if light
- then greenIdx ls (undefined :: Subword) t s
- else lj -- subword 0 0
- ablj = if light
- then Z:.ab:.lj
- else Z:.subword 0 0:.subword 0 0 -- Z:.lj:.lj
- in bt (Prelude.snd $ bounds t) ablj >>= \ ~bb -> {- traceShow (ab,lj,bb) $ -} return $ ElmBtITbl (t ! ablj) bb lj (subword 0 0) s)
- $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
- mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh (Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0))
- where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0)
- step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
- l = j - z
- kl = subword k l
- light = greenLight ls t
- ab = if light
- then greenIdx ls (undefined :: Subword) t s
- else kl -- subword 0 0
- abkl = if light
- then Z:.ab:.kl
- else Z:.subword 0 0:.subword 0 0 -- Z:.kl:.kl
- bt (Prelude.snd $ bounds t) abkl >>= \ ~bb -> {- traceShow (ab,kl,bb) $ -} return $ Yield (ElmBtITbl (t!abkl) bb kl (subword 0 0) s) (s:.z-1)
- | otherwise = return $ Done
- {-# Inline [0] mk #-}
- {-# Inline [0] step #-}
- {-# Inline mkStream #-}
-
--- | Get the previous index; this should really be made generic!
---
--- TODO This is probably a REALLY STUPID IDEA ;-)
-
-class FirstSecond x k where
- greenLight :: x -> k -> Bool
-
-class FirstSecondIdx x k i where
- greenIdx :: x -> i -> k -> Elm x i -> Subword
-
-instance FirstSecond S k where
- greenLight S _ = False
- {-# Inline greenLight #-}
-
-
-
-instance
- ( FirstSecond ls (arr (Z:.Subword:.Subword) x)
- ) => FirstSecond (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) where
- greenLight (ls :!: ITbl _ _ _ t _) t' =
- case reallyUnsafePtrEquality# t t' of
- -- TODO speaking of stupid ideas!
- 1# -> True
- _ -> greenLight ls t'
- {-# Inline greenLight #-}
-
-instance
- ( FirstSecond ls (arr (Z:.Subword:.Subword) x)
- ) => FirstSecond (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) where
- greenLight (ls :!: BtITbl _ t _) t' =
- case reallyUnsafePtrEquality# t t' of
- -- TODO speaking of stupid ideas!
- 1# -> True
- _ -> greenLight ls t'
- {-# Inline greenLight #-}
-
-
-
-instance FirstSecondIdx S k i where
- greenIdx S _ _ _ = error "shouldn't arrive here!"
- {-# Inline greenIdx #-}
-
-instance
- ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
- , Elm ls Subword ~ RecElm (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword
- , Element ls Subword
- ) => FirstSecondIdx (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) Subword where
- greenIdx (ls :!: ITbl _ _ _ t _) _ t' e =
- case reallyUnsafePtrEquality# t t' of
- 1# -> let ab = getIdx e in ab
- _ -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g
- {-# Inline greenIdx #-}
-
-instance
- ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword
- , Elm ls Subword ~ RecElm (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword
- , Element ls Subword
- ) => FirstSecondIdx (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) Subword where
- greenIdx (ls :!: BtITbl _ t _) _ t' e =
- case reallyUnsafePtrEquality# t t' of
- 1# -> let ab = getIdx e in ab
- _ -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g
- {-# Inline greenIdx #-}
-
diff --git a/ADP/Fusion/SynVar/Array/TermSymbol.hs b/ADP/Fusion/SynVar/Array/TermSymbol.hs
index b914dbd..8a33629 100644
--- a/ADP/Fusion/SynVar/Array/TermSymbol.hs
+++ b/ADP/Fusion/SynVar/Array/TermSymbol.hs
@@ -1,12 +1,16 @@
-- | TODO migrate instances to correct modules
+--
+-- TODO need to find out if we can reduce the total number of instances
+-- required here. Probably not trivial since there are, in principle, @n*m@
+-- instances that we need to handle.
module ADP.Fusion.SynVar.Array.TermSymbol where
+import Data.Proxy
import Data.Strict.Tuple hiding (snd)
-import Data.Vector.Fusion.Stream.Size
import Data.Vector.Fusion.Util (delay_inline)
-import Data.Vector.Fusion.Stream.Monadic
+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)
import Debug.Trace
import Prelude hiding (map,mapM)
@@ -18,57 +22,115 @@ import ADP.Fusion.SynVar.Backtrack
--- | TODO need to deal with @minSize@
+-- |
+--
+-- TODO need to handle @minSize@ conditions!
instance
- ( Monad m
- , TerminalStream m a is
- , PrimArrayOps arr Subword x
- , Show x
- ) => TerminalStream m (TermSymbol a (ITbl m arr Subword x)) (is:.Subword) where
- terminalStream (a :| ITbl _ _ c t _) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
- = map (\ (S6 s (zi:.(Subword (a:.l))) (zo:._) is os e) ->
- let lj = subword l j
- in {- traceShow (i,a,' ',l,j,t!lj) $ -} S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj)) )
- . iPackTerminalStream a sv (is:.ix)
- terminalStream (a :| ITbl _ _ c t _) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
- = flatten mk step Unknown . iPackTerminalStream a sv (is:.ix)
- where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !
- step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6
- l = j - z
- kl = subword k l
- return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1)
- | otherwise = return $ Done
+ ( TstCtx1 m ts a is (Subword I)
+ , PrimArrayOps arr (Subword I) x
+ ) => TermStream m (TermSymbol ts (ITbl m arr (Subword I) x)) a (is:.Subword I) where
+ --
+ termStream (ts:|ITbl _ _ _ t _) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))
+ = map (\(TState s a b ii oo ee) ->
+ let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ lj = subword l j
+ in TState s a b (ii:.lj) (oo:.subword 0 0) (ee:.t!lj) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|ITbl _ _ _ t _) (cs:.IVariable ()) (us:.u) (is:.Subword (i:.j))
+ = flatten mk step . termStream ts cs us is
+ where mk tstate@(TState s a b ii oo ee) =
+ let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ in return (tstate, l, j - l)
+ step (tstate@(TState s a b ii oo ee), k, z)
+ | z >= 0 = do let l = j - z
+ kl = subword k l
+ return $ Yield (TState s a b (ii:.kl) (oo:.subword 0 0) (ee:.t!kl)) (tstate, k, z-1)
+ | otherwise = return $ Done
{-# Inline [0] mk #-}
{-# Inline [0] step #-}
- {-# Inline terminalStream #-}
+ {-# Inline termStream #-}
+
+-- |
+--
+-- TODO can we combine the @ITbl@ and @BtITbl@ code again?
instance
- ( Monad mB
- , TerminalStream mB a is
- , PrimArrayOps arr Subword x
- ) => TerminalStream mB (TermSymbol a (Backtrack (ITbl mF arr Subword x) mF mB r)) (is:.Subword) where
- terminalStream (a :| BtITbl c t bt) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
- = mapM (\ (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) ->
- let lj = subword l j
- hh = snd $ bounds t
- in bt hh lj >>= \ ~bb -> return $ S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj, bb)) )
- . iPackTerminalStream a sv (is:.ix)
- terminalStream (a :| BtITbl c t bt) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
- = flatten mk step Unknown . iPackTerminalStream a sv (is:.ix)
- where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !
- step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6
- l = j - z
- kl = subword k l
- hh = snd $ bounds t
- bt hh kl >>= \ ~bb -> return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl,bb))) (s6 :. k :. z-1)
- | otherwise = return $ Done
+ ( TstCtx1 mB ts a is (Subword I)
+ , PrimArrayOps arr (Subword I) x
+ ) => TermStream mB (TermSymbol ts (Backtrack (ITbl mF arr (Subword I) x) mF mB r)) a (is:.Subword I) where
+ termStream (ts:|BtITbl c t bt) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))
+ = mapM (\(TState s a b ii oo ee) ->
+ let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ lj = subword l j
+ in bt u lj >>= \ ~bb -> return $ TState s a b (ii:.lj) (oo:.subword 0 0) (ee:.(t!lj,bb)) )
+ . termStream ts cs us is
+ termStream (ts:|BtITbl c t bt) (cs:.IVariable ()) (us:.u) (is:.Subword (i:.j))
+ = flatten mk step . termStream ts cs us is
+ where mk tstate@(TState s a b ii oo ee) =
+ let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ in return (tstate, l, j - l)
+ step (tstate@(TState s a b ii oo ee), k, z)
+ | z >= 0 = do let l = j - z
+ kl = subword k l
+ bt u kl >>= \ ~bb -> return $ Yield (TState s a b (ii:.kl) (oo:.subword 0 0) (ee:.(t!kl,bb))) (tstate, k, z-1)
+ | otherwise = return $ Done
{-# Inline [0] mk #-}
{-# Inline [0] step #-}
- {-# Inline terminalStream #-}
+ {-# Inline termStream #-}
+-- | TODO need to deal with @minSize@
-instance TermStaticVar (ITbl m arr Subword x) Subword where
+--instance
+-- ( Monad m
+-- , TerminalStream m a is
+-- , PrimArrayOps arr (Subword I) x
+-- , Show x
+-- ) => TerminalStream m (TermSymbol a (ITbl m arr (Subword I) x)) (is:.Subword I) where
+-- terminalStream (a :| ITbl _ _ c t _) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
+-- = map (\ (S6 s (zi:.(Subword (a:.l))) (zo:._) is os e) ->
+-- let lj = subword l j
+-- in {- traceShow (i,a,' ',l,j,t!lj) $ -} S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj)) )
+-- . iPackTerminalStream a sv (is:.ix)
+-- terminalStream (a :| ITbl _ _ c t _) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
+-- = flatten mk step . iPackTerminalStream a sv (is:.ix)
+-- where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !
+-- step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6
+-- l = j - z
+-- kl = subword k l
+-- return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1)
+-- | otherwise = return $ Done
+-- {-# Inline [0] mk #-}
+-- {-# Inline [0] step #-}
+-- {-# Inline terminalStream #-}
+
+--instance
+-- ( Monad mB
+-- , TerminalStream mB a is
+-- , PrimArrayOps arr (Subword I) x
+-- ) => TerminalStream mB (TermSymbol a (Backtrack (ITbl mF arr (Subword I) x) mF mB r)) (is:.Subword I) where
+-- terminalStream (a :| BtITbl c t bt) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
+-- = mapM (\ (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) ->
+-- let lj = subword l j
+-- hh = snd $ bounds t
+-- in bt hh lj >>= \ ~bb -> return $ S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj, bb)) )
+-- . iPackTerminalStream a sv (is:.ix)
+-- terminalStream (a :| BtITbl c t bt) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
+-- = flatten mk step . iPackTerminalStream a sv (is:.ix)
+-- where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c !
+-- step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6
+-- l = j - z
+-- kl = subword k l
+-- hh = snd $ bounds t
+-- bt hh kl >>= \ ~bb -> return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl,bb))) (s6 :. k :. z-1)
+-- | otherwise = return $ Done
+-- {-# Inline [0] mk #-}
+-- {-# Inline [0] step #-}
+-- {-# Inline terminalStream #-}
+
+
+instance TermStaticVar (ITbl m arr (Subword I) x) (Subword I) where
termStaticVar _ (IStatic d) _ = IVariable d
termStaticVar _ (IVariable d) _ = IVariable d
termStreamIndex (ITbl _ _ _ _ _) (IStatic d) (Subword (i:.j)) = subword i j -- TODO minSize handling !
@@ -76,7 +138,7 @@ instance TermStaticVar (ITbl m arr Subword x) Subword where
{-# Inline [0] termStaticVar #-}
{-# Inline [0] termStreamIndex #-}
-instance TermStaticVar (Backtrack (ITbl mF arr Subword x) mF mB r) Subword where
+instance TermStaticVar (Backtrack (ITbl mF arr (Subword I) x) mF mB r) (Subword I) where
termStaticVar _ (IStatic d) _ = IVariable d
termStaticVar _ (IVariable d) _ = IVariable d
termStreamIndex (BtITbl _ _ _) (IStatic d) (Subword (i:.j)) = subword i j -- TODO minSize handling !
diff --git a/ADP/Fusion/SynVar/Array/Type.hs b/ADP/Fusion/SynVar/Array/Type.hs
index 0f451aa..d93a58c 100644
--- a/ADP/Fusion/SynVar/Array/Type.hs
+++ b/ADP/Fusion/SynVar/Array/Type.hs
@@ -1,10 +1,14 @@
+{-# Language DataKinds #-}
+{-# Language TypeOperators #-}
+
module ADP.Fusion.SynVar.Array.Type where
import Data.Strict.Tuple hiding (uncurry,snd)
-import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM)
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))
import Debug.Trace
import Prelude hiding (map,head,mapM)
+import Data.Proxy
import Data.PrimitiveArray hiding (map)
@@ -27,7 +31,7 @@ data ITbl m arr i x where
instance Build (ITbl m arr i x)
-type instance TermArg (TermSymbol a (ITbl m arr i x)) = TermArg a :. x
+type instance TermArg (ITbl m arr i x) = x
instance GenBacktrackTable (ITbl mF arr i x) mF mB r where
data Backtrack (ITbl mF arr i x) mF mB r = BtITbl !(TblConstraint i) !(arr i x) (i -> i -> mB [r])
@@ -35,7 +39,11 @@ instance GenBacktrackTable (ITbl mF arr i x) mF mB r where
toBacktrack (ITbl _ _ c arr _) _ bt = BtITbl c arr bt
{-# Inline toBacktrack #-}
-type instance TermArg (TermSymbol a (Backtrack (ITbl mF arr i x) mF mB r)) = TermArg a :. (x,[r])
+type instance TermArg (Backtrack (ITbl mF arr i x) mF mB r) = (x,[r])
+
+
+
+-- * axiom stuff
instance
( Monad m
@@ -59,6 +67,10 @@ instance
bt (snd $ bounds arr) h
{-# Inline axiom #-}
+
+
+-- * 'Element'
+
instance Element ls i => Element (ls :!: ITbl m arr j x) i where
data Elm (ls :!: ITbl m arr j x) i = ElmITbl !x !i !i !(Elm ls i)
type Arg (ls :!: ITbl m arr j x) = Arg ls :. x
@@ -90,36 +102,40 @@ instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr j x) mF mB r))
instance (Show x, Show i, Show (Elm ls i)) => Show (Elm (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i) where
show (ElmBtITbl x _ i o s) = show (x,i,o) ++ " " ++ show s
+
+
+-- * Multi-dim extensions
+
instance
( Monad m
, Element ls (is:.i)
- , TableStaticVar (is:.i)
- , TableIndices (is:.i)
+ , TableStaticVar (us:.u) (is:.i)
+ , AddIndexDense (is:.i) (us:.u) (is:.i)
, MkStream m ls (is:.i)
- , PrimArrayOps arr (is:.i) x
- ) => MkStream m (ls :!: ITbl m arr (is:.i) x) (is:.i) where
- mkStream (ls :!: ITbl _ _ c t _) vs lu is
- = map (\(S5 s _ _ i o) -> ElmITbl (t ! i) i o s)
- . tableIndices c vs is
- . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
- $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)
+ , PrimArrayOps arr (us:.u) x
+ ) => MkStream m (ls :!: ITbl m arr (us:.u) x) (is:.i) where
+ mkStream (ls :!: ITbl _ _ c t _) vs us is
+ = map (\(s,tt,ii',oo') -> ElmITbl (t!tt) ii' oo' s)
+ . addIndexDense c vs us is
+ $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)
{-# Inline mkStream #-}
instance
( Monad mB
, Element ls (is:.i)
- , TableStaticVar (is:.i)
- , TableIndices (is:.i)
+ , TableStaticVar (us:.u) (is:.i)
+ , AddIndexDense (is:.i) (us:.u) (is:.i)
, MkStream mB ls (is:.i)
- , PrimArrayOps arr (is:.i) x
- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (is:.i) x) mF mB r) (is:.i) where
+ , PrimArrayOps arr (us:.u) x
+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (us:.u) x) mF mB r) (is:.i) where
mkStream (ls :!: BtITbl c t bt) vs us is
- = mapM (\(S5 s _ _ i o) -> bt us i >>= \ ~bb -> return $ ElmBtITbl (t ! i) (bb {-bt us i-}) i o s)
- . tableIndices c vs is
- . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
- $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)
+ = mapM (\(s,tt,ii',oo') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' oo' s)
+ . addIndexDense c vs us is
+ $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is)
+ where !us' = snd $ bounds t
{-# Inline mkStream #-}
+{-
instance
( Monad m
, Element ls (Outside (is:.i))
@@ -135,7 +151,9 @@ instance
. map (\s -> S5 s Z Z (getIdx s) (getOmx s))
$ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)
{-# Inline mkStream #-}
+-}
+{-
instance
( Monad mB
, Element ls (Outside (is:.i))
@@ -151,4 +169,6 @@ instance
. map (\s -> S5 s Z Z (getIdx s) (getOmx s))
$ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)
{-# Inline mkStream #-}
+-}
+
diff --git a/ADP/Fusion/SynVar/Fill.hs b/ADP/Fusion/SynVar/Fill.hs
index 856a0f5..37ab70b 100644
--- a/ADP/Fusion/SynVar/Fill.hs
+++ b/ADP/Fusion/SynVar/Fill.hs
@@ -117,7 +117,7 @@ instance
writeM marr i z
{-# INLINE mutateCell #-}
-type ZS2 = Z:.Subword:.Subword
+type ZS2 = Z:.Subword I:.Subword I
instance
( PrimArrayOps arr ZS2 x
@@ -134,11 +134,11 @@ instance
{-# INLINE mutateCell #-}
instance
- ( PrimArrayOps arr Subword x
- , MPrimArrayOps arr Subword x
- , MutateCell h ts im om (Z:.Subword:.Subword)
+ ( PrimArrayOps arr (Subword I) x
+ , MPrimArrayOps arr (Subword I) x
+ , MutateCell h ts im om (Z:.Subword I:.Subword I)
, PrimMonad om
- ) => MutateCell h (ts:.ITbl im arr Subword x) im om (Z:.Subword:.Subword) where
+ ) => MutateCell h (ts:.ITbl im arr (Subword I) x) im om (Z:.Subword I:.Subword I) where
mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do
mutateCell h bo lo mrph ts lu ix
when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do
diff --git a/ADP/Fusion/SynVar/Indices.hs b/ADP/Fusion/SynVar/Indices.hs
index 134edae..707976b 100644
--- a/ADP/Fusion/SynVar/Indices.hs
+++ b/ADP/Fusion/SynVar/Indices.hs
@@ -3,8 +3,22 @@
-- need 'tableIndices' in multi-dimensional tables as the type of the
-- multi-dimensional indices is generic.
-module ADP.Fusion.SynVar.Indices where
+module ADP.Fusion.SynVar.Indices
+ ( module ADP.Fusion.SynVar.Indices.Classes
+ , module ADP.Fusion.SynVar.Indices.Point
+ , module ADP.Fusion.SynVar.Indices.Set0
+ , module ADP.Fusion.SynVar.Indices.Subword
+ , module ADP.Fusion.SynVar.Indices.Unit
+ ) where
+import ADP.Fusion.SynVar.Indices.Classes
+import ADP.Fusion.SynVar.Indices.Point
+import ADP.Fusion.SynVar.Indices.Set0
+import ADP.Fusion.SynVar.Indices.Subword
+import ADP.Fusion.SynVar.Indices.Unit
+
+
+{-
import Data.Vector.Fusion.Stream.Size (Size(Unknown))
import Data.Vector.Fusion.Stream.Monadic (flatten,map,Stream, Step(..))
import Prelude hiding (map)
@@ -15,6 +29,8 @@ import ADP.Fusion.Base
+
+
class TableIndices i where
tableIndices :: (Monad m) => TblConstraint i -> Context i -> i -> Stream m (S5 z j j i i) -> Stream m (S5 z j j i i)
@@ -142,3 +158,7 @@ instance TableIndices is => TableIndices (is:.PointR) where
{-# INLINE tableIndices #-}
-}
+
+
+-}
+
diff --git a/ADP/Fusion/SynVar/Indices/Classes.hs b/ADP/Fusion/SynVar/Indices/Classes.hs
new file mode 100644
index 0000000..4b3b4ff
--- /dev/null
+++ b/ADP/Fusion/SynVar/Indices/Classes.hs
@@ -0,0 +1,76 @@
+
+-- | Classes that enumerate the index structure necessary for actually
+-- performing the indexing.
+--
+-- TODO Currently, we only provide dense index generation.
+
+module ADP.Fusion.SynVar.Indices.Classes where
+
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..))
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+
+
+
+-- | This type classes enable enumeration both in single- and multi-dim
+-- cases. The type @a@ is the type of the /full stack/ of indices, i.e. the
+-- full multi-tape problem.
+
+class AddIndexDense a u i where
+ addIndexDenseGo
+ :: (Monad m)
+ => TblConstraint u -> Context i -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i)
+
+instance AddIndexDense a Z Z where
+ addIndexDenseGo _ _ _ _ = id
+ {-# Inline addIndexDenseGo #-}
+
+-- | @SvState@ holds the state that is currently being built up by
+-- @AddIndexDense@. We have both @tIx@ (and @tOx@) and @iIx@ (and @iOx@).
+-- For most index structures, the indices will co-incide; however for some,
+-- this will not be true -- herein for @Set@ index structures.
+
+data SvState s a u i = SvS
+ { sS :: !s -- | state coming in from the left
+ , sIx :: !a -- | @I/C@ index from @sS@
+ , sOx :: !a -- | @O@ index from @sS@
+ , tx :: !u -- | @I/C@ building up state to index the @table@.
+ , iIx :: !i -- | @I/C@ building up state to hand over to next symbol
+ , iOx :: !i -- | @O@ building up state to hand over to next symbol
+ }
+
+
+-- | Given an incoming stream with indices, this adds indices for the
+-- current syntactic variable / symbol.
+
+addIndexDense
+ :: ( Monad m
+ , AddIndexDense a u i
+ , GetIndex a i
+ , s ~ Elm x0 a
+ , Element x0 a
+ )
+ => TblConstraint u -> Context i -> i -> i -> Stream m s -> Stream m (s,u,i,i)
+addIndexDense t c u i = map (\(SvS s _ _ z i' o') -> (s,z,i',o')) . addIndexDenseGo t c u i . map (\s -> (SvS s (getIdx s) (getOmx s) Z Z Z))
+{-# Inline addIndexDense #-}
+
+-- | In case of 1-dim tables, we wrap the index creation in a multi-dim
+-- system and remove the @Z@ later on. This allows us to have to write only
+-- a single instance.
+
+addIndexDense1
+ :: ( Monad m
+ , AddIndexDense (Z:.a) (Z:.u) (Z:.i)
+ , GetIndex (Z:.a) (Z:.i)
+ , s ~ Elm x0 a
+ , Element x0 a
+ )
+ => TblConstraint u -> Context i -> i -> i -> Stream m s -> Stream m (s,u,i,i)
+addIndexDense1 t c u i = map (\(SvS s _ _ (Z:.z) (Z:.i') (Z:.o')) -> (s,z,i',o'))
+ . addIndexDenseGo (Z:.t) (Z:.c) (Z:.u) (Z:.i)
+ . map (\s -> (SvS s (Z:.getIdx s) (Z:.getOmx s) Z Z Z))
+{-# Inline addIndexDense1 #-}
+
diff --git a/ADP/Fusion/SynVar/Indices/Point.hs b/ADP/Fusion/SynVar/Indices/Point.hs
new file mode 100644
index 0000000..acc1b49
--- /dev/null
+++ b/ADP/Fusion/SynVar/Indices/Point.hs
@@ -0,0 +1,73 @@
+
+module ADP.Fusion.SynVar.Indices.Point where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))
+import Data.Vector.Fusion.Util (delay_inline)
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Indices.Classes
+
+
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.PointL I)
+ , GetIx a (is:.PointL I) ~ (PointL I)
+ ) => AddIndexDense a (us:.PointL I) (is:.PointL I) where
+ addIndexDenseGo (cs:._) (vs:.IStatic d) (us:.u) (is:.i)
+ = map (\(SvS s a b t y' z') -> SvS s a b (t:.i) (y':.i) (z':.PointL 0))
+ . addIndexDenseGo cs vs us is
+ addIndexDenseGo (cs:.c) (vs:.IVariable d) (us:.u) (is:.PointL i)
+ = flatten mk step . addIndexDenseGo cs vs us is
+ where mk svS = let PointL k = getIndex (sIx svS) (Proxy :: Proxy (is:.PointL I))
+ in return $ svS :. k
+ step (svS@(SvS s a b t y' z') :. k)
+ | k + csize > i = return $ Done
+ | otherwise = return $ Yield (SvS s a b (t:.PointL k) (y':.PointL k) (z':.PointL 0)) (svS :. k+1)
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ csize = delay_inline minSize c
+ {-# Inline addIndexDenseGo #-}
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.PointL O)
+ , GetIx a (is:.PointL O) ~ (PointL O)
+ ) => AddIndexDense a (us:.PointL O) (is:.PointL O) where
+ addIndexDenseGo (cs:.c) (vs:.OStatic d) (us:.u) (is:.i)
+ = map (\(SvS s a b t y' z') -> let o = getIndex b (Proxy :: Proxy (is:.PointL O))
+ in SvS s a b (t:.o) (y':.o) (z':.o))
+ . addIndexDenseGo cs vs us is
+ where csize = delay_inline minSize c
+ {-# Inline addIndexDenseGo #-}
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.PointL C)
+ , GetIx a (is:.PointL C) ~ (PointL C)
+ ) => AddIndexDense a (us:.PointL I) (is:.PointL C) where
+ addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)
+ = map (\(SvS s a b t y z) -> let PointL k = getIndex a (Proxy :: Proxy (is:.PointL C))
+ kT = PointL k
+ kC = PointL k
+ in SvS s a b (t:.kT) (y:.kC) (z:.kC))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.PointL C)
+ , GetIx a (is:.PointL C) ~ (PointL C)
+ ) => AddIndexDense a (us:.PointL O) (is:.PointL C) where
+ addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)
+ = map (\(SvS s a b t y z) -> let PointL k = getIndex a (Proxy :: Proxy (is:.PointL C))
+ kT = PointL k
+ kC = PointL k
+ in SvS s a b (t:.kT) (y:.kC) (z:.kC))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
diff --git a/ADP/Fusion/SynVar/Indices/Set0.hs b/ADP/Fusion/SynVar/Indices/Set0.hs
new file mode 100644
index 0000000..2610cdf
--- /dev/null
+++ b/ADP/Fusion/SynVar/Indices/Set0.hs
@@ -0,0 +1,160 @@
+
+-- | @Set0@ provides index movement for sets with no interfaces.
+--
+-- TODO Sets with 1 and 2 interfaces will go into @Set1@ and @Set2@
+-- modules.
+
+module ADP.Fusion.SynVar.Indices.Set0 where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import Prelude hiding (map,head,mapM)
+import Data.Bits.Extras
+import Data.Bits
+
+import Data.PrimitiveArray hiding (map)
+import Data.Bits.Ordered
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Indices.Classes
+
+
+
+-- * Bitsets without any boundaries
+--
+-- TODO outside and complement code
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.BitSet I)
+ , GetIx a (is:.BitSet I) ~ (BitSet I)
+ ) => AddIndexDense a (us:.BitSet I) (is:.BitSet I) where
+ addIndexDenseGo (cs:.c) (vs:.IStatic rb) (us:.u) (is:.i)
+ = flatten mk step . addIndexDenseGo cs vs us is
+ -- @mk@ builds up the index we start with. First we ask in @l@
+ -- for the index from the previous symbol. Then we calculate the
+ -- @mask@, the bits we can still set. This is @i@ minus the @l@
+ -- bits. Then we calculate the population count. For this we ask
+ -- for the @popCount mask@ and lower it by the constraint @rb@
+ -- (why?). Finally, we set exactly popCount bits in @k@. These
+ -- @k@ bits are *not* the bits from the @mask@ but rather the
+ -- lowest bits.
+ -- @rb@ should be set by more-right symbols in case they need to
+ -- reserve some bits but otherwise are static.
+ where mk svS
+ | cm < csize = return $ Nothing
+ | otherwise = {- traceShow ("I0",l,mask,k) . -} return $ Just (svS :. mask :. k)
+ where k = (BitSet $ 2^cm-1)
+ cm = popCount mask - rb
+ mask = i `xor` l
+ l = getIndex (sIx svS) (Proxy :: Proxy (is:.BitSet I))
+ step Nothing = return $ Done
+ -- @step Just ...@ performs a non-trivial step. First we
+ -- calculate the population count of the index for this symbol as
+ -- @pk@. This will terminate once the popcount is higher than the
+ -- index @i@ minus the reserved count @rb@.
+ -- In case we don't terminate, we calculate the actual index @kk@
+ -- by shifting the key @k@ around with our @mask@. The local
+ -- index is given by @kk@, while the set of all active bits is
+ -- @kk .|. aa@.
+ --
+ -- TODO is the stopping criterion actually right? Should'nd we
+ -- look at all set bits? Also consider the comment above on @rb@.
+ step (Just (svS@(SvS s a b t y' z') :. mask :. k))
+ | pk > popCount i - rb = return $ Done
+ | otherwise = let kk = popShiftL mask k
+ aa = getIndex a (Proxy :: Proxy (is:.BitSet I))
+ in return $ Yield (SvS s a b (t:.kk) (y':.(kk.|.aa)) (z':.0))
+ ((svS :. mask :.) <$> setSucc 0 (2^pm -1) k)
+ where pk = popCount k
+ pm = popCount mask
+ csize = delay_inline minSize c -- minimal set size via constraints
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ addIndexDenseGo (cs:.c) (vs:.IVariable rb) (us:.u) (is:.i)
+ = flatten mk step . addIndexDenseGo cs vs us is
+ -- @mk@ builds up the initially set population. In case of
+ -- @EmptyOk@ no bits are set. Otherwise we check first if we have
+ -- bits left. If @cm==0@ then we immediately quit. If not, we
+ -- activate one bit.
+ where mk svS
+ | c==EmptyOk = return $ Just (svS :. mask :. cm :. 0)
+ | cm == 0 = return $ Nothing
+ | c==NonEmpty = return $ Just (svS :. mask :. cm :. 1)
+ where mask = i `xor` l
+ cm = popCount mask
+ l = getIndex (sIx svS) (Proxy :: Proxy (is:.BitSet I))
+ step Nothing = return $ Done
+ -- if the possible popcount in @i@ is less than the total
+ -- popcount in @kk@ and @l@ and the reserved bits in @rb@, then
+ -- we continue. This means returning @kk@ as the bitset for
+ -- indexing; @kk.|.l@ as all set bits. @setSucc@ will rotate
+ -- through all permutations for each popcount and mask.
+ step (Just (svS@(SvS s a b t y' z') :. mask :. cm :. k))
+ | popCount i < popCount (kk .|. l) + rb = return $ Done
+ | otherwise = return $ Yield (SvS s a b (t:.kk) (y':.(kk.|.l)) (z':.0))
+ ((svS :. mask :. cm :.) <$> setSucc 0 (2^cm -1) k)
+ where kk = popShiftL mask k
+ l = getIndex a (Proxy :: Proxy (is:.BitSet I))
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ {-# Inline addIndexDenseGo #-}
+
+-- | Outside / Outside synvar indices are either @OStatic@ or @ORightOf@.
+-- Of course, the single outside synvar is not to the right of itself, but
+-- it is the final @RightOf@ object before we have the @FirstLeft@ object.
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.BitSet O)
+ , GetIx a (is:.BitSet O) ~ (BitSet O)
+ ) => AddIndexDense a (us:.BitSet O) (is:.BitSet O) where
+ addIndexDenseGo (cs:.c) (vs:.OStatic rb) (us:.u) (is:.i)
+ = flatten mk step . addIndexDenseGo cs vs us is
+ -- We need to make the number of @0@s smaller, or make the number
+ -- of @1@s larger. By an amount given by @rb@.
+ where mk svS
+ -- not enough free bits with reserved count
+ | rb + popCount b >= popCount u = return $ Nothing
+ | otherwise = return $ Just (svS :. mask :. k)
+ where a = getIndex (sIx svS) (Proxy :: Proxy (is:.BitSet O))
+ b = getIndex (sOx svS) (Proxy :: Proxy (is:.BitSet O))
+ mask = u `xor` b -- all bits available for permutations (upper bound, without already set bits)
+ k = BitSet $ 2 ^ rb - 1 -- the bits we want to trigger
+ step Nothing = return $ Done
+ -- | @step@ can now provide the outside index with @+rb@ more
+ -- bits, while the inside index wont have those. The idea is that
+ -- @outside@ provides the mask we can now plug additional
+ -- @inside@ objects in -- but only in those plug-ports where @i@
+ -- is zero.
+ step (Just (svS@(SvS s a b t y' z') :. mask :. k))
+ -- drawing the next bitset ends up over the limit
+ | pk > rb = return $ Done
+ | otherwise =
+ let aa = getIndex a (Proxy :: Proxy (is:.BitSet O)) -- this is our inside-type index, it will not be modified here
+ bb = getIndex b (Proxy :: Proxy (is:.BitSet O))
+ kk = popShiftL mask k
+ tt = kk .|. bb -- the (smaller, more @1@ bits) lookup index
+ in return $ Yield (SvS s a b (t:.tt) (y':.aa) (z':.tt))
+ ((svS :. mask :.) <$> setSucc 0 (2^rb -1) k)
+ where pk = popCount k
+ csize = delay_inline minSize c
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ addIndexDenseGo (cs:.c) (vs:.ORightOf rb) (us:.u) (is:.i)
+ = undefined
+ {-# Inline addIndexDenseGo #-}
+
+-- |
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.BitSet O)
+ , GetIx a (is:.BitSet O) ~ (BitSet O)
+ ) => AddIndexDense a (us:.BitSet I) (is:.BitSet O) where
+-- addIndexDenseGo (cs:.c) (vs:.OFirstLeft rb) (us:.u) (is:.i)
+-- = error "ping"
+ {-# Inline addIndexDenseGo #-}
+
diff --git a/ADP/Fusion/SynVar/Indices/Subword.hs b/ADP/Fusion/SynVar/Indices/Subword.hs
new file mode 100644
index 0000000..cce193c
--- /dev/null
+++ b/ADP/Fusion/SynVar/Indices/Subword.hs
@@ -0,0 +1,220 @@
+
+-- | Instance code for @Inside@, @Outside@, and @Complement@ indices.
+--
+-- TODO actual @Outside@ and @Complement@ code ...
+--
+-- TODO we have quite a lot of @subword i j@ code where only the @type@
+-- is different; check if @coerce@ yields improved performance or if the
+-- compiler optimizes this out!
+
+module ADP.Fusion.SynVar.Indices.Subword where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),filter)
+import Data.Vector.Fusion.Util (delay_inline)
+import Prelude hiding (map,head,mapM,filter)
+import Debug.Trace
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Indices.Classes
+
+
+
+-- |
+-- @
+-- Table: Inside
+-- Grammar: Inside
+--
+-- The minSize condition for @IStatic@ is guaranteed via the use of
+-- @tableStreamIndex@ (not here, in individual synvars), where @j@ is set
+-- to @j-1@ for the next-left symbol!
+-- @
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Subword I)
+ , GetIx a (is:.Subword I) ~ (Subword I)
+ ) => AddIndexDense a (us:.Subword I) (is:.Subword I) where
+ addIndexDenseGo (cs:._) (vs:.IStatic ()) (us:.Subword (_:.u)) (is:.Subword (i:.j))
+ = staticCheck (j<=u)
+ . map (\(SvS s a b t y' z') -> let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ lj = subword l j
+ oo = subword 0 0
+ in SvS s a b (t:.lj) (y':.lj) (z':.oo))
+ . addIndexDenseGo cs vs us is
+ addIndexDenseGo (cs:.c) (vs:.IVariable ()) (us:.Subword (_:.u)) (is:.Subword (i:.j))
+ = staticCheck (j<=u)
+ . flatten mk step . addIndexDenseGo cs vs us is
+ where mk svS = let (Subword (_:.l)) = getIndex (sIx svS) (Proxy :: Proxy (is:.Subword I))
+ in return $ svS :. (j - l - csize)
+ step (svS@(SvS s a b t y' z') :. zz)
+ | zz >= 0 = do let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ l = j - zz ; kl = subword k l
+ oo = subword 0 0
+ return $ Yield (SvS s a b (t:.kl) (y':.kl) (z':.oo)) (svS :. zz-1)
+ | otherwise = return $ Done
+ csize = delay_inline minSize c
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ {-# Inline addIndexDenseGo #-}
+
+-- |
+-- @
+-- Table: Outside
+-- Grammar: Outside
+-- @
+--
+-- TODO Take care of @c@ in all cases to correctly handle @NonEmpty@ tables
+-- and the like.
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Subword O)
+ , GetIx a (is:.Subword O) ~ (Subword O)
+ ) => AddIndexDense a (us:.Subword O) (is:.Subword O) where
+ addIndexDenseGo (cs:.c) (vs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = map (\(SvS s a b t y' z') -> let Subword (k:._) = getIndex b (Proxy :: Proxy (is:.Subword O))
+ kj = subword k (j+dj)
+ ij' = subword i j -- (j+dj)
+ oo = subword 0 0
+ in SvS s a b (t:.kj) (y':.ij') (z':.kj))
+ . addIndexDenseGo cs vs us is
+ addIndexDenseGo (cs:.c) (vs:.ORightOf (di:.dj)) (us:.Subword (_:.h)) (is:.Subword (i:.j))
+ = flatten mk step . addIndexDenseGo cs vs us is
+ where mk svS = return (svS :. j+dj)
+ step (svS@(SvS s a b t y' z') :. l)
+ | l <= h = let Subword (k:._) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ kl = subword k l
+ jj = subword (j+dj) (j+dj)
+ oo = subword 0 0
+ in return $ Yield (SvS s a b (t:.kl) (y':.jj) (z':.kl)) (svS :. l+1)
+ | otherwise = return Done
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ addIndexDenseGo _ (_:.OFirstLeft _) _ _ = error "SynVar.Indices.Subword : OFirstLeft"
+ addIndexDenseGo _ (_:.OLeftOf _) _ _ = error "SynVar.Indices.Subword : LeftOf"
+ {-# Inline addIndexDenseGo #-}
+
+-- |
+-- @
+-- Table: Inside
+-- Grammar: Outside
+-- @
+--
+-- TODO take care of @c@
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Subword O)
+ , GetIx a (is:.Subword O) ~ (Subword O)
+ ) => AddIndexDense a (us:.Subword I) (is:.Subword O) where
+ addIndexDenseGo (cs:.c) (vs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = map (\(SvS s a b t y' z') -> let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ ll@(Subword (_:.l)) = getIndex b (Proxy :: Proxy (is:.Subword O))
+ klI = subword (k-dj) (l-dj)
+ klO = subword (k-dj) (l-dj)
+ oo = subword 0 0
+ in SvS s a b (t:.klI) (y':.klO) (z':.ll))
+ . addIndexDenseGo cs vs us is
+ addIndexDenseGo (cs:.c) (vs:.ORightOf d) (us:.u) (is:.Subword (i:.j))
+ = flatten mk step . addIndexDenseGo cs vs us is
+ where mk svS = let Subword (_:.l) = getIndex (sIx svS) (Proxy :: Proxy (is:.Subword O))
+ in return (svS :. l :. l + csize)
+ step (svS@(SvS s a b t y' z') :. k :. l)
+ | l <= o = return $ Yield (SvS s a b (t:.klI) (y':.klO) (z':.zo))
+ (svS :. k :. l+1)
+ | otherwise = return $ Done
+ where zo@(Subword (_:.o)) = getIndex b (Proxy :: Proxy (is:.Subword O))
+ klI = subword k l
+ klO = subword k l
+ oo = subword 0 0
+ csize = minSize c
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ addIndexDenseGo (cs:.c) (vs:.OFirstLeft (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = map (\(SvS s a b t y' z') -> let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ ll@(Subword (l:._)) = getIndex b (Proxy :: Proxy (is:.Subword O))
+ klI = subword k $ i - di
+ klO = subword k $ i - di
+ oo = subword 0 0
+ in SvS s a b (t:.klI) (y':.klO) (z':.ll))
+ . addIndexDenseGo cs vs us is
+ addIndexDenseGo (cs:.c) (vs:.OLeftOf d) (us:.u) (is:.Subword (i:.j))
+ = flatten mk step . addIndexDenseGo cs vs us is
+ where mk svS = let Subword (_:.l) = getIndex (sIx svS) (Proxy :: Proxy (is:.Subword O))
+ in return $ svS :. l
+ step (svS@(SvS s a b t y' z') :. l)
+ | l <= i = let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ omx = getIndex b (Proxy :: Proxy (is:.Subword O))
+ klI = subword k l
+ klO = subword k l
+ oo = subword 0 0
+ in return $ Yield (SvS s a b (t:.klI) (y':.klO) (z':.omx))
+ (svS :. l+1)
+ | otherwise = return $ Done
+ csize = minSize c
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ {-# Inline addIndexDenseGo #-}
+
+
+
+
+-- TODO
+-- @
+-- Table: Inside
+-- Grammar: Complement
+-- @
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Subword C)
+ , GetIx a (is:.Subword C) ~ (Subword C)
+ ) => AddIndexDense a (us:.Subword I) (is:.Subword C) where
+ addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)
+ = map (\(SvS s a b t y' z') -> let Subword kk = getIndex a (Proxy :: Proxy (is:.Subword C))
+ kT = Subword kk -- @k@ Table
+ kC = Subword kk
+ in SvS s a b (t:.kT) (y':.kC) (z':.kC))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
+-- TODO
+-- @
+-- Table: Outside
+-- Grammar: Complement
+-- @
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Subword C)
+ , GetIx a (is:.Subword C) ~ (Subword C)
+ ) => AddIndexDense a (us:.Subword O) (is:.Subword C) where
+ addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)
+ = map (\(SvS s a b t y' z') -> let Subword kk = getIndex a (Proxy :: Proxy (is:.Subword C))
+ kT = Subword kk
+ kC = Subword kk
+ in SvS s a b (t:.kT) (y':.kC) (z':.kC))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
+-- |
+-- @
+-- Table: Complement
+-- Grammar: Complement
+-- @
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Subword C)
+ , GetIx a (is:.Subword C) ~ (Subword C)
+ ) => AddIndexDense a (us:.Subword C) (is:.Subword C) where
+ addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i)
+ = map (\(SvS s a b t y' z') -> let k = getIndex a (Proxy :: Proxy (is:.Subword C))
+ oo = subword 0 0
+ in SvS s a b (t:.k) (y':.k) (z':.oo))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
diff --git a/ADP/Fusion/SynVar/Indices/Unit.hs b/ADP/Fusion/SynVar/Indices/Unit.hs
new file mode 100644
index 0000000..a46c146
--- /dev/null
+++ b/ADP/Fusion/SynVar/Indices/Unit.hs
@@ -0,0 +1,58 @@
+
+-- | TODO if we have a table that has min-size @>0@ we need to immediately
+-- terminate @addIndexDenseGo@ !
+
+module ADP.Fusion.SynVar.Indices.Unit where
+
+import Data.Proxy
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))
+import Data.Vector.Fusion.Util (delay_inline)
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Indices.Classes
+
+
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Unit I)
+ , GetIx a (is:.Unit I) ~ (Unit I)
+ ) => AddIndexDense a (us:.Unit I) (is:.Unit I) where
+ addIndexDenseGo (cs:._) (vs:.IStatic ()) (us:._) (is:._)
+ = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Unit O)
+ , GetIx a (is:.Unit O) ~ (Unit O)
+ ) => AddIndexDense a (us:.Unit O) (is:.Unit O) where
+ addIndexDenseGo (cs:._) (vs:.OStatic ()) (us:._) (is:._)
+ = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Unit C)
+ , GetIx a (is:.Unit C) ~ (Unit C)
+ ) => AddIndexDense a (us:.Unit I) (is:.Unit C) where
+ addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._)
+ = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
+instance
+ ( AddIndexDense a us is
+ , GetIndex a (is:.Unit C)
+ , GetIx a (is:.Unit C) ~ (Unit C)
+ ) => AddIndexDense a (us:.Unit O) (is:.Unit C) where
+ addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._)
+ = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit))
+ . addIndexDenseGo cs vs us is
+ {-# Inline addIndexDenseGo #-}
+
diff --git a/ADP/Fusion/SynVar/Recursive/Subword.hs b/ADP/Fusion/SynVar/Recursive/Subword.hs
index 88b7b10..6aa7704 100644
--- a/ADP/Fusion/SynVar/Recursive/Subword.hs
+++ b/ADP/Fusion/SynVar/Recursive/Subword.hs
@@ -3,7 +3,6 @@ module ADP.Fusion.SynVar.Recursive.Subword where
import Data.Strict.Tuple
import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
import Data.Vector.Fusion.Util (delay_inline)
import Debug.Trace
import Prelude hiding (map)
diff --git a/ADP/Fusion/SynVar/Split/Subword.hs b/ADP/Fusion/SynVar/Split/Subword.hs
index 97c323d..bf80d29 100644
--- a/ADP/Fusion/SynVar/Split/Subword.hs
+++ b/ADP/Fusion/SynVar/Split/Subword.hs
@@ -1,10 +1,16 @@
+-- |
+--
+-- TODO Rewrite to use the new index-generating system.
+--
+-- TODO Take care of minsize constraints! These are somewhat tricky. We
+-- have one constraint for dimension in the table.
+
module ADP.Fusion.SynVar.Split.Subword where
import Data.Strict.Tuple
import Data.Proxy
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)
import Data.Vector.Fusion.Util (delay_inline)
import Debug.Trace
import GHC.TypeLits
@@ -24,15 +30,15 @@ import ADP.Fusion.SynVar.Split.Type
instance
( Monad m
- , Element ls Subword
- , MkStream m ls Subword
- ) => MkStream m (ls :!: Split uId Fragment (ITbl m arr j x)) Subword where
+ , Element ls (Subword I)
+ , MkStream m ls (Subword I)
+ ) => MkStream m (ls :!: Split uId Fragment (ITbl m arr j x)) (Subword I) where
mkStream (ls :!: Split _) (IStatic ()) hh (Subword (i:.j))
= map (\s -> let (Subword (_:.l)) = getIdx s
in ElmSplitITbl Proxy () (subword l j) (subword 0 0) s)
$ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
mkStream (ls :!: Split _) (IVariable ()) hh (Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))
+ = flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))
where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j - z
@@ -45,20 +51,20 @@ instance
instance
( Monad m
- , Element ls Subword
- , MkStream m ls Subword
- , SplitIxCol uId (SameSid uId (Elm ls Subword)) (Elm ls Subword)
- , (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) ~ mix
- , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) x)
- ) => MkStream m (ls :!: Split uId Final (ITbl m arr mix x)) Subword where
- mkStream (ls :!: Split (ITbl _ _ c t elm)) (IStatic ()) hh (Subword (i:.j))
+ , Element ls (Subword I)
+ , MkStream m ls (Subword I)
+ , SplitIxCol uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I))
+ , (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) ~ mix
+ , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) x)
+ ) => MkStream m (ls :!: Split uId Final (ITbl m arr mix x)) (Subword I) where
+ mkStream (ls :!: Split (ITbl _ _ (_:.c) t elm)) (IStatic ()) hh (Subword (i:.j))
= map (\s -> let (Subword (_:.l)) = getIdx s
fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. subword l j
in ElmSplitITbl Proxy (t ! fmbkm) (subword l j) (subword 0 0) s)
- $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
- mkStream (ls :!: Split (ITbl _ _ c t _)) (IVariable ()) hh (Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO - minSize c))
- where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
+ $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
+ mkStream (ls :!: Split (ITbl _ _ (_:.c) t _)) (IVariable ()) hh (Subword (i:.j))
+ = flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
+ where mk s = let Subword (_:.l) = getIdx s in return (s :. (delay_inline id $ j - l - minSize c))
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j - z
kl = subword k l
@@ -75,15 +81,15 @@ instance
instance
( Monad mB
- , Element ls Subword
- , MkStream mB ls Subword
- ) => MkStream mB (ls :!: Split uId Fragment (Backtrack (ITbl mF arr j x) mF mB r)) Subword where
- mkStream (ls :!: Split _) (IStatic ()) hh (Subword (i:.j))
+ , Element ls (Subword I)
+ , MkStream mB ls (Subword I)
+ ) => MkStream mB (ls :!: Split uId Fragment (Backtrack (ITbl mF arr j x) mF mB r)) (Subword I) where
+ mkStream (ls :!: Split (BtITbl _ _ _)) (IStatic ()) hh (Subword (i:.j))
= map (\s -> let (Subword (_:.l)) = getIdx s
in ElmSplitBtITbl Proxy () (subword l j) (subword 0 0) s)
$ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
mkStream (ls :!: Split _) (IVariable ()) hh (Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))
+ = flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see above) - minSize c))
where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j - z
@@ -96,22 +102,22 @@ instance
instance
( Monad mB
- , Element ls Subword
- , MkStream mB ls Subword
- , SplitIxCol uId (SameSid uId (Elm ls Subword)) (Elm ls Subword)
- , (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) ~ mix
- , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls Subword)) (Elm ls Subword) :. Subword) x)
- ) => MkStream mB (ls :!: Split uId Final (Backtrack (ITbl mF arr mix x) mF mB r)) Subword where
- mkStream (ls :!: Split (BtITbl c t bt)) (IStatic ()) hh (Subword (i:.j))
+ , Element ls (Subword I)
+ , MkStream mB ls (Subword I)
+ , SplitIxCol uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I))
+ , (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) ~ mix
+ , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) x)
+ ) => MkStream mB (ls :!: Split uId Final (Backtrack (ITbl mF arr mix x) mF mB r)) (Subword I) where
+ mkStream (ls :!: Split (BtITbl (_:.c) t bt)) (IStatic ()) hh (Subword (i:.j))
= mapM (\s -> let (Subword (_:.l)) = getIdx s
lj = subword l j
fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. lj
(_,hhhh) = bounds t -- This is an ugly hack, but we need a notation of higher bound from somewhere
in bt hhhh fmbkm >>= \ ~bb -> return $ ElmSplitBtITbl Proxy (t ! fmbkm,bb) lj (subword 0 0) s)
- $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO (see TODO in @Split@) - minSize c))
- mkStream (ls :!: Split (BtITbl c t bt)) (IVariable ()) hh (Subword (i:.j))
- = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j)) -- TODO - minSize c))
- where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l) -- TODO - minSize c)
+ $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
+ mkStream (ls :!: Split (BtITbl (_:.c) t bt)) (IVariable ()) hh (Subword (i:.j))
+ = flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j))
+ where mk s = let Subword (_:.l) = getIdx s in return (s :. (delay_inline id $ j - l - minSize c))
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j - z
kl = subword k l
diff --git a/ADP/Fusion/SynVar/Split/Type.hs b/ADP/Fusion/SynVar/Split/Type.hs
index 592e7a2..bad5243 100644
--- a/ADP/Fusion/SynVar/Split/Type.hs
+++ b/ADP/Fusion/SynVar/Split/Type.hs
@@ -11,7 +11,6 @@ module ADP.Fusion.SynVar.Split.Type
import Data.Proxy
import Data.Strict.Tuple
import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
import Data.Vector.Fusion.Util (delay_inline)
import Debug.Trace
import GHC.TypeLits
@@ -50,10 +49,19 @@ type family ArgTy argTy where
newtype Split (uId :: Symbol) {- (zOrder :: Nat) -} (splitType :: SplitType) synVar = Split { getSplit :: synVar }
+-- |
+--
+-- TODO Here, we probably want to default to a @NonEmpty@ condition. Or at
+-- least have different versions of @split@.
+
split :: Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar
split _ _ = Split
{-# Inline split #-}
+splitNE :: (ModifyConstraint synVar) => Proxy (uId::Symbol) -> {- Proxy (zOrder::Nat) -> -} Proxy (splitType::SplitType) -> synVar -> Split uId splitType synVar
+splitNE _ _ = Split . toNonEmpty
+{-# Inline splitNE #-}
+
--type Spl uId zOrder splitType = forall synVar . Split uId zOrder splitType synVar
instance Build (Split uId splitType synVar)
diff --git a/ADP/Fusion/Term/Chr.hs b/ADP/Fusion/Term/Chr.hs
index 8da6cc7..788d510 100644
--- a/ADP/Fusion/Term/Chr.hs
+++ b/ADP/Fusion/Term/Chr.hs
@@ -2,10 +2,12 @@
module ADP.Fusion.Term.Chr
( module ADP.Fusion.Term.Chr.Type
, module ADP.Fusion.Term.Chr.Point
+ , module ADP.Fusion.Term.Chr.Set0
, module ADP.Fusion.Term.Chr.Subword
) where
import ADP.Fusion.Term.Chr.Point
+import ADP.Fusion.Term.Chr.Set0
import ADP.Fusion.Term.Chr.Subword
import ADP.Fusion.Term.Chr.Type
diff --git a/ADP/Fusion/Term/Chr/Point.hs b/ADP/Fusion/Term/Chr/Point.hs
index fb0713a..fc65352 100644
--- a/ADP/Fusion/Term/Chr/Point.hs
+++ b/ADP/Fusion/Term/Chr/Point.hs
@@ -1,6 +1,7 @@
module ADP.Fusion.Term.Chr.Point where
+import Data.Proxy
import Data.Strict.Tuple
import Debug.Trace
import qualified Data.Vector.Fusion.Stream.Monadic as S
@@ -11,81 +12,65 @@ import Data.PrimitiveArray
import ADP.Fusion.Base
import ADP.Fusion.Term.Chr.Type
+import ADP.Fusion.Base.Term
+
+
+
+-- | First try in getting this right with a @termStream@.
+--
+-- TODO use @PointL i@ since this is probably the same for all single-tape
+-- instances with @ElmChr@.
+--
+-- TODO it might even be possible to auto-generate this code via TH.
instance
- ( Monad m
- , Element ls PointL
- , MkStream m ls PointL
- ) => MkStream m (ls :!: Chr r x) PointL where
- mkStream (ls :!: Chr f xs) (IStatic d) (PointL u) (PointL i)
- = staticCheck (i>0 && i<=u && i<= VG.length xs)
- $ S.map (ElmChr (f xs $ i-1) (PointL $ i) (PointL 0))
- $ mkStream ls (IStatic d) (PointL u) (PointL $ i-1)
- mkStream _ _ _ _ = error "mkStream / Chr / PointL can only be implemented for IStatic"
+ ( TmkCtx1 m ls (Chr r x) (PointL i)
+ ) => MkStream m (ls :!: Chr r x) (PointL i) where
+ mkStream (ls :!: Chr f xs) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmChr ee ii oo ss) -- recover ElmChr
+ . addTermStream1 (Chr f xs) sv us is
+ $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is)
{-# Inline mkStream #-}
+
+
+-- | Current first try for using @TermStream@
+--
+-- TODO what happens to fusion if @staticCheck@ happens before @S.map@?
+--
+-- NOTE / TODO a bit faster with @seq xs@ ?
+
instance
- ( Monad m
- , Element ls (Outside PointL)
- , MkStream m ls (Outside PointL)
- ) => MkStream m (ls :!: Chr r x) (Outside PointL) where
- mkStream (ls :!: Chr f xs) (OStatic d) (O (PointL u)) (O (PointL i))
- = S.map (\z -> let (O (PointL k)) = getOmx z in ElmChr (f xs $ k-d-1) (O . PointL $ k-d) (getOmx z) z)
- $ mkStream ls (OStatic $ d+1) (O $ PointL u) (O $ PointL i)
- mkStream _ _ _ _ = error "Chr.Point / mkStream / Chr / Outside.PointL can only be implemented for OStatic"
- {-# Inline mkStream #-}
+ ( TstCtx1 m ts a is (PointL I)
+ ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.PointL I) where
+ termStream (ts:|Chr f xs) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)
+ = seq xs . staticCheck (i>0 && i<=u && i<= VG.length xs)
+ . S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.PointL i) (oo:.PointL 0) (ee:. f xs (i-1)))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (PointL O)
+ ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.PointL O) where
+ termStream (ts:|Chr f xs) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)
+ = S.map (\(TState s a b ii oo ee) ->
+ let PointL k = getIndex a (Proxy :: Proxy (is:.PointL O))
+ o = getIndex b (Proxy :: Proxy (is:.PointL O))
+ in TState s a b (ii:.PointL (k-d+1)) (oo:.o) (ee:.f xs (k-d-1)))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
--- TODO @Inline [0]@ ???
-instance TermStaticVar (Chr r x) PointL where
+
+instance TermStaticVar (Chr r x) (PointL I) where
termStaticVar _ sv _ = sv
termStreamIndex _ _ (PointL j) = PointL $ j-1
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
-instance TermStaticVar (Chr r x) (Outside PointL) where
+instance TermStaticVar (Chr r x) (PointL O) where
termStaticVar _ (OStatic d) _ = OStatic (d+1)
termStreamIndex _ _ j = j
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
-
-instance
- ( Monad m
- , TerminalStream m a is
- ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointL) where
- terminalStream (a:|Chr f (!v)) (sv:.IStatic _) (is:.i@(PointL j))
- = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.f v (j-1)))
- . iPackTerminalStream a sv (is:.i)
- {-
- . terminalStream a sv is
- . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
- -}
- terminalStream (a:|Chr f (!v)) (sv:._) (is:.i@(PointL _))
- = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1))) -- TODO is the @l-1@ even right? is this part even called?
- . iPackTerminalStream a sv (is:.i)
- {-
- . terminalStream a sv is
- . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
- -}
- {-# INLINE terminalStream #-}
-
-instance
- ( Monad m
- , TerminalStream m a (Outside is)
- , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)
- ) => TerminalStream m (TermSymbol a (Chr r x)) (Outside (is:.PointL)) where
- terminalStream (a:|Chr f (!v)) (sv:.OStatic d) (O (is:.i))
- = S.map (\(S6 s (zi:._) (zo:.(PointL k)) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.f v (k-d-1)))
- . oPackTerminalStream a sv (O (is:.i))
- {-
- . terminalStream a sv (O is)
- . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))
- -}
- {-
- terminalStream (a:|Chr f (!v)) (sv:._) (is:.PointL i)
- = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1)))
- . terminalStream a sv is
- . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
- -}
- {-# INLINE terminalStream #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
diff --git a/ADP/Fusion/Term/Chr/Set0.hs b/ADP/Fusion/Term/Chr/Set0.hs
new file mode 100644
index 0000000..bbd8e45
--- /dev/null
+++ b/ADP/Fusion/Term/Chr/Set0.hs
@@ -0,0 +1,64 @@
+
+-- | @Chr@ on sets is equivalent to having a @Vertex@ symbol. Each bit
+-- denotes one vertex point.
+
+module ADP.Fusion.Term.Chr.Set0 where
+
+import Data.Proxy
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import Data.Vector.Fusion.Stream.Monadic as S
+import qualified Data.Vector.Generic as VG
+import Prelude hiding (map)
+import Data.Bits
+import Data.Bits.Extras (msb)
+import Data.Bits.Ordered
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.Term.Chr.Type
+
+
+
+instance
+ ( TmkCtx1 m ls (Chr r x) (BitSet i)
+ ) => MkStream m (ls :!: Chr r x) (BitSet i) where
+ mkStream (ls :!: Chr f xs) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmChr ee ii oo ss)
+ . addTermStream1 (Chr f xs) sv us is
+ $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is)
+ {-# Inline mkStream #-}
+
+instance
+ ( TstCtx1 m ts a is (BitSet I)
+ ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.BitSet I) where
+ termStream (ts:|Chr f xs) (cs:.IStatic rb) (us:.u) (is:.i)
+ = staticCheck (rb <= popCount i && i <= u && VG.length xs > msb u)
+ . S.flatten mk step . termStream ts cs us is
+ -- we task all set bits @bs@ and also the index @i@ and calculate
+ -- the non-set bits @mask@. The mask should have a popcount equal
+ -- to @rb + 1@. We then active bit 0 and proceed with @step@.
+ where mk svS = let bs = getIndex (tIx svS) (Proxy :: Proxy (is:.BitSet I))
+ mask = i `xor` bs
+ in {- traceShow ("Chr",i,bs,mask,lsbZ mask) $ -} return (svS :. mask :. lsbZ mask)
+ -- In case we can still do a step via @k>=0@, we active bit @k@
+ -- in @aa@.
+ step (svS@(TState s a b ii oo ee) :. mask :. k )
+ | k < 0 = return $ Done
+ | otherwise =
+ let aa = getIndex a (Proxy :: Proxy (is:.BitSet I))
+ in return $ Yield (TState s a b (ii:.setBit aa k) (oo:.0) (ee:.f xs k))
+ (svS :. mask :. nextActiveZ k mask)
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ {-# Inline termStream #-}
+
+instance TermStaticVar (Chr r x) (BitSet I) where
+ termStaticVar _ (IStatic rb) _ = IStatic $ rb + 1
+ termStaticVar _ (IVariable rb) _ = IVariable $ rb + 1
+ termStreamIndex _ _ b = b
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
diff --git a/ADP/Fusion/Term/Chr/Subword.hs b/ADP/Fusion/Term/Chr/Subword.hs
index 6bcf0c5..05afcab 100644
--- a/ADP/Fusion/Term/Chr/Subword.hs
+++ b/ADP/Fusion/Term/Chr/Subword.hs
@@ -1,6 +1,7 @@
module ADP.Fusion.Term.Chr.Subword where
+import Data.Proxy
import Data.Strict.Tuple
import Data.Vector.Fusion.Util (delay_inline)
import Debug.Trace
@@ -16,66 +17,80 @@ import ADP.Fusion.Term.Chr.Type
instance
- ( Monad m
- , Element ls Subword
- , MkStream m ls Subword
- ) => MkStream m (ls :!: Chr r x) Subword where
- mkStream (ls :!: Chr f xs) (IStatic ()) hh (Subword (i:.j))
- = staticCheck (i>=0 && i<j && j<= VG.length xs)
- $ map (ElmChr (f xs $ j-1) (subword (j-1) j) (subword 0 0))
- $ mkStream ls (IStatic ()) hh (delay_inline Subword (i:.j-1))
- mkStream (ls :!: Chr f xs) (IVariable ()) hh (Subword (i:.j))
- = map (\s -> let Subword (_:.l) = getIdx s
- in ElmChr (f xs l) (subword l (l+1)) (subword 0 0) s)
- $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j-1))
+ ( TmkCtx1 m ls (Chr r x) (Subword i)
+ ) => MkStream m (ls :!: Chr r x) (Subword i) where
+ mkStream (ls :!: Chr f xs) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmChr ee ii oo ss)
+ . addTermStream1 (Chr f xs) sv us is
+ $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is)
{-# Inline mkStream #-}
-instance
- ( Monad m
- , Element ls (Outside Subword)
- , MkStream m ls (Outside Subword)
- ) => MkStream m (ls :!: Chr r x) (Outside Subword) where
- mkStream (ls :!: Chr f xs) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
- = id -- staticCheck ( j < h ) -- TODO any check possible?
- $ map (\s -> let (O (Subword (_:.k'))) = getIdx s
- k = k'-dj-1
- in ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)
- $ mkStream ls (OStatic (di:.dj+1)) u ij
- mkStream (ls :!: Chr f xs) (ORightOf (di:.dj)) u ij
- = map (\s -> let (O (Subword (_:.k'))) = getIdx s
- k = k'-dj-1
- in ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)
- $ mkStream ls (ORightOf (di:.dj+1)) u ij
- mkStream (ls :!: Chr f xs) (OFirstLeft (di:.dj)) u ij
- = id
- $ map (\s -> let (O (Subword (_:.k))) = getIdx s
- in ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)
- $ mkStream ls (OFirstLeft (di+1:.dj)) u ij
- mkStream (ls :!: Chr f xs) (OLeftOf (di:.dj)) u ij
- = map (\s -> let (O (Subword (_:.k))) = getIdx s
- in ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)
- $ mkStream ls (OLeftOf (di+1:.dj)) u ij
- {-# Inline mkStream #-}
+instance
+ ( TstCtx1 m ts a is (Subword I)
+ ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.Subword I) where
+ termStream (ts:|Chr f xs) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))
+ = staticCheck (i>=0 && i < j && j <= VG.length xs)
+ . map (\(TState s a b ii oo ee) ->
+ TState s a b (ii:.subword (j-1) j) (oo:.subword 0 0) (ee:.f xs (j-1)) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Chr f xs) (cs:.IVariable ()) (us:.u) (is:.Subword (i:.j))
+ = map (\(TState s a b ii oo ee) ->
+ let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ in TState s a b (ii:.subword l (l+1)) (oo:.subword 0 0) (ee:.f xs l) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
instance
- ( Monad m
- , TerminalStream m a is
- ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.Subword) where
- terminalStream (a:|Chr f v) (sv:.IStatic _) (is:.ix@(Subword (i:.j)))
- -- TODO check if 'staticCheck' breaks fusion!!!
- = staticCheck (i>=0 && i<j && j<=VG.length v)
- . S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword (j-1) j) (os:.subword 0 0) (e:.f v (j-1)))
- . iPackTerminalStream a sv (is:.ix)
- terminalStream (a:|Chr f v) (sv:.IVariable _) (is:.ix@(Subword (i:.j)))
- = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l (l+1)) (os:.subword 0 0) (e:.f v l))
- . iPackTerminalStream a sv (is:.ix)
- {-# Inline terminalStream #-}
-
-instance TermStaticVar (Chr r x) Subword where
+ ( TstCtx1 m ts a is (Subword O)
+ ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.Subword O) where
+ termStream (ts:|Chr f xs) (cs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ l = k - dj
+ in TState s a b (ii:.subword k (k+1)) (oo:.o) (ee:.f xs k) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Chr f xs) (cs:.ORightOf (di:.dj)) (us:.u) (is:.i)
+ = map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ l = k - dj - 1
+ in TState s a b (ii:.subword (k-1) k) (oo:.o) (ee:.f xs l) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Chr f xs) (cs:.OFirstLeft (di:.dj)) (us:.u) (is:.i)
+ = map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ in TState s a b (ii:.subword k (k+1)) (oo:.o) (ee:.f xs k) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Chr f xs) (cs:.OLeftOf (di:.dj)) (us:.u) (is:.i)
+ = map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ in TState s a b (ii:.subword k (k+1)) (oo:.o) (ee:.f xs k) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+
+
+instance TermStaticVar (Chr r x) (Subword I) where
termStaticVar _ sv _ = sv
termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1)
{-# Inline [0] termStaticVar #-}
{-# Inline [0] termStreamIndex #-}
+instance TermStaticVar (Chr r x) (Subword O) where
+ termStaticVar _ (OStatic (di:.dj)) _ = OStatic (di :.dj+1)
+ termStaticVar _ (ORightOf (di:.dj)) _ = ORightOf (di :.dj+1)
+ termStaticVar _ (OFirstLeft (di:.dj)) _ = OFirstLeft (di+1:.dj )
+ termStaticVar _ (OLeftOf (di:.dj)) _ = OLeftOf (di+1:.dj )
+ termStreamIndex _ _ sw = sw
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
diff --git a/ADP/Fusion/Term/Chr/Type.hs b/ADP/Fusion/Term/Chr/Type.hs
index 16b3a9d..fa539a3 100644
--- a/ADP/Fusion/Term/Chr/Type.hs
+++ b/ADP/Fusion/Term/Chr/Type.hs
@@ -1,4 +1,10 @@
+-- |
+--
+-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of
+-- a char parser. But this is only semantics, so not super important to do
+-- now.
+
module ADP.Fusion.Term.Chr.Type where
import Data.Strict.Tuple
@@ -52,5 +58,5 @@ instance
deriving instance (Show i, Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)
-type instance TermArg (TermSymbol a (Chr r x)) = TermArg a :. r
+type instance TermArg (Chr r x) = r
diff --git a/ADP/Fusion/Term/Deletion.hs b/ADP/Fusion/Term/Deletion.hs
index 0e29a1a..3eac3b7 100644
--- a/ADP/Fusion/Term/Deletion.hs
+++ b/ADP/Fusion/Term/Deletion.hs
@@ -3,11 +3,13 @@ module ADP.Fusion.Term.Deletion
( module ADP.Fusion.Term.Deletion.Type
, module ADP.Fusion.Term.Deletion.Point
, module ADP.Fusion.Term.Deletion.Subword
+ , module ADP.Fusion.Term.Deletion.Unit
) where
import ADP.Fusion.Term.Deletion.Point
import ADP.Fusion.Term.Deletion.Subword
import ADP.Fusion.Term.Deletion.Type
+import ADP.Fusion.Term.Deletion.Unit
{-
diff --git a/ADP/Fusion/Term/Deletion/Point.hs b/ADP/Fusion/Term/Deletion/Point.hs
index a6eba8b..cba56e4 100644
--- a/ADP/Fusion/Term/Deletion/Point.hs
+++ b/ADP/Fusion/Term/Deletion/Point.hs
@@ -1,6 +1,7 @@
module ADP.Fusion.Term.Deletion.Point where
+import Data.Proxy
import Data.Strict.Tuple
import qualified Data.Vector.Fusion.Stream.Monadic as S
@@ -12,51 +13,46 @@ import ADP.Fusion.Term.Deletion.Type
instance
- ( Monad m
- , MkStream m ls PointL
- ) => MkStream m (ls :!: Deletion) PointL where
- mkStream (ls :!: Deletion) (IStatic d) (PointL u) (PointL i)
- = S.map (ElmDeletion (PointL i) (PointL 0))
- $ mkStream ls (IStatic d) (PointL u) (PointL i)
+ ( TmkCtx1 m ls Deletion (PointL i)
+ ) => MkStream m (ls :!: Deletion) (PointL i) where
+ mkStream (ls :!: Deletion) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmDeletion ii oo ss)
+ . addTermStream1 Deletion sv us is
+ $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is)
{-# Inline mkStream #-}
+
+
instance
- ( Monad m
- , Element ls (Outside PointL)
- , MkStream m ls (Outside PointL)
- ) => MkStream m (ls :!: Deletion) (Outside PointL) where
- mkStream (ls :!: Deletion) (OStatic d) (O (PointL u)) (O (PointL i))
- = S.map (\z -> ElmDeletion (O $ PointL i) (getOmx z) z)
- $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)
- {-# Inline mkStream #-}
+ ( TstCtx1 m ts a is (PointL I)
+ ) => TermStream m (TermSymbol ts Deletion) a (is:.PointL I) where
+ termStream (ts:|Deletion) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)
+ = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.PointL i) (oo:.PointL 0) (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (PointL O)
+ ) => TermStream m (TermSymbol ts Deletion) a (is:.PointL O) where
+ termStream (ts:|Deletion) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)
+ = S.map (\(TState s a b ii oo ee) ->
+ let i' = getIndex a (Proxy :: Proxy (is:.PointL O))
+ o' = getIndex b (Proxy :: Proxy (is:.PointL O))
+ in TState s a b (ii:.i') (oo:.o') (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
-instance TermStaticVar Deletion PointL where
+
+instance TermStaticVar Deletion (PointL I) where
termStaticVar _ sv _ = sv
termStreamIndex _ _ (PointL j) = PointL j
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
-instance TermStaticVar Deletion (Outside PointL) where
+instance TermStaticVar Deletion (PointL O) where
termStaticVar _ (OStatic d) _ = OStatic d
termStreamIndex _ _ j = j
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
-
-instance
- ( Monad m
- , TerminalStream m a is
- ) => TerminalStream m (TermSymbol a Deletion) (is:.PointL) where
- terminalStream (a:|Deletion) (sv:.IStatic _) (is:.i@(PointL j))
- = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))
- . iPackTerminalStream a sv (is:.i)
- {-# Inline terminalStream #-}
-
-instance
- ( Monad m
- , TerminalStream m a (Outside is)
- ) => TerminalStream m (TermSymbol a Deletion) (Outside (is:.PointL)) where
- terminalStream (a:|Deletion) (sv:.OStatic d) (O (is:.i))
- = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))
- . oPackTerminalStream a sv (O (is:.i))
- {-# Inline terminalStream #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
diff --git a/ADP/Fusion/Term/Deletion/Subword.hs b/ADP/Fusion/Term/Deletion/Subword.hs
index 2f12e1b..0a71229 100644
--- a/ADP/Fusion/Term/Deletion/Subword.hs
+++ b/ADP/Fusion/Term/Deletion/Subword.hs
@@ -1,6 +1,7 @@
module ADP.Fusion.Term.Deletion.Subword where
+import Data.Proxy
import Data.Strict.Tuple
import Data.Vector.Fusion.Stream.Monadic as S
import Prelude hiding (map)
@@ -13,20 +14,76 @@ import ADP.Fusion.Term.Deletion.Type
instance
- ( Monad m
- , TerminalStream m a is
- ) => TerminalStream m (TermSymbol a Deletion) (is:.Subword) where
- terminalStream (a:|Deletion) (sv:.IStatic _) (is:.ij@(Subword (i:.j)))
- = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword j j) (os:.subword 0 0) (e:.()))
- . iPackTerminalStream a sv (is:.ij)
- terminalStream (a:|Deletion) (sv:.IVariable _) (is:.ij@(Subword (i:.j)))
- = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l l) (os:.subword 0 0) (e:.()))
- . iPackTerminalStream a sv (is:.ij)
- {-# Inline terminalStream #-}
-
-instance TermStaticVar Deletion Subword where
+ ( TmkCtx1 m ls Deletion (Subword i)
+ ) => MkStream m (ls :!: Deletion) (Subword i) where
+ mkStream (ls :!: Deletion) sv us is
+ = map (\(ss,ee,ii,oo) -> ElmDeletion ii oo ss)
+ . addTermStream1 Deletion sv us is
+ $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is)
+ {-# Inline mkStream #-}
+
+
+
+instance
+ ( TstCtx1 m ts a is (Subword I)
+ ) => TermStream m (TermSymbol ts Deletion) a (is:.Subword I) where
+ termStream (ts:|Deletion) (cs:.IStatic d) (us:.u) (is:.Subword (i:.j))
+ = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.subword j j) (oo:.subword 0 0) (ee:.()) )
+ . termStream ts cs us is
+ termStream (ts:|Deletion) (cs:.IVariable d) (us:.u) (is:.Subword (i:.j))
+ = S.map (\(TState s a b ii oo ee) ->
+ let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ in TState s a b (ii:.subword l l) (oo:.subword 0 0) (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (Subword O)
+ ) => TermStream m (TermSymbol ts Deletion) a (is:.Subword O) where
+ -- X_ij -> Y_ik Z_kj d_jj 0 i Y k Z j-j N
+ -- Y^_ik -> X^_ij Z_kj d_jj 0 x i k Z j-j x N
+ -- Z^_kj -> Y_ik X^_ij d_jj 0 x i Y k j-j x N
+ termStream (ts:|Deletion) (cs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = S.map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ in TState s a b (ii:.subword k k) (oo:.o) (ee:.()) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Deletion) (cs:.ORightOf (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = S.map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ l = k - dj -- TODO needed ?
+ in TState s a b (ii:.subword k k) (oo:.o) (ee:.()) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Deletion) (cs:.OFirstLeft (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = S.map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ in TState s a b (ii:.subword k k) (oo:.o) (ee:.()) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Deletion) (cs:.OLeftOf (di:.dj)) (us:.u) (is:.Subword (i:.j))
+ = S.map (\(TState s a b ii oo ee) ->
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o = getIndex b (Proxy :: Proxy (is:.Subword O))
+ in TState s a b (ii:.subword k k) (oo:.o) (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+
+
+instance TermStaticVar Deletion (Subword I) where
+ termStaticVar _ sv _ = sv
+ termStreamIndex _ _ ij = ij
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
+instance TermStaticVar Deletion (Subword O) where
termStaticVar _ sv _ = sv
termStreamIndex _ _ ij = ij
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
diff --git a/ADP/Fusion/Term/Deletion/Type.hs b/ADP/Fusion/Term/Deletion/Type.hs
index bb2f430..d5d9f79 100644
--- a/ADP/Fusion/Term/Deletion/Type.hs
+++ b/ADP/Fusion/Term/Deletion/Type.hs
@@ -23,5 +23,5 @@ instance (Element ls i) => Element (ls :!: Deletion) i where
{-# Inline getIdx #-}
{-# Inline getOmx #-}
-type instance TermArg (TermSymbol a Deletion) = TermArg a :. ()
+type instance TermArg Deletion = ()
diff --git a/ADP/Fusion/Term/Deletion/Unit.hs b/ADP/Fusion/Term/Deletion/Unit.hs
new file mode 100644
index 0000000..3584188
--- /dev/null
+++ b/ADP/Fusion/Term/Deletion/Unit.hs
@@ -0,0 +1,55 @@
+
+module ADP.Fusion.Term.Deletion.Unit where
+
+import Data.Proxy
+import Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Base
+import ADP.Fusion.Term.Deletion.Type
+
+
+
+instance
+ ( TmkCtx1 m ls Deletion (Unit i)
+ ) => MkStream m (ls :!: Deletion) (Unit i) where
+ mkStream (ls :!: Deletion) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmDeletion ii oo ss)
+ . addTermStream1 Deletion sv us is
+ $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is)
+ {-# Inline mkStream #-}
+
+
+
+instance
+ ( TstCtx1 m ts a is (Unit I)
+ ) => TermStream m (TermSymbol ts Deletion) a (is:.Unit I) where
+ termStream (ts:|Deletion) (cs:.IStatic ()) (us:._) (is:._)
+ = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (Unit O)
+ ) => TermStream m (TermSymbol ts Deletion) a (is:.Unit O) where
+ termStream (ts:|Deletion) (cs:.OStatic ()) (us:._) (is:._)
+ = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+
+
+instance TermStaticVar Deletion (Unit I) where
+ termStaticVar _ _ _ = IStatic ()
+ termStreamIndex _ _ _ = Unit
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
+instance TermStaticVar Deletion (Unit O) where
+ termStaticVar _ _ _ = OStatic ()
+ termStreamIndex _ _ _ = Unit
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
diff --git a/ADP/Fusion/Term/Edge/Set.hs b/ADP/Fusion/Term/Edge/Set.hs
index 5de4b12..4f5160c 100644
--- a/ADP/Fusion/Term/Edge/Set.hs
+++ b/ADP/Fusion/Term/Edge/Set.hs
@@ -3,8 +3,7 @@ module ADP.Fusion.Term.Edge.Set where
import Data.Bits
import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Monadic
-import Data.Vector.Fusion.Stream.Size
+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)
import Debug.Trace
import Prelude hiding (map)
@@ -18,30 +17,30 @@ import ADP.Fusion.Term.Edge.Type
instance
( Monad m
- , Element ls (BS2I First Last)
- , MkStream m ls (BS2I First Last)
- ) => MkStream m (ls :!: Edge e) (BS2I First Last) where
- mkStream (ls :!: Edge f) (IStatic rp) u sij@(s:>i:>j)
- = flatten mk step Unknown $ mkStream ls (IStatic rpn) u tik
+ , Element ls (BS2 First Last I)
+ , MkStream m ls (BS2 First Last I)
+ ) => MkStream m (ls :!: Edge e) (BS2 First Last I) where
+ mkStream (ls :!: Edge f) (IStatic rp) u sij@(BS2 s i j)
+ = flatten mk step $ mkStream ls (IStatic rpn) u tik
where rpn | j >= 0 = rp
| otherwise = rp+1
- tik | j >= 0 = s `clearBit` (getIter j) :> i :> undefi
+ tik | j >= 0 = BS2 (s `clearBit` (getIter j)) i undefi
| otherwise = sij
mk z
| j >= 0 && popCount s >= 2 = return $ This z
| j < 0 && popCount s >= 2 = return $ That (z,bits,maybeLsb bits)
| popCount s <= max 1 rp = return $ Naught
| otherwise = error $ show ("Edge",s,i,j)
- where (zs:>_:>zk) = getIdx z
+ where (BS2 zs _ zk) = getIdx z
bits = s `xor` zs
step Naught = return Done
step (This z)
| popCount zs == 0 = return $ Done
| otherwise = return $ Yield (ElmEdge (f (getIter zk) (getIter j)) sij undefbs2i z) Naught
- where (zs:>_:>zk) = getIdx z
+ where (BS2 zs _ zk) = getIdx z
step (That (z,bits,Nothing)) = return $ Done
- step (That (z,bits,Just j')) = let (zs:>_:>Iter zk) = getIdx z
- tij' = (zs .|. bit j') :> Iter zk :> Iter j'
+ step (That (z,bits,Just j')) = let (BS2 zs _ (Iter zk)) = getIdx z
+ tij' = BS2 (zs .|. bit j') (Iter zk) (Iter j')
in return $ Yield (ElmEdge (f zk j') tij' undefbs2i z) (That (z,bits,maybeNextActive j' bits))
{-# Inline [0] mk #-}
{-# Inline [0] step #-}
@@ -51,9 +50,9 @@ instance
instance
( Monad m
- , Element ls (Outside (BS2I First Last))
- , MkStream m ls (Outside (BS2I First Last))
- ) => MkStream m (ls :!: Edge f) (Outside (BS2I First Last)) where
+ , Element ls (BS2 First Last O)
+ , MkStream m ls (BS2 First Last O)
+ ) => MkStream m (ls :!: Edge f) (BS2 First Last O) where
mkStream (ls :!: Edge f) (OStatic ()) u sij
= map undefined
$ mkStream ls (undefined) u sij
@@ -63,9 +62,9 @@ instance
instance
( Monad m
- , Element ls (Complement (BS2I First Last))
- , MkStream m ls (Complement (BS2I First Last))
- ) => MkStream m (ls :!: Edge f) (Complement (BS2I First Last)) where
+ , Element ls (BS2 First Last C)
+ , MkStream m ls (BS2 First Last C)
+ ) => MkStream m (ls :!: Edge f) (BS2 First Last C) where
mkStream (ls :!: Edge f) Complemented u sij
= map undefined
$ mkStream ls Complemented u sij
diff --git a/ADP/Fusion/Term/Edge/Type.hs b/ADP/Fusion/Term/Edge/Type.hs
index 00cd845..a0da58f 100644
--- a/ADP/Fusion/Term/Edge/Type.hs
+++ b/ADP/Fusion/Term/Edge/Type.hs
@@ -28,5 +28,5 @@ instance
deriving instance (Show i, Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i)
-type instance TermArg (TermSymbol a (Edge e)) = TermArg a :. e
+type instance TermArg (Edge e) = e
diff --git a/ADP/Fusion/Term/Epsilon.hs b/ADP/Fusion/Term/Epsilon.hs
index e96b522..e6f902b 100644
--- a/ADP/Fusion/Term/Epsilon.hs
+++ b/ADP/Fusion/Term/Epsilon.hs
@@ -2,12 +2,16 @@
module ADP.Fusion.Term.Epsilon
( module ADP.Fusion.Term.Epsilon.Type
, module ADP.Fusion.Term.Epsilon.Point
+ , module ADP.Fusion.Term.Epsilon.Set
, module ADP.Fusion.Term.Epsilon.Subword
+ , module ADP.Fusion.Term.Epsilon.Unit
) where
import ADP.Fusion.Term.Epsilon.Point
+import ADP.Fusion.Term.Epsilon.Set
import ADP.Fusion.Term.Epsilon.Subword
import ADP.Fusion.Term.Epsilon.Type
+import ADP.Fusion.Term.Epsilon.Unit
{-
diff --git a/ADP/Fusion/Term/Epsilon/Point.hs b/ADP/Fusion/Term/Epsilon/Point.hs
index a804469..45f544a 100644
--- a/ADP/Fusion/Term/Epsilon/Point.hs
+++ b/ADP/Fusion/Term/Epsilon/Point.hs
@@ -1,6 +1,7 @@
module ADP.Fusion.Term.Epsilon.Point where
+import Data.Proxy
import Data.Strict.Tuple
import qualified Data.Vector.Fusion.Stream.Monadic as S
@@ -12,51 +13,46 @@ import ADP.Fusion.Term.Epsilon.Type
instance
- ( Monad m
- , MkStream m ls PointL
- ) => MkStream m (ls :!: Epsilon) PointL where
- mkStream (ls :!: Epsilon) (IStatic d) (PointL u) (PointL i)
- = S.map (ElmEpsilon (PointL i) (PointL 0))
- $ mkStream ls (IStatic d) (PointL u) (PointL i)
+ ( TmkCtx1 m ls Epsilon (PointL i)
+ ) => MkStream m (ls :!: Epsilon) (PointL i) where
+ mkStream (ls :!: Epsilon) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss)
+ . addTermStream1 Epsilon sv us is
+ $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)
{-# Inline mkStream #-}
+
+
instance
- ( Monad m
- , Element ls (Outside PointL)
- , MkStream m ls (Outside PointL)
- ) => MkStream m (ls :!: Epsilon) (Outside PointL) where
- mkStream (ls :!: Epsilon) (OStatic d) (O (PointL u)) (O (PointL i))
- = S.map (\z -> ElmEpsilon (O $ PointL i) (getOmx z) z)
- $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)
- {-# Inline mkStream #-}
+ ( TstCtx1 m ts a is (PointL I)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.PointL I) where
+ termStream (ts:|Epsilon) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)
+ = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.PointL i) (oo:.PointL 0) (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (PointL O)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.PointL O) where
+ termStream (ts:|Epsilon) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)
+ = S.map (\(TState s a b ii oo ee) ->
+ let i' = getIndex a (Proxy :: Proxy (is:.PointL O))
+ o' = getIndex b (Proxy :: Proxy (is:.PointL O))
+ in TState s a b (ii:.i') (oo:.o') (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
-instance TermStaticVar Epsilon PointL where
+
+instance TermStaticVar Epsilon (PointL I) where
termStaticVar _ sv _ = sv
termStreamIndex _ _ (PointL j) = PointL j
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
-instance TermStaticVar Epsilon (Outside PointL) where
+instance TermStaticVar Epsilon (PointL O) where
termStaticVar _ (OStatic d) _ = OStatic d
termStreamIndex _ _ j = j
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
-
-instance
- ( Monad m
- , TerminalStream m a is
- ) => TerminalStream m (TermSymbol a Epsilon) (is:.PointL) where
- terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.i@(PointL j))
- = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))
- . iPackTerminalStream a sv (is:.i)
- {-# Inline terminalStream #-}
-
-instance
- ( Monad m
- , TerminalStream m a (Outside is)
- ) => TerminalStream m (TermSymbol a Epsilon) (Outside (is:.PointL)) where
- terminalStream (a:|Epsilon) (sv:.OStatic d) (O (is:.i))
- = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))
- . oPackTerminalStream a sv (O (is:.i))
- {-# Inline terminalStream #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
diff --git a/ADP/Fusion/Term/Epsilon/Set.hs b/ADP/Fusion/Term/Epsilon/Set.hs
new file mode 100644
index 0000000..b11bc3f
--- /dev/null
+++ b/ADP/Fusion/Term/Epsilon/Set.hs
@@ -0,0 +1,98 @@
+
+module ADP.Fusion.Term.Epsilon.Set where
+
+import Data.Proxy
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Monadic as S
+import Prelude hiding (map)
+
+import Data.Bits.Ordered
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.Term.Epsilon.Type
+
+
+
+-- ** No boundaries
+
+instance
+ ( TmkCtx1 m ls Epsilon (BitSet i)
+ ) => MkStream m (ls :!: Epsilon) (BitSet i) where
+ mkStream (ls :!: Epsilon) sv us is
+ = map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss)
+ . addTermStream1 Epsilon sv us is
+ $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)
+ {-# Inline mkStream #-}
+
+
+
+instance
+ ( TstCtx1 m ts a is (BitSet I)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.BitSet I) where
+ termStream (ts:|Epsilon) (cs:.IStatic r) (us:.u) (is:.i)
+ = staticCheck (i==0)
+ . map (\(TState s a b ii oo ee) ->
+ TState s a b (ii:.0) (oo:.0) (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (BitSet O)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.BitSet O) where
+ termStream (ts:|Epsilon) (cs:.OStatic r) (us:.u) (is:.i)
+ = staticCheck (i==u)
+ . map (\(TState s a b ii oo ee) ->
+ TState s a b (ii:.u) (oo:.u) (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+
+
+instance TermStaticVar Epsilon (BitSet I) where
+ termStaticVar _ sv _ = sv
+ termStreamIndex _ _ b = b
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
+instance TermStaticVar Epsilon (BitSet O) where
+ termStaticVar _ sv _ = sv
+ termStreamIndex _ _ b = b
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
+
+
+-- ** Two boundaries
+
+instance
+ ( TmkCtx1 m ls Epsilon (BS2 First Last i)
+ ) => MkStream m (ls :!: Epsilon) (BS2 First Last i) where
+ mkStream (ls :!: Epsilon) sv us is
+ = map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss)
+ . addTermStream1 Epsilon sv us is
+ $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)
+ {-# Inline mkStream #-}
+
+instance
+ ( TstCtx1 m ts a is (BS2 First Last I)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.BS2 First Last I) where
+ termStream (ts:|Epsilon) (cs:.IStatic r) (us:.u) (is:.BS2 bs _ _)
+ = staticCheck (bs==0)
+ . map (\(TState s a b ii oo ee) ->
+ TState s a b (ii:.BS2 0 0 0) (oo:.BS2 0 0 0) (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (BS2 First Last O)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.BS2 First Last O) where
+ termStream (ts:|Epsilon) (cs:.OStatic r) (us:.BS2 ub uf ul) (is:.BS2 bs f l)
+ = staticCheck (ub==bs)
+ . map (\(TState s a b ii oo ee) ->
+ let i' = getIndex a (Proxy :: Proxy (is:.BS2 First Last O))
+ o' = getIndex b (Proxy :: Proxy (is:.BS2 First Last O))
+ in TState s a b (ii:.i') (oo:.o') (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
diff --git a/ADP/Fusion/Term/Epsilon/Subword.hs b/ADP/Fusion/Term/Epsilon/Subword.hs
index c00b472..6604379 100644
--- a/ADP/Fusion/Term/Epsilon/Subword.hs
+++ b/ADP/Fusion/Term/Epsilon/Subword.hs
@@ -1,6 +1,7 @@
module ADP.Fusion.Term.Epsilon.Subword where
+import Data.Proxy
import Data.Strict.Tuple
import Data.Vector.Fusion.Stream.Monadic as S
import Prelude hiding (map)
@@ -10,44 +11,52 @@ import Data.PrimitiveArray hiding (map)
import ADP.Fusion.Base
import ADP.Fusion.Term.Epsilon.Type
---import Data.Vector.Fusion.Util
+
+
+instance
+ ( TmkCtx1 m ls Epsilon (Subword i)
+ ) => MkStream m (ls :!: Epsilon) (Subword i) where
+ mkStream (ls :!: Epsilon) sv us is
+ = map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss)
+ . addTermStream1 Epsilon sv us is
+ $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)
+ {-# Inline mkStream #-}
instance
- ( Monad m
- , MkStream m ls Subword
- ) => MkStream m (ls :!: Epsilon) Subword where
- mkStream (ls :!: Epsilon) (IStatic ()) hh ij@(Subword (i:.j))
+ ( TstCtx1 m ts a is (Subword I)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.Subword I) where
+ termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.u) (is:.Subword (i:.j))
= staticCheck (i==j)
- $ map (ElmEpsilon (subword i j) (subword 0 0))
- $ mkStream ls (IStatic ()) hh ij
- {-# Inline mkStream #-}
+ . map (\(TState s a b ii oo ee) ->
+ TState s a b (ii:.subword i j) (oo:.subword 0 0) (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
instance
- ( Monad m
- , MkStream m ls (Outside Subword)
- ) => MkStream m (ls :!: Epsilon) (Outside Subword) where
- mkStream (ls :!: Epsilon) (OStatic d) u ij@(O (Subword (i:.j)))
- = map (ElmEpsilon (O $ subword i j) (O $ subword i j))
- $ mkStream ls (OStatic d) u ij
- {-# Inline mkStream #-}
+ ( TstCtx1 m ts a is (Subword O)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.Subword O) where
+ termStream (ts:|Epsilon) (cs:.OStatic d) (us:.Subword (ui:.uj)) (is:.Subword (i:.j))
+ = staticCheck (ui == i && uj == j) -- TODO correct ?
+ . map (\(TState s a b ii oo ee) ->
+ let i' = getIndex a (Proxy :: Proxy (is:.Subword O))
+ o' = getIndex b (Proxy :: Proxy (is:.Subword O))
+ in TState s a b (ii:.i') (oo:.o') (ee:.()) )
+ . termStream ts cs us is
+ {-# Inline termStream #-}
-instance
- ( Monad m
- , TerminalStream m a is
- ) => TerminalStream m (TermSymbol a Epsilon) (is:.Subword) where
- terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.ij@(Subword (i:.j)))
- = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.subword i j) (os:.subword 0 0) (e:.()))
- . iPackTerminalStream a sv (is:.ij)
- {-# Inline terminalStream #-}
-
-instance TermStaticVar Epsilon Subword where
+instance TermStaticVar Epsilon (Subword I) where
termStaticVar _ sv _ = sv
termStreamIndex _ _ ij = ij
- {-# Inline termStaticVar #-}
- {-# Inline termStreamIndex #-}
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+instance TermStaticVar Epsilon (Subword O) where
+ termStaticVar _ sv _ = sv
+ termStreamIndex _ _ ij = ij
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
diff --git a/ADP/Fusion/Term/Epsilon/Type.hs b/ADP/Fusion/Term/Epsilon/Type.hs
index 4bbe73a..0c6f04c 100644
--- a/ADP/Fusion/Term/Epsilon/Type.hs
+++ b/ADP/Fusion/Term/Epsilon/Type.hs
@@ -23,5 +23,5 @@ instance (Element ls i) => Element (ls :!: Epsilon) i where
{-# Inline getIdx #-}
{-# Inline getOmx #-}
-type instance TermArg (TermSymbol a Epsilon) = TermArg a :. ()
+type instance TermArg Epsilon = ()
diff --git a/ADP/Fusion/Term/Epsilon/Unit.hs b/ADP/Fusion/Term/Epsilon/Unit.hs
new file mode 100644
index 0000000..32af877
--- /dev/null
+++ b/ADP/Fusion/Term/Epsilon/Unit.hs
@@ -0,0 +1,55 @@
+
+module ADP.Fusion.Term.Epsilon.Unit where
+
+import Data.Proxy
+import Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Base
+import ADP.Fusion.Term.Epsilon.Type
+
+
+
+instance
+ ( TmkCtx1 m ls Epsilon (Unit i)
+ ) => MkStream m (ls :!: Epsilon) (Unit i) where
+ mkStream (ls :!: Epsilon) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss)
+ . addTermStream1 Epsilon sv us is
+ $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)
+ {-# Inline mkStream #-}
+
+
+
+instance
+ ( TstCtx1 m ts a is (Unit I)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.Unit I) where
+ termStream (ts:|Epsilon) (cs:.IStatic ()) (us:._) (is:._)
+ = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (Unit O)
+ ) => TermStream m (TermSymbol ts Epsilon) a (is:.Unit O) where
+ termStream (ts:|Epsilon) (cs:.OStatic ()) (us:._) (is:._)
+ = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.()))
+ . termStream ts cs us is
+ {-# Inline termStream #-}
+
+
+
+instance TermStaticVar Epsilon (Unit I) where
+ termStaticVar _ _ _ = IStatic ()
+ termStreamIndex _ _ _ = Unit
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
+instance TermStaticVar Epsilon (Unit O) where
+ termStaticVar _ _ _ = OStatic ()
+ termStreamIndex _ _ _ = Unit
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
+
diff --git a/ADP/Fusion/Term/PeekIndex/Subword.hs b/ADP/Fusion/Term/PeekIndex/Subword.hs
index 862e807..2668e1b 100644
--- a/ADP/Fusion/Term/PeekIndex/Subword.hs
+++ b/ADP/Fusion/Term/PeekIndex/Subword.hs
@@ -14,9 +14,9 @@ import ADP.Fusion.Term.PeekIndex.Type
instance
( Monad m
- , Element ls (Complement Subword)
- , MkStream m ls (Complement Subword)
- ) => MkStream m (ls :!: PeekIndex (Complement Subword)) (Complement Subword) where
+ , Element ls (Subword C)
+ , MkStream m ls (Subword C)
+ ) => MkStream m (ls :!: PeekIndex (Subword C)) (Subword C) where
mkStream (ls :!: PeekIndex) Complemented h ij
= map (\s -> ElmPeekIndex (getIdx s) (getOmx s) s)
$ mkStream ls Complemented h ij
diff --git a/ADP/Fusion/Term/PeekIndex/Type.hs b/ADP/Fusion/Term/PeekIndex/Type.hs
index 57d03db..566742e 100644
--- a/ADP/Fusion/Term/PeekIndex/Type.hs
+++ b/ADP/Fusion/Term/PeekIndex/Type.hs
@@ -27,5 +27,5 @@ instance
deriving instance (Show i, Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)
-type instance TermArg (TermSymbol a (PeekIndex i)) = TermArg a :. PeekIndex i
+type instance TermArg (PeekIndex i) = PeekIndex i
diff --git a/ADP/Fusion/Term/Strng/Point.hs b/ADP/Fusion/Term/Strng/Point.hs
index bb62c87..5779886 100644
--- a/ADP/Fusion/Term/Strng/Point.hs
+++ b/ADP/Fusion/Term/Strng/Point.hs
@@ -1,6 +1,7 @@
module ADP.Fusion.Term.Strng.Point where
+import Data.Proxy
import Data.Strict.Tuple
import Debug.Trace
import qualified Data.Vector.Fusion.Stream.Monadic as S
@@ -14,30 +15,84 @@ import ADP.Fusion.Term.Strng.Type
instance
- ( Monad m
- , Element ls PointL
- , MkStream m ls PointL
- ) => MkStream m (ls :!: Strng v x) PointL where
- mkStream (ls :!: Strng f minL maxL xs) (IStatic d) (PointL u) (PointL i)
- = staticCheck (i - minL >= 0 && i <= u && minL <= maxL)
- $ S.map (\z -> let PointL j = getIdx z in ElmStrng (f j (i-j) xs) (PointL i) (PointL 0) z)
- $ mkStream ls (IVariable $ d + maxL - minL) (PointL u) (PointL $ i - minL)
- mkStream _ _ _ _ = error "mkStream / Strng / PointL / IVariable"
+ ( TmkCtx1 m ls (Strng v x) (PointL i)
+ ) => MkStream m (ls :!: Strng v x) (PointL i) where
+ mkStream (ls :!: strng@(Strng _ minL maxL xs)) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmStrng ee ii oo ss)
+ . addTermStream1 strng sv us is
+ $ mkStream ls (termStaticVar strng sv is) us (termStreamIndex strng sv is)
{-# Inline mkStream #-}
-instance TermStaticVar (Strng v x) PointL where
- termStaticVar _ (IStatic d) _ = IVariable d
- termStaticVar _ (IVariable d) _ = IVariable d
+
+
+instance
+ ( TstCtx1 m ts a is (PointL I)
+ ) => TermStream m (TermSymbol ts (Strng v x)) a (is:.PointL I) where
+ --
+ termStream (ts:|Strng f minL maxL v) (cs:.IStatic d) (us:.PointL u) (is:.PointL i)
+ = S.map (\(TState s a b ii oo ee) ->
+ let PointL k = getIndex a (Proxy :: Proxy (is:.PointL I))
+ in TState s a b (ii:.PointL i) (oo:.PointL 0) (ee:.f k (i-k) v))
+ . termStream ts cs us is
+ --
+ termStream (ts:|Strng f minL maxL v) (cs:.IVariable d) (us:.PointL u) (is:.PointL i)
+ = S.flatten mk step . termStream ts cs us is
+ where mk (tstate@(TState s a b ii oo ee)) =
+ let PointL k = getIndex a (Proxy :: Proxy (is:.PointL I))
+ in return (tstate, i-k-d-minL)
+ step (tstate@(TState s a b ii oo ee), z)
+ | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s a b (ii:.PointL l) (oo:.o) (ee:.f k (l-k+1) v)) (tstate, z-1)
+ | otherwise = return $ S.Done
+ where PointL k = getIndex a (Proxy :: Proxy (is:.PointL I))
+ o = PointL 0
+ l = i - z - d
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ {-# Inline termStream #-}
+
+instance
+ ( TstCtx1 m ts a is (PointL O)
+ ) => TermStream m (TermSymbol ts (Strng v x)) a (is:.PointL O) where
+ --
+ termStream (ts:|Strng f minL maxL v) (cs:.OStatic d) (us:.PointL u) (is:.PointL i)
+ = S.map (\(TState s a b ii oo ee) ->
+ let PointL k = getIndex a (Proxy :: Proxy (is:.PointL O))
+ o = getIndex b (Proxy :: Proxy (is:.PointL O))
+ in TState s a b (ii:.PointL (i-d+1)) (oo:.o) (ee:.f k (i-k) v)) -- @i-d+1 or k-d+1@ ?
+ . termStream ts cs us is
+ --
+ termStream (ts:|Strng f minL maxL v) (cs:.ORightOf d) (us:.PointL u) (is:.PointL i)
+ = S.flatten mk step . termStream ts cs us is
+ where mk (tstate@(TState s a b ii oo ee)) =
+ let PointL k = getIndex a (Proxy :: Proxy (is:.PointL O))
+ in return (tstate, i-k-d-minL)
+ step (tstate@(TState s a b ii oo ee), z)
+ | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s a b (ii:.PointL l) (oo:.o) (ee:.f k (l-k+1) v)) (tstate, z-1)
+ | otherwise = return $ S.Done
+ where PointL k = getIndex a (Proxy :: Proxy (is:.PointL O))
+ o = getIndex b (Proxy :: Proxy (is:.PointL O))
+ l = i - z - d
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ {-# Inline termStream #-}
+
+
+
+instance TermStaticVar (Strng v x) (PointL I) where
+ termStaticVar (Strng _ minL maxL _) (IStatic d) _ = IVariable $ d + maxL - minL
+ termStaticVar _ (IVariable d) _ = IVariable d -- TODO is this right?
+ --
termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL
+ --
{-# Inline [0] termStaticVar #-}
{-# Inline [0] termStreamIndex #-}
-instance
- ( Monad m
- , TerminalStream m a is
- ) => TerminalStream m (TermSymbol a (Strng v x)) (is:.PointL) where
- terminalStream (a:|Strng f minL maxL xs) (sv:.IStatic d) (is:.i@(PointL j))
- = S.map (\(S6 s (zi:.PointL pi) (zo:._) is os e) -> S6 s zi zo (is:.i) (os:.PointL 0) (e:.f pi (j-pi) xs))
- . iPackTerminalStream a sv (is:.i)
- {-# Inline terminalStream #-}
+instance TermStaticVar (Strng v x) (PointL O) where
+ termStaticVar (Strng _ minL maxL _) (OStatic d) _ = ORightOf $ d + maxL - minL
+ termStaticVar _ (ORightOf d) _ = ORightOf 0 -- TODO is this right?
+ --
+ termStreamIndex _ _ j = j
+ --
+ {-# Inline [0] termStaticVar #-}
+ {-# Inline [0] termStreamIndex #-}
diff --git a/ADP/Fusion/Term/Strng/Subword.hs b/ADP/Fusion/Term/Strng/Subword.hs
index 3b6a924..0749984 100644
--- a/ADP/Fusion/Term/Strng/Subword.hs
+++ b/ADP/Fusion/Term/Strng/Subword.hs
@@ -1,9 +1,8 @@
module ADP.Fusion.Term.Strng.Subword where
-
+import Data.Proxy
import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Size
import Data.Vector.Fusion.Util (delay_inline)
import Debug.Trace
import Prelude hiding (map)
@@ -17,21 +16,54 @@ import ADP.Fusion.Term.Strng.Type
+instance
+ ( TmkCtx1 m ls (Strng v x) (Subword i)
+ ) => MkStream m (ls :!: Strng v x) (Subword i) where
+ mkStream (ls :!: strng) sv us is
+ = S.map (\(ss,ee,ii,oo) -> ElmStrng ee ii oo ss)
+ . addTermStream1 strng sv us is
+ $ mkStream ls (termStaticVar strng sv is) us (termStreamIndex strng sv is)
+ {-# Inline mkStream #-}
+
+instance
+ ( TstCtx1 m ts a is (Subword I)
+ ) => TermStream m (TermSymbol ts (Strng v x)) a (is:.Subword I) where
+ --
+ termStream (ts:|Strng f minL maxL v) (cs:.IStatic d) (us:.Subword (ui:.uj)) (is:.Subword (i:.j))
+ = S.filter (\(TState _ a _ _ _ _) -> let Subword (k:.l) = getIndex a (Proxy :: Proxy (is:.Subword I)) in l-k <= maxL)
+ . S.map (\(TState s a b ii oo ee) ->
+ let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ o = getIndex b (Proxy :: Proxy (is:.Subword I))
+ in TState s a b (ii:.subword l j) (oo:.o) (ee:.f l (j-l) v) )
+ . termStream ts cs us is
+ --
+ termStream (ts:|Strng f minL maxL v) (cs:.IVariable d) (us:._) (is:.Subword (i:.j))
+ = S.flatten mk step . termStream ts cs us is
+ where mk (tstate@(TState s a b ii oo ee)) =
+ let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword I))
+ in return (tstate, k+minL, min j (k+maxL))
+ step = undefined
+ {-# Inline [0] mk #-}
+ {-# Inline [0] step #-}
+ {-# Inline termStream #-}
+
+{-
+
-- | TODO If we use (IVariable mx) we might be able to request @exactly@
-- the range we need!
instance
( Monad m
- , Element ls Subword
- , MkStream m ls Subword
- ) => MkStream m (ls :!: Strng v x) Subword where
+ , Element ls (Subword I)
+ , MkStream m ls (Subword I)
+ ) => MkStream m (ls :!: Strng v x) (Subword I) where
mkStream (ls :!: Strng slice mn mx v) (IStatic ()) hh (Subword (i:.j))
= S.filter (\s -> let Subword (k:.l) = getIdx s in l-k <= mx)
. S.map (\s -> let (Subword (_:.l)) = getIdx s
in ElmStrng (slice l (j-l) v) (subword l j) (subword 0 0) s)
$ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn))
mkStream (ls :!: Strng slice mn mx v) (IVariable ()) hh (Subword (i:.j))
- = S.flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn))
+ = S.flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn))
where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - mn)
step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
l = j - z
@@ -42,3 +74,5 @@ instance
{-# Inline [0] step #-}
{-# Inline mkStream #-}
+-}
+
diff --git a/ADP/Fusion/Term/Strng/Type.hs b/ADP/Fusion/Term/Strng/Type.hs
index 53cc9fb..1cb0e53 100644
--- a/ADP/Fusion/Term/Strng/Type.hs
+++ b/ADP/Fusion/Term/Strng/Type.hs
@@ -52,5 +52,5 @@ instance
deriving instance (Show i, Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i)
-type instance TermArg (TermSymbol a (Strng v x)) = TermArg a :. v x
+type instance TermArg (Strng v x) = v x
diff --git a/ADPfusion.cabal b/ADPfusion.cabal
index 5404e29..f675624 100644
--- a/ADPfusion.cabal
+++ b/ADPfusion.cabal
@@ -1,5 +1,5 @@
name: ADPfusion
-version: 0.4.1.1
+version: 0.5.0.0
author: Christian Hoener zu Siederdissen, 2011-2015
copyright: Christian Hoener zu Siederdissen, 2011-2015
homepage: https://github.com/choener/ADPfusion
@@ -11,7 +11,7 @@ license-file: LICENSE
build-type: Simple
stability: experimental
cabal-version: >= 1.10.0
-tested-with: GHC == 7.8.4, GHC == 7.10.1
+tested-with: GHC == 7.8.4, GHC == 7.10.2
synopsis: Efficient, high-level dynamic programming.
description:
<http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>
@@ -62,24 +62,23 @@ flag debug
library
--- ghc-prim: for reallyUnsafePtrEquality#
build-depends: base >= 4.7 && < 4.9
, bits >= 0.4 && < 0.5
, containers
- , ghc-prim
, mmorph >= 1.0 && < 1.1
, monad-primitive >= 0.1 && < 0.2
, mtl >= 2.0 && < 2.3
- , OrderedBits >= 0.0.0.1 && < 0.0.1
+ , OrderedBits >= 0.0.1.0 && < 0.0.2.0
, primitive >= 0.5.4 && < 0.7
- , PrimitiveArray >= 0.6.1 && < 0.6.2
+ , PrimitiveArray >= 0.7.0 && < 0.7.1
, QuickCheck >= 2.7 && < 2.9
+ , singletons >= 1.1 && < 1.2
, strict >= 0.3 && < 0.4
, template-haskell >= 2.0 && < 3.0
, th-orphans >= 0.12 && < 0.13
, transformers >= 0.3 && < 0.5
, tuple >= 0.3 && < 0.4
- , vector >= 0.10 && < 0.11
+ , vector >= 0.11 && < 0.12
exposed-modules:
ADP.Fusion
@@ -90,21 +89,22 @@ library
ADP.Fusion.Base.Point
ADP.Fusion.Base.Set
ADP.Fusion.Base.Subword
- ADP.Fusion.QuickCheck.Common
- ADP.Fusion.QuickCheck.Point
- ADP.Fusion.QuickCheck.Set
- ADP.Fusion.QuickCheck.Subword
+ ADP.Fusion.Base.Term
+ ADP.Fusion.Base.TyLvlIx
+ ADP.Fusion.Base.Unit
ADP.Fusion.SynVar
ADP.Fusion.SynVar.Array
- ADP.Fusion.SynVar.Array.Point
- ADP.Fusion.SynVar.Array.Set
- ADP.Fusion.SynVar.Array.Subword
ADP.Fusion.SynVar.Array.TermSymbol
ADP.Fusion.SynVar.Array.Type
ADP.Fusion.SynVar.Axiom
ADP.Fusion.SynVar.Backtrack
ADP.Fusion.SynVar.Fill
ADP.Fusion.SynVar.Indices
+ ADP.Fusion.SynVar.Indices.Classes
+ ADP.Fusion.SynVar.Indices.Point
+ ADP.Fusion.SynVar.Indices.Set0
+ ADP.Fusion.SynVar.Indices.Subword
+ ADP.Fusion.SynVar.Indices.Unit
ADP.Fusion.SynVar.Recursive
ADP.Fusion.SynVar.Recursive.Point
ADP.Fusion.SynVar.Recursive.Subword
@@ -115,19 +115,23 @@ library
ADP.Fusion.Term
ADP.Fusion.Term.Chr
ADP.Fusion.Term.Chr.Point
+ ADP.Fusion.Term.Chr.Set0
ADP.Fusion.Term.Chr.Subword
ADP.Fusion.Term.Chr.Type
ADP.Fusion.Term.Deletion
ADP.Fusion.Term.Deletion.Point
ADP.Fusion.Term.Deletion.Subword
ADP.Fusion.Term.Deletion.Type
+ ADP.Fusion.Term.Deletion.Unit
ADP.Fusion.Term.Edge
ADP.Fusion.Term.Edge.Set
ADP.Fusion.Term.Edge.Type
ADP.Fusion.Term.Epsilon
ADP.Fusion.Term.Epsilon.Point
+ ADP.Fusion.Term.Epsilon.Set
ADP.Fusion.Term.Epsilon.Subword
ADP.Fusion.Term.Epsilon.Type
+ ADP.Fusion.Term.Epsilon.Unit
ADP.Fusion.Term.PeekIndex
ADP.Fusion.Term.PeekIndex.Subword
ADP.Fusion.Term.PeekIndex.Type
@@ -140,6 +144,8 @@ library
ADP.Fusion.TH.Common
default-extensions: BangPatterns
+ , ConstraintKinds
+ , CPP
, DataKinds
, DefaultSignatures
, FlexibleContexts
@@ -152,6 +158,7 @@ library
, ScopedTypeVariables
, StandaloneDeriving
, TemplateHaskell
+ , TupleSections
, TypeFamilies
, TypeOperators
, TypeSynonymInstances
@@ -455,19 +462,39 @@ test-suite properties
exitcode-stdio-1.0
main-is:
properties.hs
+ other-modules:
+ QuickCheck.Common
+ QuickCheck.Point
+ QuickCheck.Set
+ QuickCheck.Subword
ghc-options:
-threaded -rtsopts -with-rtsopts=-N
hs-source-dirs:
tests
default-language:
Haskell2010
- default-extensions: TemplateHaskell
+ default-extensions: BangPatterns
+ , CPP
+ , FlexibleContexts
+ , FlexibleInstances
+ , MultiParamTypeClasses
+ , TemplateHaskell
+ , TypeFamilies
+ , TypeOperators
+ , TypeSynonymInstances
+ cpp-options:
+ -DADPFUSION_TEST_SUITE_PROPERTIES
build-depends: base
, ADPfusion
+ , bits
+ , OrderedBits
+ , PrimitiveArray
, QuickCheck
+ , strict
, test-framework >= 0.8 && < 0.9
, test-framework-quickcheck2 >= 0.3 && < 0.4
, test-framework-th >= 0.2 && < 0.3
+ , vector
diff --git a/changelog.md b/changelog.md
index 9aa02f5..f00acfb 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,3 +1,12 @@
+0.5.0.0
+-------
+
+- complete re-design of Inside / Outside / Complement handling based on phantom
+ types
+- very liberal combination of multi-tape grammars
+- simplified index generation system (both faster, and easier to write new
+ symbol now)
+
0.4.1.1
-------
diff --git a/src/Durbin.hs b/src/Durbin.hs
index 6218edb..16752a9 100644
--- a/src/Durbin.hs
+++ b/src/Durbin.hs
@@ -26,7 +26,7 @@ import Data.List
import Data.Vector.Fusion.Util
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
-import qualified Data.Vector.Fusion.Stream as S
+--import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.Environment (getArgs)
@@ -96,6 +96,7 @@ grammar Durbin{..} c t' =
spl <<< tt % tt ... h
)
tt = toNonEmpty t
+ {-# Inline tt #-}
in (Z:.t)
{-# INLINE grammar #-}
@@ -106,10 +107,11 @@ runDurbin k inp = (d, take k . unId $ axiom b) where
!(Z:.t) = mutateTablesDefault
$ grammar bpmax
(chr i)
- (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) :: Z:.ITbl Id Unboxed Subword Int
+ (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) :: Z:.ITbl Id Unboxed (Subword I) Int
-- d = let (ITbl _ _ arr _) = t in arr PA.! subword 0 n
d = iTblArray t PA.! subword 0 n
!(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))
+{-# NoInline runDurbin #-}
main = do
as <- getArgs
diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs
index 98f54c9..a522ee1 100644
--- a/src/NeedlemanWunsch.hs
+++ b/src/NeedlemanWunsch.hs
@@ -28,7 +28,6 @@ import Data.Vector.Fusion.Util
import Debug.Trace
import qualified Control.Arrow as A
import qualified Data.Vector as V
-import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.Environment (getArgs)
@@ -241,7 +240,7 @@ runNeedlemanWunsch k i1' i2' = (d, take k bs) where
-- For your own code, you can write as done here, or in the way of
-- 'runOutsideNeedlemanWunsch'.
-nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.PointL:.PointL) Int
+nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.PointL I:.PointL I) Int
nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $
grammar sScore
(ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))
@@ -250,7 +249,7 @@ nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $
n2 = VU.length i2
{-# NoInline nwInsideForward #-}
-nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.PointL:.PointL) Int -> [[String]]
+nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.PointL I:.PointL I) Int -> [[String]]
nwInsideBacktrack i1 i2 t = {-# SCC "nwInsideBacktrack" #-} unId $ axiom b
where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
{-# NoInline nwInsideBacktrack #-}
@@ -268,17 +267,17 @@ runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId
n2 = VU.length i2
!(Z:.t) = nwOutsideForward i1 i2
-- d = let (ITbl _ _ arr _) = t in arr PA.! (O (Z:.PointL 0:.PointL 0))
- d = iTblArray t PA.! (O (Z:.PointL 0:.PointL 0))
+ d = iTblArray t PA.! (Z:.PointL 0:.PointL 0)
!(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
{-# Noinline runOutsideNeedlemanWunsch #-}
-- | Again, to be able to observe performance, we have extracted the
-- outside-table-filling part.
-nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Outside (Z:.PointL:.PointL)) Int
+nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.PointL O:.PointL O) Int
nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $
grammar sScore
- (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (O (Z:.PointL 0:.PointL 0)) (O (Z:.PointL n1:.PointL n2)) (-999999) []))
+ (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))
i1 i2
where n1 = VU.length i1
n2 = VU.length i2
diff --git a/src/Nussinov.hs b/src/Nussinov.hs
index ef92717..a58c043 100644
--- a/src/Nussinov.hs
+++ b/src/Nussinov.hs
@@ -13,7 +13,7 @@ import Data.Vector.Fusion.Util
import Debug.Trace
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
-import qualified Data.Vector.Fusion.Stream as S
+--import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.Environment (getArgs)
@@ -108,7 +108,7 @@ runNussinov k inp = (d, take k bs) where
bs = runInsideBacktrack i t
{-# NOINLINE runNussinov #-}
-runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed Subword Int
+runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed (Subword I) Int
runInsideForward i = mutateTablesDefault
$ grammar bpmax
(chr i)
@@ -116,7 +116,7 @@ runInsideForward i = mutateTablesDefault
where n = VU.length i
{-# NoInline runInsideForward #-}
-runInsideBacktrack :: VU.Vector Char -> ITbl Id Unboxed Subword Int -> [String]
+runInsideBacktrack :: VU.Vector Char -> ITbl Id Unboxed (Subword I) Int -> [String]
runInsideBacktrack i t = unId $ axiom b
where !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))
{-# NoInline runInsideBacktrack #-}
diff --git a/src/OverlappingPalindromes.hs b/src/OverlappingPalindromes.hs
index 959607c..5f4b0d1 100644
--- a/src/OverlappingPalindromes.hs
+++ b/src/OverlappingPalindromes.hs
@@ -26,7 +26,6 @@ import Data.Vector.Fusion.Util
import Debug.Trace
import qualified Control.Arrow as A
import qualified Data.Vector as V
-import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.Environment (getArgs)
@@ -141,8 +140,8 @@ opForward i =
i
{-# NoInline opForward #-}
-type X = ITbl Id Unboxed Subword Int
-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int
+type X = ITbl Id Unboxed (Subword I) Int
+type T = ITbl Id Unboxed (Z:.Subword I:.Subword I) Int
main :: IO ()
diff --git a/src/PartNussinov.hs b/src/PartNussinov.hs
index 1cdec8c..fbbdf92 100644
--- a/src/PartNussinov.hs
+++ b/src/PartNussinov.hs
@@ -14,7 +14,6 @@ import Debug.Trace
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Numeric.Log as Log
-import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.Environment (getArgs)
@@ -135,17 +134,17 @@ ensemble
-> NussinovEnsemble
m
(Log Double)
- (Complement Subword:.(Complement Subword))
- (Subword, Log Double)
- [(Subword, Log Double)]
+ (Subword C:.Subword C)
+ (Subword C, Log Double)
+ [(Subword C, Log Double)]
ensemble z = NussinovEnsemble
- { ens = \ x (C k:._) y -> ( k , x * y / z )
+ { ens = \ x (Subword k:._) y -> ( Subword k , x * y / z )
, hhh = SM.toList
}
{-# Inline ensemble #-}
ensembleGrammar NussinovEnsemble{..} i o v' =
- let v = v' ( ens <<< i % (PeekIndex :: PeekIndex (Complement Subword)) % o ... hhh )
+ let v = v' ( ens <<< i % (PeekIndex :: PeekIndex (Subword C)) % o ... hhh )
in Z:.v
{-# Inline ensembleGrammar #-}
@@ -155,7 +154,7 @@ ensembleGrammar NussinovEnsemble{..} i o v' =
-- * Run different algorithm parts
-runNussinov :: String -> ([(Subword, Log Double)], Log Double, [(Int,Int, Log Double, Log Double, Log Double, Log Double)])
+runNussinov :: String -> ([(Subword C, Log Double)], Log Double, [(Int,Int, Log Double, Log Double, Log Double, Log Double)])
runNussinov inp = (es,z,ys) where
i = VU.fromList . Prelude.map toUpper $ inp
n = VU.length i
@@ -165,13 +164,13 @@ runNussinov inp = (es,z,ys) where
za = let (ITbl _ _ _ arr _) = a in arr PA.! subword 0 n
zp = let (ITbl _ _ _ arr _) = p in arr PA.! subword 0 n
z = za
- e = let (ITbl _ _ _ arr _) = b in Log.sum [ arr PA.! (O $ subword k k) | k <- [0 .. n] ]
+ e = let (ITbl _ _ _ arr _) = b in Log.sum [ arr PA.! (subword k k) | k <- [0 .. n] ]
ys = [ ( k
, l
, fwda PA.! subword k l
, fwdp PA.! subword k l
- , bwdb PA.! (O $ subword k l)
- , bwdq PA.! (O $ subword k l)
+ , bwdb PA.! subword k l
+ , bwdq PA.! subword k l
)
| let (ITbl _ _ _ fwda _) = a
, let (ITbl _ _ _ fwdp _) = p
@@ -203,8 +202,8 @@ neat i = do let (es,z,ys) = runNussinov i
forM_ es $ \ (Subword (i:.j),v) -> printf "%3d %3d %0.4f\n" i j (exp $ ln v)
putStrLn ""
-type TblI = ITbl Id Unboxed Subword (Log Double)
-type TblO = ITbl Id Unboxed (Outside Subword) (Log Double)
+type TblI = ITbl Id Unboxed (Subword I) (Log Double)
+type TblO = ITbl Id Unboxed (Subword O) (Log Double)
runInsideForward :: VU.Vector Char -> Z:.TblI:.TblI
runInsideForward i = mutateTablesDefault
@@ -220,18 +219,18 @@ runOutsideForward i a p = mutateTablesDefault
$ outsideGrammar prob
(chr i)
a p
- (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))
- (ITbl 0 1 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))
+ (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))
+ (ITbl 0 1 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 []))
where n = VU.length i
{-# NoInline runOutsideForward #-}
-runEnsembleForward :: Log Double -> TblI -> TblO -> [ (Subword,Log Double) ]
+runEnsembleForward :: Log Double -> TblI -> TblO -> [ (Subword C,Log Double) ]
runEnsembleForward z i o = unId $ axiom g
where (Z:.g) = ensembleGrammar (ensemble z)
i o
- (IRec EmptyOk (C l) (C h))
- :: Z :. IRec Id (Complement Subword) [(Subword, Log Double)]
- (l,h) = let (ITbl _ _ _ arr _) = i in bounds arr
+ (IRec EmptyOk (Subword l) (Subword h))
+ :: Z :. IRec Id (Subword C) [(Subword C, Log Double)]
+ (Subword l,Subword h) = let (ITbl _ _ _ arr _) = i in bounds arr
{-# NoInline runEnsembleForward #-}
{-
diff --git a/src/Pseudoknot.hs b/src/Pseudoknot.hs
index e5df2e8..59e43f5 100644
--- a/src/Pseudoknot.hs
+++ b/src/Pseudoknot.hs
@@ -10,7 +10,6 @@ import Data.Vector.Fusion.Util
import Debug.Trace
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
-import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.Environment (getArgs)
@@ -80,10 +79,12 @@ pretty = Nussinov
}
{-# INLINE pretty #-}
+-- |
+
grammar Nussinov{..} t' u' v' c =
- let t = t' ( unp <<< t % c |||
+ let t = t' ( unp <<< t % c |||
jux <<< t % c % t % c |||
- nil <<< Epsilon |||
+ nil <<< Epsilon |||
pse <<< (split (Proxy :: Proxy "U") (Proxy :: Proxy Fragment) u)
% (split (Proxy :: Proxy "V") (Proxy :: Proxy Fragment) v)
% (split (Proxy :: Proxy "U") (Proxy :: Proxy Final) u)
@@ -114,8 +115,8 @@ runPseudoknot k inp = (d, take k bs) where
-}
{-# NOINLINE runPseudoknot #-}
-type X = ITbl Id Unboxed Subword Int
-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int
+type X = ITbl Id Unboxed (Subword I) Int
+type T = ITbl Id Unboxed (Z:.Subword I:.Subword I) Int
runInsideForward :: VU.Vector Char -> Z:.X:.T:.T
runInsideForward i = mutateTablesWithHints (Proxy :: Proxy MonotoneMCFG)
diff --git a/src/SplitTests.hs b/src/SplitTests.hs
index de2a378..7890127 100644
--- a/src/SplitTests.hs
+++ b/src/SplitTests.hs
@@ -26,7 +26,6 @@ import Data.Vector.Fusion.Util
import Debug.Trace
import qualified Control.Arrow as A
import qualified Data.Vector as V
-import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.Environment (getArgs)
@@ -121,8 +120,8 @@ opForward i =
i
{-# NoInline opForward #-}
-type X = ITbl Id Unboxed Subword Int
-type T = ITbl Id Unboxed (Z:.Subword:.Subword) Int
+type X = ITbl Id Unboxed (Subword I) Int
+type T = ITbl Id Unboxed (Z:.Subword I:.Subword I) Int
main :: IO ()
diff --git a/ADP/Fusion/QuickCheck/Common.hs b/tests/QuickCheck/Common.hs
index 701444f..4efd3e0 100644
--- a/ADP/Fusion/QuickCheck/Common.hs
+++ b/tests/QuickCheck/Common.hs
@@ -1,7 +1,7 @@
{-# Options_GHC -O0 #-}
-module ADP.Fusion.QuickCheck.Common where
+module QuickCheck.Common where
import Debug.Trace
diff --git a/ADP/Fusion/QuickCheck/Point.hs b/tests/QuickCheck/Point.hs
index 87e201d..1505fd4 100644
--- a/ADP/Fusion/QuickCheck/Point.hs
+++ b/tests/QuickCheck/Point.hs
@@ -1,20 +1,24 @@
{-# Options_GHC -O0 #-}
-module ADP.Fusion.QuickCheck.Point where
+module QuickCheck.Point where
import Control.Applicative
import Control.Monad
import Data.Strict.Tuple
import Data.Vector.Fusion.Util
import Debug.Trace
-import qualified Data.Vector.Fusion.Stream as S
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.IO.Unsafe
import Test.QuickCheck
import Test.QuickCheck.All
import Test.QuickCheck.Monadic
+#ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+import Test.Framework.TH
+import Test.Framework.Providers.QuickCheck2
+#endif
+
import Data.PrimitiveArray
@@ -25,61 +29,69 @@ import ADP.Fusion
-- * Epsilon cases
prop_Epsilon ix@(PointL j) = zs == ls where
- zs = (id <<< Epsilon ... S.toList) maxPL ix
+ zs = (id <<< Epsilon ... stoList) maxPLi ix
ls = [ () | j == 0 ]
-prop_O_Epsilon ix@(O (PointL j)) = zs == ls where
- zs = (id <<< Epsilon ... S.toList) (O maxPL) ix
- ls = [ () | j == 100 ]
+prop_O_Epsilon ix@(PointL j) = zs == ls where
+ zs = (id <<< Epsilon ... stoList) maxPLo ix
+ ls = [ () | j == maxI ]
prop_ZEpsilon ix@(Z:.PointL j) = zs == ls where
- zs = (id <<< (M:|Epsilon) ... S.toList) (Z:.maxPL) ix
+ zs = (id <<< (M:|Epsilon) ... stoList) (Z:.maxPLi) ix
ls = [ Z:.() | j == 0 ]
-prop_O_ZEpsilon ix@(O (Z:.PointL j)) = zs == ls where
- zs = (id <<< (M:|Epsilon) ... S.toList) (O (Z:.maxPL)) ix
- ls = [ Z:.() | j == 100 ]
+prop_O_ZEpsilon ix@(Z:.PointL j) = zs == ls where
+ zs = (id <<< (M:|Epsilon) ... stoList) (Z:.maxPLo) ix
+ ls = [ Z:.() | j == maxI ]
-prop_O_ZEpsilonEpsilon ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
- zs = (id <<< (M:|Epsilon:|Epsilon) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
- ls = [ Z:.():.() | j == 100, l == 100 ]
+prop_O_ZEpsilonEpsilon ix@(Z:.PointL j:.PointL l) = zs == ls where
+ zs = (id <<< (M:|Epsilon:|Epsilon) ... stoList) (Z:.maxPLo:.maxPLo) ix
+ ls = [ Z:.():.() | j == maxI, l == maxI ]
-- * Deletion cases
-prop_O_ItNC ix@(O (PointL j)) = zs == ls where
+prop_ItNC ix@(PointL j) = zs == ls where
+ t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
+ zs = ((,,) <<< t % Deletion % chr xs ... stoList) maxPLi ix
+ ls = [ ( unsafeIndex xsP (PointL $ j-1)
+ , ()
+ , xs VU.! (j-1)
+ ) | j >= 1, j <= (maxI) ]
+
+prop_O_ItNC ix@(PointL j) = zs == ls where
t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
- zs = ((,,) <<< t % Deletion % chr xs ... S.toList) (O $ maxPL) ix
- ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)
+ zs = ((,,) <<< t % Deletion % chr xs ... stoList) maxPLo ix
+ ls = [ ( unsafeIndex xsPo (PointL $ j+1)
, ()
, xs VU.! (j+0)
- ) | j >= 0, j <= 99 ]
+ ) | j >= 0, j <= (maxI-1) ]
{-# Noinline prop_O_ItNC #-}
-prop_O_ZItNC ix@(O (Z:.PointL j)) = zs == ls where
+prop_O_ZItNC ix@(Z:.PointL j) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
- zs = ((,,) <<< t % (M:|Deletion) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
- ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+1)))
+ zs = ((,,) <<< t % (M:|Deletion) % (M:|chr xs) ... stoList) (Z:.maxPLo) ix
+ ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+1))
, Z:.()
, Z:.xs VU.! (j+0)
- ) | j >= 0, j <= 99 ]
+ ) | j >= 0, j <= (maxI-1) ]
-prop_O_2dimIt_NC_CN ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
+prop_O_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)
- zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
- ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+1):.PointL (l+1)))
+ zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (Z:.maxPLo:.maxPLo) ix
+ ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+1):.PointL (l+1))
, Z:.() :.xs VU.! (l+0)
, Z:.xs VU.! (j+0):.()
- ) | j>=0, l>=0, j<=99, l<=99 ]
+ ) | j>=0, l>=0, j<=(maxI-1), l<=(maxI-1) ]
prop_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
- zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (Z:.maxPL:.maxPL) ix
+ zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (Z:.maxPLi:.maxPLi) ix
ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1))
, Z:.() :.xs VU.! (l-1)
, Z:.xs VU.! (j-1):.()
- ) | j>=1, l>=1, j<=100, l<=100 ]
+ ) | j>=1, l>=1, j<=maxI, l<=maxI ]
@@ -88,157 +100,160 @@ prop_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where
-- | A single character terminal
prop_Tt ix@(Z:.PointL j) = zs == ls where
- zs = (id <<< (M:|chr xs) ... S.toList) (Z:.maxPL) ix
+ zs = (id <<< (M:|chr xs) ... stoList) (Z:.maxPLi) ix
ls = [ (Z:.xs VU.! (j-1)) | 1==j ]
--prop_O_Tt ix@(Z:.O (PointL j)) = traceShow (j,zs,ls) $ zs == ls where
--- zs = (id <<< (M:|chr xs) ... S.toList) (Z:.O maxPL) ix
+-- zs = (id <<< (M:|chr xs) ... stoList) (Z:.O maxPLo) ix
-- ls = [ (Z:.xs VU.! (j-1)) | 1==j ]
-- | Two single-character terminals
prop_CC ix@(Z:.PointL i) = zs == ls where
- zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... S.toList) (Z:.maxPL) ix
+ zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... stoList) (Z:.maxPLi) ix
ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ]
-- | Just a table
prop_It ix@(PointL j) = zs == ls where
t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
- zs = (id <<< t ... S.toList) maxPL ix
- ls = [ unsafeIndex xsP ix | j>=0, j<=100 ]
+ zs = (id <<< t ... stoList) maxPLi ix
+ ls = [ unsafeIndex xsP ix | j>=0, j<=maxI ]
-prop_O_It ix@(O (PointL j)) = zs == ls where
+prop_O_It ix@(PointL j) = zs == ls where
t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
- zs = (id <<< t ... S.toList) (O maxPL) ix
- ls = [ unsafeIndex xsPo ix | j>=0, j<=100 ]
+ zs = (id <<< t ... stoList) maxPLo ix
+ ls = [ unsafeIndex xsPo ix | j>=0, j<=maxI ]
prop_ZIt ix@(Z:.PointL j) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
- zs = (id <<< t ... S.toList) (Z:.maxPL) ix
- ls = [ unsafeIndex xsZP ix | j>=0, j<=100 ]
+ zs = (id <<< t ... stoList) (Z:.maxPLi) ix
+ ls = [ unsafeIndex xsZP ix | j>=0, j<=maxI ]
-prop_O_ZIt ix@(O (Z:.PointL j)) = zs == ls where
+prop_O_ZIt ix@(Z:.PointL j) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
- zs = (id <<< t ... S.toList) (O (Z:.maxPL)) ix
- ls = [ unsafeIndex xsZPo ix | j>=0, j<=100 ]
+ zs = (id <<< t ... stoList) (Z:.maxPLo) ix
+ ls = [ unsafeIndex xsZPo ix | j>=0, j<=maxI ]
-- | Table, then single terminal
prop_ItC ix@(PointL j) = zs == ls where
t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
- zs = ((,) <<< t % chr xs ... S.toList) maxPL ix
+ zs = ((,) <<< t % chr xs ... stoList) maxPLi ix
ls = [ ( unsafeIndex xsP (PointL $ j-1)
, xs VU.! (j-1)
- ) | j>=1, j<=100 ]
+ ) | j>=1, j<=maxI ]
-- | @A^*_j -> A^*_{j+1} c_{j+1)@ !
-prop_O_ItC ix@(O (PointL j)) = zs == ls where
+prop_O_ItC ix@(PointL j) = zs == ls where
t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
- zs = ((,) <<< t % chr xs ... S.toList) (O $ maxPL) ix
- ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)
+ zs = ((,) <<< t % chr xs ... stoList) maxPLo ix
+ ls = [ ( unsafeIndex xsPo (PointL $ j+1)
, xs VU.! (j+0)
- ) | j >= 0, j < 100 ]
+ ) | j >= 0, j < maxI ]
-prop_O_ItCC ix@(O (PointL j)) = zs == ls where
+prop_O_ItCC ix@(PointL j) = zs == ls where
t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
- zs = ((,,) <<< t % chr xs % chr xs ... S.toList) (O $ maxPL) ix
- ls = [ ( unsafeIndex xsPo (O $ PointL $ j+2)
+ zs = ((,,) <<< t % chr xs % chr xs ... stoList) maxPLo ix
+ ls = [ ( unsafeIndex xsPo (PointL $ j+2)
, xs VU.! (j+0)
, xs VU.! (j+1)
- ) | j >= 0, j <= 98 ]
+ ) | j >= 0, j <= (maxI-2) ]
{-# Noinline prop_O_ItCC #-}
-prop_O_ZItCC ix@(O (Z:.PointL j)) = zs == ls where
+prop_O_ZItCC ix@(Z:.PointL j) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
- zs = ((,,) <<< t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
- ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+2)))
+ zs = ((,,) <<< t % (M:|chr xs) % (M:|chr xs) ... stoList) (Z:.maxPLo) ix
+ ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+2))
, Z:.xs VU.! (j+0)
, Z:.xs VU.! (j+1)
- ) | j >= 0, j <= 98 ]
+ ) | j >= 0, j <= (maxI-2) ]
-- | synvar followed by a 2-tape character terminal
prop_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
- zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+ zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (Z:.maxPLi:.maxPLi) ix
ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2))
, Z:.xs VU.! (j-2):.xs VU.! (l-2)
, Z:.xs VU.! (j-1):.xs VU.! (l-1)
- ) | j>=2, l>=2, j<=100, l<=100 ]
+ ) | j>=2, l>=2, j<=maxI, l<=maxI ]
-prop_O_2dimItCC ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
+prop_O_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)
- zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
- ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+2):.PointL (l+2)))
+ zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (Z:.maxPLo:.maxPLo) ix
+ ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+2):.PointL (l+2))
, Z:.xs VU.! (j+0):.xs VU.! (l+0)
, Z:.xs VU.! (j+1):.xs VU.! (l+1)
- ) | j>=0, l>=0, j<=98, l<=98 ]
+ ) | j>=0, l>=0, j<=(maxI-2), l<=(maxI-2) ]
-- * direct index tests
+{-
xprop_O_ixZItCC ix@(O (Z:.PointL j)) = zs where
t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
- zs = (id >>> t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
+ zs = (id >>> t % (M:|chr xs) % (M:|chr xs) ... stoList) (O (Z:.maxPLo)) ix
+-}
-- * 'Strng' tests
-- ** Just the 'Strng' terminal
prop_ManyS ix@(PointL j) = zs == ls where
- zs = (id <<< manyS xs ... S.toList) maxPL ix
+ zs = (id <<< manyS xs ... stoList) maxPLi ix
ls = [ (VU.slice 0 j xs) ]
prop_SomeS ix@(PointL j) = zs == ls where
- zs = (id <<< someS xs ... S.toList) maxPL ix
+ zs = (id <<< someS xs ... stoList) maxPLi ix
ls = [ (VU.slice 0 j xs) | j>0 ]
-prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where
- zs = (id <<< (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
- ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]
+--prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where
+-- zs = (id <<< (M:|manyS xs:|manyS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix
+-- ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]
-prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where
- zs = (id <<< (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
- ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]
+--prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where
+-- zs = (id <<< (M:|someS xs:|someS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix
+-- ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]
-- ** Together with a syntactic variable.
prop_Itbl_ManyS ix@(PointL i) = zs == ls where
t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
- zs = ((,) <<< t % manyS xs ... S.toList) maxPL ix
+ zs = ((,) <<< t % manyS xs ... stoList) maxPLi ix
ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ]
prop_Itbl_SomeS ix@(PointL i) = zs == ls where
t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
- zs = ((,) <<< t % someS xs ... S.toList) maxPL ix
+ zs = ((,) <<< t % someS xs ... stoList) maxPLi ix
ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ]
prop_1dim_Itbl_ManyS ix@(Z:.PointL i) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
- zs = ((,) <<< t % (M:|manyS xs) ... S.toList) (Z:.maxPL) ix
+ zs = ((,) <<< t % (M:|manyS xs) ... stoList) (Z:.maxPLi) ix
ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ]
prop_1dim_Itbl_SomeS ix@(Z:.PointL i) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
- zs = ((,) <<< t % (M:|someS xs) ... S.toList) (Z:.maxPL) ix
+ zs = ((,) <<< t % (M:|someS xs) ... stoList) (Z:.maxPLi) ix
ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ]
prop_2dim_Itbl_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
- zs = ((,) <<< t % (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+ zs = ((,) <<< t % (M:|manyS xs:|manyS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix
ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ]
prop_2dim_Itbl_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
- zs = ((,) <<< t % (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+ zs = ((,) <<< t % (M:|someS xs:|someS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix
ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ]
+stoList = unId . SM.toList
infixl 8 >>>
-(>>>) f xs = \lu ij -> S.map f . mkStream (build xs) (initialContext ij) lu $ ij
+(>>>) f xs = \lu ij -> SM.map f . mkStream (build xs) (initialContext ij) lu $ ij
class GetIxs x i where
type R x i :: *
@@ -256,39 +271,50 @@ instance GetIxs ls i => GetIxs (ls :!: ITbl m a i x) i where
type R (ls :!: ITbl m a i x) i = R ls i :. (i,i)
getIxs (ElmITbl _ i o s) = getIxs s :. (i,o)
-xsP :: Unboxed (PointL) Int
-xsP = fromList (PointL 0) maxPL [0 ..]
+xsP :: Unboxed (PointL I) Int
+xsP = fromList (PointL 0) maxPLi [0 ..]
-xsZP :: Unboxed (Z:.PointL) Int
-xsZP = fromList (Z:.PointL 0) (Z:.maxPL) [0 ..]
+xsZP :: Unboxed (Z:.PointL I) Int
+xsZP = fromList (Z:.PointL 0) (Z:.maxPLi) [0 ..]
-xsPo :: Unboxed (Outside (PointL)) Int
-xsPo = fromList (O $ PointL 0) (O $ maxPL) [0 ..]
+xsPo :: Unboxed (PointL O) Int
+xsPo = fromList (PointL 0) maxPLo [0 ..]
-xsZPo :: Unboxed (Outside (Z:.PointL)) Int
-xsZPo = fromList (O (Z:.PointL 0)) (O (Z:.maxPL)) [0 ..]
+xsZPo :: Unboxed (Z:.PointL O) Int
+xsZPo = fromList (Z:.PointL 0) (Z:.maxPLo) [0 ..]
-xsPP :: Unboxed (Z:.PointL:.PointL) Int
-xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]
+xsPP :: Unboxed (Z:.PointL I:.PointL I) Int
+xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPLi:.maxPLi) [0 ..]
-xsPPo :: Unboxed (Outside (Z:.PointL:.PointL)) Int
-xsPPo = fromList (O (Z:.PointL 0:.PointL 0)) (O (Z:.maxPL:.maxPL)) [0 ..]
+xsPPo :: Unboxed (Z:.PointL O:.PointL O) Int
+xsPPo = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPLo:.maxPLo) [0 ..]
mxsPP = unsafePerformIO $ zzz where
- zzz :: IO (MutArr IO (Unboxed (Z:.PointL:.PointL) Int))
- zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]
+ zzz :: IO (MutArr IO (Unboxed (Z:.PointL I:.PointL I) Int))
+ zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPLi:.maxPLi) [0 ..]
-maxI = 100
-maxPL = PointL maxI
+maxI =100
+
+maxPLi :: PointL I
+maxPLi = PointL maxI
+
+maxPLo :: PointL O
+maxPLo = PointL maxI
xs = VU.fromList [0 .. maxI - 1 :: Int]
-- * general quickcheck stuff
-options = stdArgs {maxSuccess = 1000}
+options = stdArgs {maxSuccess = 1000 } -- 0}
customCheck = quickCheckWithResult options
return []
allProps = $forAllProperties customCheck
+
+
+#ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+testgroup_point = $(testGroupGenerator)
+#endif
+
diff --git a/tests/QuickCheck/Set.hs b/tests/QuickCheck/Set.hs
new file mode 100644
index 0000000..b83c720
--- /dev/null
+++ b/tests/QuickCheck/Set.hs
@@ -0,0 +1,314 @@
+
+{-# Options_GHC -O0 #-}
+
+module QuickCheck.Set where
+
+import Data.Bits
+import Data.Bits.Extras (msb)
+import Data.Vector.Fusion.Util
+import Debug.Trace
+import qualified Data.List as L
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Unboxed as VU
+import Test.QuickCheck.All
+import Test.QuickCheck hiding (NonEmpty)
+import Test.QuickCheck.Monadic
+#ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+import Test.Framework.TH
+import Test.Framework.Providers.QuickCheck2
+#endif
+
+import Data.Bits.Ordered
+import Data.PrimitiveArray
+
+import ADP.Fusion
+import QuickCheck.Common
+
+
+
+-- * BitSets without interfaces
+
+-- ** Inside checks
+
+prop_BS0_I_Eps ix@(BitSet _) = zs == ls where
+ zs = (id <<< Epsilon ... stoList) highestBi ix
+ ls = [ () | ix == 0 ]
+
+prop_BS0_I_Iv ix@(BitSet _) = {- traceShow (zs,ls) $ -} L.sort zs == L.sort ls where
+ tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ zs = ((,) <<< tia % chr csB0 ... stoList) highestBi ix
+ ls = [ (xsB ! (clearBit ix a), csB0 VU.! a) | a <- activeBitsL ix ]
+
+prop_BS0_I_Ivv ix@(BitSet _) = {- traceShow (zs,ls) $ -} L.sort zs == L.sort ls where
+ tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ zs = ((,,) <<< tia % chr csB0 % chr csB0 ... stoList) highestBi ix
+ ls = [ (xsB ! (clearBit (clearBit ix a) b), csB0 VU.! a, csB0 VU.! b) | a <- activeBitsL ix, b <- activeBitsL ix, a /=b ]
+
+prop_BS0_I_II ix@(BitSet _) = zs == ls where
+ tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ zs = ((,) <<< tia % tib ... stoList) highestBi ix
+ ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
+ | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
+ , let kk = popShiftL ix (BitSet k)
+ ]
+
+prop_BS0_I_JJ ix@(BitSet _) = zs == ls where
+ tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+ tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+ zs = ((,) <<< tia % tib ... stoList) highestBi ix
+ ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
+ | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
+ , let kk = popShiftL ix (BitSet k)
+ , popCount kk > 0
+ , popCount (ix `xor` kk) > 0
+ ]
+
+prop_BS0_I_III ix@(BitSet _) = {- traceShow (zs,ls) $ -} zs == ls where
+ tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ zs = ((,,) <<< tia % tib % tic ... stoList) highestBi ix
+ ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
+ | k <- VU.toList . popCntSorted $ popCount ix
+ , l <- VU.toList . popCntSorted $ popCount ix - popCount k
+ , let kk = popShiftL ix (BitSet k)
+ , let ll = popShiftL (ix `xor` kk) (BitSet l)
+ , let mm = (ix `xor` (kk .|. ll))
+ ]
+
+prop_BS0_I_JJJ ix@(BitSet _) = zs == ls where
+ tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+ tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+ tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+ zs = ((,,) <<< tia % tib % tic ... stoList) highestBi ix
+ ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
+ | k <- VU.toList . popCntSorted $ popCount ix
+ , l <- VU.toList . popCntSorted $ popCount ix - popCount k
+ , let kk = popShiftL ix (BitSet k)
+ , let ll = popShiftL (ix `xor` kk) (BitSet l)
+ , let mm = (ix `xor` (kk .|. ll))
+ , popCount kk > 0, popCount ll > 0, popCount mm > 0
+ ]
+
+
+-- * Outside checks
+-- These checks are very similar to those in the @Subword@ module. We just
+-- need to be a bit more careful, as indexed sets have overlap.
+
+prop_BS0_O_Eps ix@(BitSet _) = zs == ls where
+ zs = (id <<< Epsilon ... stoList) highestBo ix
+ ls = [ () | ix == highestBo ]
+
+prop_BS0_O_O ix@(BitSet _) = zs == ls where
+ tia = ITbl 0 0 EmptyOk xoB (\ _ _ -> Id 1)
+ zs = (id <<< tia ... stoList) highestBo ix
+ ls = [ xoB ! ix ]
+
+--prop_BS0_O_IO ix@(BitSet _) = zs == ls where
+-- tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+-- tib = ITbl 0 0 EmptyOk xoB (\ _ _ -> Id 1)
+-- zs = ((,) <<< tia % tib ... stoList) highestBo ix
+-- ls = []
+-- {-
+-- ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
+-- | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
+-- , let kk = popShiftL ix (BitSet k)
+-- ] -}
+
+{-
+prop_BS0_I_II ix@(BitSet _) = zs == ls where
+ tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+ zs = ((,) <<< tia % tib ... stoList) highestBi ix
+ ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
+ | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
+ , let kk = popShiftL ix (BitSet k)
+ ]
+-}
+
+
+-- ** Two non-terminals.
+--
+-- @A_s -> B_(s\t) C_t (s\t) ++ t == s@
+-- @s = 111 , s\t = 101, t = 010@
+--
+-- with @Z@ the full set.
+-- @Z = 1111@
+
+-- @B*_Z\(s\t) -> A*_Z\s C_t@
+-- @Z\(s\t) = 1010, Z\s = 1000, t = 010@
+
+
+
+
+-- * BitSets with two interfaces
+
+-- ** Inside checks
+
+--prop_bii_i :: BS2 First Last I -> Bool
+--prop_bii_i ix@(BS2 s i j) = zs == ls where
+-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+-- zs = (id <<< tia ... stoList) highestBII ix
+-- ls = [ xsBII ! ix ]
+--
+--prop_bii_i_n :: BS2 First Last I -> Bool
+--prop_bii_i_n ix@(BS2 s i j) = zs == ls where
+-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+-- zs = (id <<< tia ... stoList) highestBII ix
+-- ls = [ xsBII ! ix | popCount s > 0 ]
+
+-- | Edges should never work as a single terminal element.
+
+--prop_bii_e :: BS2 First Last I -> Bool
+--prop_bii_e ix@(BS2 s (Iter i) (Iter j)) = zs == ls where
+-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+-- zs = (id <<< e ... stoList) highestBII ix
+-- ls = [] :: [ (Int,Int) ]
+
+-- | Edges extend only in cases where in @i -> j@, @i@ actually happens to
+-- be a true interface.
+
+--prop_bii_ie :: BS2 First Last I -> Bool
+--prop_bii_ie ix@(BS2 s i (Iter j)) = zs == ls where
+-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+-- zs = ((,) <<< tia % e ... stoList) highestBII ix
+-- ls = [ ( xsBII ! (BS2 t i (Iter k :: Interface Last)) , (k,j) )
+-- | let t = s `clearBit` j
+-- , k <- activeBitsL t ]
+--
+--prop_bii_ie_n :: BS2 First Last I -> Bool
+--prop_bii_ie_n ix@(BS2 s i (Iter j)) = zs == ls where
+-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+-- zs = ((,) <<< tia % e ... stoList) highestBII ix
+-- ls = [ ( xsBII ! (BS2 t i (Iter k :: Interface Last)) , (k,j) )
+-- | let t = s `clearBit` j
+-- , popCount t >= 2
+-- , k <- activeBitsL t
+-- , k /= getIter i
+-- ]
+--
+--prop_bii_iee :: BS2 First Last I -> Bool
+--prop_bii_iee ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where
+-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+-- zs = ((,,) <<< tia % e % e ... stoList) highestBII ix
+-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,j) )
+-- | let tmp = (s `clearBit` j)
+-- , l <- activeBitsL tmp
+-- , l /= getIter i
+-- , let t = tmp `clearBit` l
+-- , k <- activeBitsL t
+-- , let kk = Iter k
+-- ]
+--
+--prop_bii_ieee :: BS2 First Last I -> Bool
+--prop_bii_ieee ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where
+-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+-- zs = ((,,,) <<< tia % e % e % e ... stoList) highestBII ix
+-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,m) , (m,j) )
+-- | let tmpM = (s `clearBit` j)
+-- , m <- activeBitsL tmpM
+-- , m /= getIter i
+-- , let tmpL = (tmpM `clearBit` m)
+-- , l <- activeBitsL tmpL
+-- , l /= getIter i
+-- , let t = tmpL `clearBit` l
+-- , k <- activeBitsL t
+-- , let kk = Iter k
+-- ]
+--
+--prop_bii_iee_n :: BS2 First Last I -> Bool
+--prop_bii_iee_n ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where
+-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+-- zs = ((,,) <<< tia % e % e ... stoList) highestBII ix
+-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,j) )
+-- | let tmp = (s `clearBit` j)
+-- , l <- activeBitsL tmp
+-- , l /= getIter i
+-- , let t = tmp `clearBit` l
+-- , popCount t >= 2
+-- , k <- activeBitsL t
+-- , k /= getIter i
+-- , let kk = Iter k
+-- ]
+--
+--prop_bii_ieee_n :: BS2 First Last I -> Bool
+--prop_bii_ieee_n ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where
+-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+-- zs = ((,,,) <<< tia % e % e % e ... stoList) highestBII ix
+-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,m) , (m,j) )
+-- | let tmpM = (s `clearBit` j)
+-- , m <- activeBitsL tmpM
+-- , m /= getIter i
+-- , let tmpL = (tmpM `clearBit` m)
+-- , l <- activeBitsL tmpL
+-- , l /= getIter i
+-- , let t = tmpL `clearBit` l
+-- , popCount t >= 2
+-- , k <- activeBitsL t
+-- , k /= getIter i
+-- , let kk = Iter k
+-- ]
+
+-- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where
+-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+-- tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+-- zs = ((,) <<< tia % tib ... stoList) highestBII ix
+-- ls = [ ( xsBII ! kk , xsBII ! ll )
+-- | k <- VU.toList . popCntSorted $ popCount s
+-- , ki <- if k==0 then [0] else activeBitsL k
+-- , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki)
+-- , let kk = (BitSet k:>Iter ki:>Iter kj)
+-- , let l = s `xor` BitSet k
+-- , li <- if l==0 then [0] else activeBitsL l
+-- , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li)
+-- , let ll = (l:>Iter li:>Iter lj)
+-- ]
+
+
+
+-- * Helper functions
+
+stoList = unId . SM.toList
+
+highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary
+highestBi :: BitSet I
+highestBi = BitSet $ 2^(highBit+1) -1
+highestBo :: BitSet O
+highestBo = BitSet $ 2^(highBit+1) -1
+highestBII = BS2 highestBi (Iter $ highBit-1) (Iter $ highBit-1) -- assuming @highBit >= 1@
+
+xsB :: Unboxed (BitSet I) Int
+xsB = fromList (BitSet 0) highestBi [ 0 .. ]
+
+xoB :: Unboxed (BitSet O) Int
+xoB = fromList (BitSet 0) highestBo [ 0 .. ]
+
+xsBII :: Unboxed (BS2 First Last I) Int
+xsBII = fromList (BS2 0 0 0) highestBII [ 0 .. ]
+
+csB0 :: VU.Vector Int
+csB0 = VU.fromList [ i | i <- [0 .. msb highestBi] ]
+
+-- * general quickcheck stuff
+
+options = stdArgs {maxSuccess = 1000}
+
+customCheck = quickCheckWithResult options
+
+return []
+allProps = $forAllProperties customCheck
+
+
+
+#ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+testgroup_set = $(testGroupGenerator)
+#endif
+
+
diff --git a/ADP/Fusion/QuickCheck/Subword.hs b/tests/QuickCheck/Subword.hs
index 2df3c75..034dfa6 100644
--- a/ADP/Fusion/QuickCheck/Subword.hs
+++ b/tests/QuickCheck/Subword.hs
@@ -6,21 +6,24 @@
-- TODO need to carefully check all props against boundary errors!
-- Especially the 2-dim cases!
-module ADP.Fusion.QuickCheck.Subword where
+module QuickCheck.Subword where
-import Test.QuickCheck
-import Test.QuickCheck.All
-import Test.QuickCheck.Monadic
-import qualified Data.Vector.Fusion.Stream as S
import Data.Vector.Fusion.Util
import Debug.Trace
import qualified Data.List as L
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
+import Test.QuickCheck
+import Test.QuickCheck.All
+import Test.QuickCheck.Monadic
+#ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+import Test.Framework.TH
+import Test.Framework.Providers.QuickCheck2
+#endif
import Data.PrimitiveArray
import ADP.Fusion
-import ADP.Fusion.QuickCheck.Common
@@ -33,20 +36,20 @@ import ADP.Fusion.QuickCheck.Common
-- B*_ik -> A*_ij C_kj
-- C*_kj -> B_ik A*_ij
-prop_sv_OI ox@(O (Subword (i:.k))) = zs == ls where
+prop_sv_OI ox@(Subword (i:.k)) = zs == ls where
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
- zs = ((,) <<< toa % tic ... S.toList) (O $ subword 0 highest) ox
- ls = [ ( unsafeIndex xoS (O $ subword i j)
- , unsafeIndex xsS ( subword k j) )
+ zs = ((,) <<< toa % tic ... stoList) maxSWo ox
+ ls = [ ( unsafeIndex xoS (subword i j)
+ , unsafeIndex xsS (subword k j) )
| j <- [ k .. highest ] ]
-prop_sv_IO ox@(O (Subword (k:.j))) = zs == ls where
+prop_sv_IO ox@(Subword (k:.j)) = zs == ls where
tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
- zs = ((,) <<< tib % toa ... S.toList) (O $ subword 0 highest) ox
- ls = [ ( unsafeIndex xsS ( subword i k)
- , unsafeIndex xoS (O $ subword i j) )
+ zs = ((,) <<< tib % toa ... stoList) maxSWo ox
+ ls = [ ( unsafeIndex xsS (subword i k)
+ , unsafeIndex xoS (subword i j) )
| j <= highest, i <- [ 0 .. k ] ]
-- ** three non-terminals on the r.h.s. (this provides situations where two
@@ -58,34 +61,34 @@ prop_sv_IO ox@(O (Subword (k:.j))) = zs == ls where
-- C*_kl -> B_ik A*_ij D_lj
-- D*_lj -> B_ik C_kl A*_ij
-prop_sv_OII ox@(O (Subword (i:.k))) = zs == ls where
+prop_sv_OII ox@(Subword (i:.k)) = zs == ls where
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
- zs = ((,,) <<< toa % tic % tid ... S.toList) (O $ subword 0 highest) ox
- ls = [ ( unsafeIndex xoS (O $ subword i j)
- , unsafeIndex xsS ( subword k l)
- , unsafeIndex xsS ( subword l j) )
+ zs = ((,,) <<< toa % tic % tid ... stoList) maxSWo ox
+ ls = [ ( unsafeIndex xoS (subword i j)
+ , unsafeIndex xsS (subword k l)
+ , unsafeIndex xsS (subword l j) )
| j <- [ k .. highest ], l <- [ k .. j ] ]
-prop_sv_IOI ox@(O (Subword (k:.l))) = zs == ls where
+prop_sv_IOI ox@(Subword (k:.l)) = zs == ls where
tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
- zs = ((,,) <<< tib % toa % tid ... S.toList) (O $ subword 0 highest) ox
- ls = [ ( unsafeIndex xsS ( subword i k)
- , unsafeIndex xoS (O $ subword i j)
- , unsafeIndex xsS ( subword l j) )
+ zs = ((,,) <<< tib % toa % tid ... stoList) maxSWo ox
+ ls = [ ( unsafeIndex xsS (subword i k)
+ , unsafeIndex xoS (subword i j)
+ , unsafeIndex xsS (subword l j) )
| i <- [ 0 .. k ], j <- [ l .. highest ] ]
-prop_sv_IIO ox@(O (Subword (l:.j))) = zs == ls where
+prop_sv_IIO ox@(Subword (l:.j)) = zs == ls where
tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
- zs = ((,,) <<< tib % tic % toa ... S.toList) (O $ subword 0 highest) ox
- ls = [ ( unsafeIndex xsS ( subword i k)
- , unsafeIndex xsS ( subword k l)
- , unsafeIndex xoS (O $ subword i j) )
+ zs = ((,,) <<< tib % tic % toa ... stoList) maxSWo ox
+ ls = [ ( unsafeIndex xsS (subword i k)
+ , unsafeIndex xsS (subword k l)
+ , unsafeIndex xoS (subword i j) )
| j <= highest, i <- [ 0 .. l ], k <- [ i .. l ] ]
-- ** four non-terminals on the r.h.s. ?
@@ -94,29 +97,29 @@ prop_sv_IIO ox@(O (Subword (l:.j))) = zs == ls where
-- ** Non-terminal and terminal combinations
-prop_cOc ox@(O( Subword (i:.j))) = zs == ls where
+prop_cOc ox@(Subword (i:.j)) = zs == ls where
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
- zs = ((,,) <<< chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox
+ zs = ((,,) <<< chr csS % toa % chr csS ... stoList) maxSWo ox
ls = [ ( csS VU.! (i-1)
- , unsafeIndex xoS (O $ subword (i-1) (j+1))
+ , unsafeIndex xoS (subword (i-1) (j+1))
, csS VU.! (j ) )
| i > 0 && j < highest ]
-prop_ccOcc ox@(O(Subword (i:.j))) = zs == ls where
+prop_ccOcc ox@(Subword (i:.j)) = zs == ls where
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
- zs = ((,,,,) <<< chr csS % chr csS % toa % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox
+ zs = ((,,,,) <<< chr csS % chr csS % toa % chr csS % chr csS ... stoList) maxSWo ox
ls = [ ( csS VU.! (i-2)
, csS VU.! (i-1)
- , unsafeIndex xoS (O $ subword (i-2) (j+2))
+ , unsafeIndex xoS (subword (i-2) (j+2))
, csS VU.! (j )
, csS VU.! (j+1) )
| i > 1 && j < highest -1 ]
-prop_cOccc ox@(O(Subword (i:.j))) = zs == ls where
+prop_cOccc ox@(Subword (i:.j)) = zs == ls where
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
- zs = ((,,,,) <<< chr csS % toa % chr csS % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox
+ zs = ((,,,,) <<< chr csS % toa % chr csS % chr csS % chr csS ... stoList) maxSWo ox
ls = [ ( csS VU.! (i-1)
- , unsafeIndex xoS (O $ subword (i-1) (j+3))
+ , unsafeIndex xoS (subword (i-1) (j+3))
, csS VU.! (j )
, csS VU.! (j+1)
, csS VU.! (j+2) )
@@ -124,32 +127,32 @@ prop_cOccc ox@(O(Subword (i:.j))) = zs == ls where
-- ** Terminals, syntactic terminals, and non-terminals
-prop_cOcIc ox@(O (Subword (i:.k))) = zs == ls where
+prop_cOcIc ox@(Subword (i:.k)) = zs == ls where
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
- zs = ((,,,,) <<< chr csS % toa % chr csS % tic % chr csS ... S.toList) (O $ subword 0 highest) ox
+ zs = ((,,,,) <<< chr csS % toa % chr csS % tic % chr csS ... stoList) maxSWo ox
ls = [ ( csS VU.! (i-1)
- , unsafeIndex xoS (O $ subword (i-1) j )
+ , unsafeIndex xoS (subword (i-1) j )
, csS VU.! (k )
- , unsafeIndex xsS ( subword (k+1) (j-1) )
+ , unsafeIndex xsS (subword (k+1) (j-1))
, csS VU.! (j-1) )
| i > 0, j <- [ k+2 .. highest ] ]
-prop_cIcOc ox@(O (Subword (k:.j))) = zs == ls where
+prop_cIcOc ox@(Subword (k:.j)) = zs == ls where
tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
- zs = ((,,,,) <<< chr csS % tib % chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox
+ zs = ((,,,,) <<< chr csS % tib % chr csS % toa % chr csS ... stoList) maxSWo ox
ls = [ ( csS VU.! (i )
- , unsafeIndex xsS ( subword (i+1) (k-1))
+ , unsafeIndex xsS (subword (i+1) (k-1))
, csS VU.! (k-1)
- , unsafeIndex xoS (O $ subword i (j+1))
+ , unsafeIndex xoS (subword i (j+1))
, csS VU.! (j ) )
| j+1 <= highest, k>1, i <- [ 0 .. k-2 ] ]
-- ** Epsilonness
-prop_Epsilon ox@(O (Subword (i:.j))) = zs == ls where
- zs = (id <<< Epsilon ... S.toList) (O $ subword 0 highest) ox
+prop_Epsilon ox@(Subword (i:.j)) = zs == ls where
+ zs = (id <<< Epsilon ... stoList) (maxSWo) ox
ls = [ () | i==0 && j==highest ]
@@ -157,24 +160,12 @@ prop_Epsilon ox@(O (Subword (i:.j))) = zs == ls where
prop_2dimIt ix@(Z:.Subword (i:.j):.Subword (k:.l)) = zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
- zs = (id <<< t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
+ zs = (id <<< t ... stoList) (Z:.subword 0 highest:.subword 0 highest) ix
ls = [ ( unsafeIndex xsSS ix ) | j<=highest && l<=highest ]
-{-
-xprop_2dimItIt ix@(Z:.Subword (i:.j):.Subword (k:.l)) = zs == ls where
- t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id (1,1))
- zs = ((,) <<< t % t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
- ls = [ ( unsafeIndex xsSS (Z:.subword i m:.subword k n)
- , unsafeIndex xsSS (Z:.subword m j:.subword n l) )
- | j<=highest && l<=highest
- , m <- [i..j]
- , n <- [k..l]
- ]
--}
-
prop_2dimcIt ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
- zs = ((,) <<< (M:|chr csS:|chr csS) % t ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
+ zs = ((,) <<< (M:|chr csS:|chr csS) % t ... stoList) (Z:.subwordI 0 highest:.subwordI 0 highest) ix
ls = [ ( Z :. (csS VU.! i) :. (csS VU.! k)
, unsafeIndex xsSS (Z :. subword (i+1) j :. subword (k+1) l) )
| j<=highest && l<=highest
@@ -182,7 +173,7 @@ prop_2dimcIt ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs
prop_2dimItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
- zs = ((,) <<< t % (M:|chr csS:|chr csS) ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
+ zs = ((,) <<< t % (M:|chr csS:|chr csS) ... stoList) (Z:.subwordI 0 highest:.subwordI 0 highest) ix
ls = [ ( unsafeIndex xsSS (Z :. subword i (j-1) :. subword k (l-1))
, Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) )
| j<=highest && l<=highest
@@ -190,7 +181,7 @@ prop_2dimItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs
prop_2dimcItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} zs == ls where
t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsSS (\ _ _ -> Id ((1,1),(1,1)))
- zs = ((,,) <<< (M:|chr csS:|chr csS) % t % (M:|chr csS:| chr csS) ... S.toList) (Z:.subword 0 highest:.subword 0 highest) ix
+ zs = ((,,) <<< (M:|chr csS:|chr csS) % t % (M:|chr csS:| chr csS) ... stoList) (Z:.subwordI 0 highest:.subwordI 0 highest) ix
ls = [ ( Z :. (csS VU.! i) :. (csS VU.! k)
, unsafeIndex xsSS (Z :. subword (i+1) (j-1) :. subword (k+1) (l-1))
, Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) )
@@ -199,18 +190,26 @@ prop_2dimcItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = {- traceShow (zs,ls) $ -} z
+stoList = unId . SM.toList
+
highest = 10
+maxSWi :: Subword I
+maxSWi = subword 0 highest
+
+maxSWo :: Subword O
+maxSWo = subword 0 highest
+
csS :: VU.Vector (Int,Int)
csS = VU.fromList [ (i,i+1) | i <- [0 .. highest-1] ] -- this should be @highest -1@, we should die if we see @(highest,highest+1)@
-xsS :: Unboxed Subword (Int,Int)
+xsS :: Unboxed (Subword I) (Int,Int)
xsS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]
-xoS :: Unboxed (Outside Subword) (Int,Int)
-xoS = fromList (O $ subword 0 0) (O $ subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]
+xoS :: Unboxed (Subword O) (Int,Int)
+xoS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]
-xsSS :: Unboxed (Z:.Subword:.Subword) ( (Int,Int) , (Int,Int) )
+xsSS :: Unboxed (Z:.Subword I:.Subword I) ( (Int,Int) , (Int,Int) )
xsSS = fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 highest:.subword 0 highest) ((-1,-1),(-1,-1))
$ Prelude.map (\((i,j),(k,l)) -> (Z:.subword i j:.subword k l, ((i,j),(k,l)) )) [ ((i,j) , (k,l)) | i <- [0 .. highest], j <-[i .. highest], k <- [0 .. highest], l <- [0 .. highest] ]
@@ -223,3 +222,9 @@ customCheck = quickCheckWithResult options
return []
allProps = $forAllProperties customCheck
+
+
+#ifdef ADPFUSION_TEST_SUITE_PROPERTIES
+testgroup_subword = $(testGroupGenerator)
+#endif
+
diff --git a/tests/performance.hs b/tests/performance.hs
index 8bcf0f5..aab4264 100644
--- a/tests/performance.hs
+++ b/tests/performance.hs
@@ -48,7 +48,7 @@ gLeft Split{..} c t' =
in Z:.t
{-# Inline gLeft #-}
-mkArrs :: Int -> (VU.Vector Int, Unboxed Subword Int)
+mkArrs :: Int -> (VU.Vector Int, Unboxed (Subword I) Int)
mkArrs n = ( VU.enumFromTo 1 n
, fromAssocs (subword 0 0) (subword 0 n) (-999999) []
)
@@ -57,7 +57,7 @@ mkArrs n = ( VU.enumFromTo 1 n
-- | WARNING: Multiple runs of @runLeft@ make use of the same @arr@. This
-- is, of course, dangerous. Unless you know what you are doing.
-runLeft :: (VU.Vector Int, Unboxed Subword Int) -> Int -> Int
+runLeft :: (VU.Vector Int, Unboxed (Subword I) Int) -> Int -> Int
runLeft (!i, !arr) k = seq k d where
-- i = VU.enumFromTo 1 k
n = VU.length i
@@ -66,7 +66,7 @@ runLeft (!i, !arr) k = seq k d where
d = unId $ axiom t
{-# NoInline runLeft #-}
-runLeftForward :: VU.Vector Int -> Unboxed Subword Int -> Z:.ITbl Id Unboxed Subword Int
+runLeftForward :: VU.Vector Int -> Unboxed (Subword I) Int -> Z:.ITbl Id Unboxed (Subword I) Int
runLeftForward !i !arr = mutateTablesDefault
$ gLeft algMax
i
diff --git a/tests/properties.hs b/tests/properties.hs
index 7534c63..3f9d503 100644
--- a/tests/properties.hs
+++ b/tests/properties.hs
@@ -4,87 +4,16 @@
module Main where
-import Test.Framework.Providers.QuickCheck2
-import Test.Framework.TH
+--import Test.Framework.Providers.QuickCheck2
+--import Test.Framework.TH
+import Test.Framework
-import qualified ADP.Fusion.QuickCheck.Subword as QSW
-import qualified ADP.Fusion.QuickCheck.Set as QS
-import qualified ADP.Fusion.QuickCheck.Point as QP
-import ADP.Fusion.QuickCheck.Point
-
-
-{-
-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Subword.hs | awk '{print $1"QSW", "=", "QSW."$1 }' | uniq
-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Set.hs | awk '{print $1"QS", "=", "QS."$1 }' | uniq
-grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Point.hs | awk '{print $1"QP", "=", "QP."$1 }' | uniq
--}
-
--- subwords
-
-prop_sv_OIQSW = QSW.prop_sv_OI
-prop_sv_IOQSW = QSW.prop_sv_IO
-prop_sv_OIIQSW = QSW.prop_sv_OII
-prop_sv_IOIQSW = QSW.prop_sv_IOI
-prop_sv_IIOQSW = QSW.prop_sv_IIO
-prop_cOcQSW = QSW.prop_cOc
-prop_ccOccQSW = QSW.prop_ccOcc
-prop_cOcccQSW = QSW.prop_cOccc
-prop_cOcIcQSW = QSW.prop_cOcIc
-prop_cIcOcQSW = QSW.prop_cIcOc
-prop_EpsilonQSW = QSW.prop_Epsilon
-
--- sets
-
-prop_b_iiQS = QS.prop_b_ii
-prop_b_ii_nnQS = QS.prop_b_ii_nn
-prop_b_iiiQS = QS.prop_b_iii
-prop_b_iii_nnnQS = QS.prop_b_iii_nnn
-prop_bii_iQS = QS.prop_bii_i
-prop_bii_i_nQS = QS.prop_bii_i_n
-prop_bii_eQS = QS.prop_bii_e
-prop_bii_ieQS = QS.prop_bii_ie
-prop_bii_ie_nQS = QS.prop_bii_ie_n
-prop_bii_ieeQS = QS.prop_bii_iee
-prop_bii_ieeeQS = QS.prop_bii_ieee
-prop_bii_iee_nQS = QS.prop_bii_iee_n
-prop_bii_ieee_nQS = QS.prop_bii_ieee_n
-
--- points
-
-prop_EpsilonQP = QP.prop_Epsilon
-prop_O_EpsilonQP = QP.prop_O_Epsilon
-prop_ZEpsilonQP = QP.prop_ZEpsilon
-prop_O_ZEpsilonQP = QP.prop_O_ZEpsilon
-prop_O_ZEpsilonEpsilonQP = QP.prop_O_ZEpsilonEpsilon
-prop_O_ItNCQP = QP.prop_O_ItNC
-prop_O_ZItNCQP = QP.prop_O_ZItNC
-prop_O_2dimIt_NC_CNQP = QP.prop_O_2dimIt_NC_CN
-prop_2dimIt_NC_CNQP = QP.prop_2dimIt_NC_CN
-prop_TtQP = QP.prop_Tt
-prop_CCQP = QP.prop_CC
-prop_ItQP = QP.prop_It
-prop_O_ItQP = QP.prop_O_It
-prop_ZItQP = QP.prop_ZIt
-prop_O_ZItQP = QP.prop_O_ZIt
-prop_ItCQP = QP.prop_ItC
-prop_O_ItCQP = QP.prop_O_ItC
-prop_O_ItCCQP = QP.prop_O_ItCC
-prop_O_ZItCCQP = QP.prop_O_ZItCC
-prop_2dimItCCQP = QP.prop_2dimItCC
-prop_O_2dimItCCQP = QP.prop_O_2dimItCC
-prop_ManySQP = QP.prop_ManyS
-prop_SomeSQP = QP.prop_SomeS
-prop_2dim_ManyS_ManySQP = QP.prop_2dim_ManyS_ManyS
-prop_2dim_SomeS_SomeSQP = QP.prop_2dim_SomeS_SomeS
-prop_Itbl_ManySQP = QP.prop_Itbl_ManyS
-prop_Itbl_SomeSQP = QP.prop_Itbl_SomeS
-prop_1dim_Itbl_ManySQP = QP.prop_1dim_Itbl_ManyS
-prop_1dim_Itbl_SomeSQP = QP.prop_1dim_Itbl_SomeS
-prop_2dim_Itbl_ManyS_ManySQP = QP.prop_2dim_Itbl_ManyS_ManyS
-prop_2dim_Itbl_SomeS_SomeSQP = QP.prop_2dim_Itbl_SomeS_SomeS
+import QuickCheck.Point (testgroup_point)
+import QuickCheck.Set (testgroup_set)
+import QuickCheck.Subword (testgroup_subword)
main :: IO ()
-main = $(defaultMainGenerator)
+main = defaultMain [testgroup_point, testgroup_set, testgroup_subword]