ADPfusion 0.4.1.1 → 0.5.0.0
raw patch · 67 files changed
+3134/−2293 lines, 67 filesdep +singletonsdep −ghc-primdep ~OrderedBitsdep ~PrimitiveArraydep ~bits
Dependencies added: singletons
Dependencies removed: ghc-prim
Dependency ranges changed: OrderedBits, PrimitiveArray, bits, strict, vector
Files
- ADP/Fusion/Base.hs +4/−0
- ADP/Fusion/Base/Classes.hs +21/−17
- ADP/Fusion/Base/Multi.hs +86/−65
- ADP/Fusion/Base/Point.hs +34/−35
- ADP/Fusion/Base/Set.hs +94/−31
- ADP/Fusion/Base/Subword.hs +77/−33
- ADP/Fusion/Base/Term.hs +55/−0
- ADP/Fusion/Base/TyLvlIx.hs +77/−0
- ADP/Fusion/Base/Unit.hs +96/−0
- ADP/Fusion/QuickCheck/Common.hs +0/−10
- ADP/Fusion/QuickCheck/Point.hs +0/−294
- ADP/Fusion/QuickCheck/Set.hs +0/−248
- ADP/Fusion/QuickCheck/Subword.hs +0/−225
- ADP/Fusion/SynVar/Array.hs +92/−248
- ADP/Fusion/SynVar/Array/Point.hs +0/−79
- ADP/Fusion/SynVar/Array/Set.hs +0/−164
- ADP/Fusion/SynVar/Array/Subword.hs +0/−318
- ADP/Fusion/SynVar/Array/TermSymbol.hs +106/−44
- ADP/Fusion/SynVar/Array/Type.hs +40/−20
- ADP/Fusion/SynVar/Fill.hs +5/−5
- ADP/Fusion/SynVar/Indices.hs +21/−1
- ADP/Fusion/SynVar/Indices/Classes.hs +76/−0
- ADP/Fusion/SynVar/Indices/Point.hs +73/−0
- ADP/Fusion/SynVar/Indices/Set0.hs +160/−0
- ADP/Fusion/SynVar/Indices/Subword.hs +220/−0
- ADP/Fusion/SynVar/Indices/Unit.hs +58/−0
- ADP/Fusion/SynVar/Recursive/Subword.hs +0/−1
- ADP/Fusion/SynVar/Split/Subword.hs +39/−33
- ADP/Fusion/SynVar/Split/Type.hs +9/−1
- ADP/Fusion/Term/Chr.hs +2/−0
- ADP/Fusion/Term/Chr/Point.hs +50/−65
- ADP/Fusion/Term/Chr/Set0.hs +64/−0
- ADP/Fusion/Term/Chr/Subword.hs +66/−51
- ADP/Fusion/Term/Chr/Type.hs +7/−1
- ADP/Fusion/Term/Deletion.hs +2/−0
- ADP/Fusion/Term/Deletion/Point.hs +34/−38
- ADP/Fusion/Term/Deletion/Subword.hs +70/−13
- ADP/Fusion/Term/Deletion/Type.hs +1/−1
- ADP/Fusion/Term/Deletion/Unit.hs +55/−0
- ADP/Fusion/Term/Edge/Set.hs +17/−18
- ADP/Fusion/Term/Edge/Type.hs +1/−1
- ADP/Fusion/Term/Epsilon.hs +4/−0
- ADP/Fusion/Term/Epsilon/Point.hs +34/−38
- ADP/Fusion/Term/Epsilon/Set.hs +98/−0
- ADP/Fusion/Term/Epsilon/Subword.hs +36/−27
- ADP/Fusion/Term/Epsilon/Type.hs +1/−1
- ADP/Fusion/Term/Epsilon/Unit.hs +55/−0
- ADP/Fusion/Term/PeekIndex/Subword.hs +3/−3
- ADP/Fusion/Term/PeekIndex/Type.hs +1/−1
- ADP/Fusion/Term/Strng/Point.hs +75/−20
- ADP/Fusion/Term/Strng/Subword.hs +40/−6
- ADP/Fusion/Term/Strng/Type.hs +1/−1
- ADPfusion.cabal +42/−15
- changelog.md +9/−0
- src/Durbin.hs +4/−2
- src/NeedlemanWunsch.hs +5/−6
- src/Nussinov.hs +3/−3
- src/OverlappingPalindromes.hs +2/−3
- src/PartNussinov.hs +17/−18
- src/Pseudoknot.hs +6/−5
- src/SplitTests.hs +2/−3
- tests/QuickCheck/Common.hs +10/−0
- tests/QuickCheck/Point.hs +320/−0
- tests/QuickCheck/Set.hs +314/−0
- tests/QuickCheck/Subword.hs +230/−0
- tests/performance.hs +3/−3
- tests/properties.hs +7/−78
ADP/Fusion/Base.hs view
@@ -5,6 +5,8 @@ , 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.Point import ADP.Fusion.Base.Set import ADP.Fusion.Base.Subword+import ADP.Fusion.Base.TyLvlIx+import ADP.Fusion.Base.Unit
ADP/Fusion/Base/Classes.hs view
@@ -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 @@ | 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 @@ -- 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 _ = 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 @@ 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
ADP/Fusion/Base/Multi.hs view
@@ -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 @@ 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 @@ ( 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 @@ 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 @@ {-# 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,24 +106,18 @@ {-# 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 @@ 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+ )
ADP/Fusion/Base/Point.hs view
@@ -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 @@ -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 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 ( 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 #-}
ADP/Fusion/Base/Set.hs view
@@ -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,43 +64,101 @@ 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 (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 (BitSet C) where++instance+ ( Monad m+ ) => 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
ADP/Fusion/Base/Subword.hs view
@@ -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 @@ -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 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 @@ $ 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 #-}
+ ADP/Fusion/Base/Term.hs view
@@ -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 #-}+++-}+
+ ADP/Fusion/Base/TyLvlIx.hs view
@@ -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 #-}++-}+
+ ADP/Fusion/Base/Unit.hs view
@@ -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 #-}++
− ADP/Fusion/QuickCheck/Common.hs
@@ -1,10 +0,0 @@--{-# Options_GHC -O0 #-}--module ADP.Fusion.QuickCheck.Common where--import Debug.Trace----tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
− ADP/Fusion/QuickCheck/Point.hs
@@ -1,294 +0,0 @@--{-# Options_GHC -O0 #-}--module ADP.Fusion.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--import Data.PrimitiveArray--import ADP.Fusion------ * Epsilon cases--prop_Epsilon ix@(PointL j) = zs == ls where- zs = (id <<< Epsilon ... S.toList) maxPL 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_ZEpsilon ix@(Z:.PointL j) = zs == ls where- zs = (id <<< (M:|Epsilon) ... S.toList) (Z:.maxPL) 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_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 ]------ * Deletion cases--prop_O_ItNC ix@(O (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)- , ()- , xs VU.! (j+0)- ) | j >= 0, j <= 99 ]-{-# Noinline prop_O_ItNC #-}--prop_O_ZItNC ix@(O (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)))- , Z:.()- , Z:.xs VU.! (j+0)- ) | j >= 0, j <= 99 ]--prop_O_2dimIt_NC_CN ix@(O (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)))- , Z:.() :.xs VU.! (l+0)- , Z:.xs VU.! (j+0):.()- ) | j>=0, l>=0, j<=99, l<=99 ]--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- 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 ]------ * terminal cases---- | A single character terminal--prop_Tt ix@(Z:.PointL j) = zs == ls where- zs = (id <<< (M:|chr xs) ... S.toList) (Z:.maxPL) 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--- 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- 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 ]--prop_O_It ix@(O (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 ]--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 ]--prop_O_ZIt ix@(O (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 ]---- | 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- ls = [ ( unsafeIndex xsP (PointL $ j-1)- , xs VU.! (j-1)- ) | j>=1, j<=100 ]---- | @A^*_j -> A^*_{j+1} c_{j+1)@ !--prop_O_ItC ix@(O (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)- , xs VU.! (j+0)- ) | j >= 0, j < 100 ]--prop_O_ItCC ix@(O (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)- , xs VU.! (j+0)- , xs VU.! (j+1)- ) | j >= 0, j <= 98 ]-{-# Noinline prop_O_ItCC #-}--prop_O_ZItCC ix@(O (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)))- , Z:.xs VU.! (j+0)- , Z:.xs VU.! (j+1)- ) | j >= 0, j <= 98 ]---- | 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- 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 ]--prop_O_2dimItCC ix@(O (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)))- , 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 ]---- * 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---- * 'Strng' tests---- ** Just the 'Strng' terminal--prop_ManyS ix@(PointL j) = zs == ls where- zs = (id <<< manyS xs ... S.toList) maxPL ix- ls = [ (VU.slice 0 j xs) ]--prop_SomeS ix@(PointL j) = zs == ls where- zs = (id <<< someS xs ... S.toList) maxPL 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_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 ]---- ** 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- 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- 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- 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- 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- 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- 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] ]-----infixl 8 >>>-(>>>) f xs = \lu ij -> S.map f . mkStream (build xs) (initialContext ij) lu $ ij--class GetIxs x i where- type R x i :: *- getIxs :: Elm x i -> R x i--instance GetIxs S i where- type R S i = Z:.(i,i)- getIxs e = Z:.(getIdx e, getOmx e)--instance GetIxs ls i => GetIxs (ls :!: Chr a b) i where- type R (ls :!: Chr a b) i = R ls i :. (i,i)- getIxs (ElmChr _ i o s) = getIxs s :. (i,o)--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 ..]--xsZP :: Unboxed (Z:.PointL) Int-xsZP = fromList (Z:.PointL 0) (Z:.maxPL) [0 ..]--xsPo :: Unboxed (Outside (PointL)) Int-xsPo = fromList (O $ PointL 0) (O $ maxPL) [0 ..]--xsZPo :: Unboxed (Outside (Z:.PointL)) Int-xsZPo = fromList (O (Z:.PointL 0)) (O (Z:.maxPL)) [0 ..]--xsPP :: Unboxed (Z:.PointL:.PointL) Int-xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]--xsPPo :: Unboxed (Outside (Z:.PointL:.PointL)) Int-xsPPo = fromList (O (Z:.PointL 0:.PointL 0)) (O (Z:.maxPL:.maxPL)) [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 ..]--maxI = 100-maxPL = PointL maxI--xs = VU.fromList [0 .. maxI - 1 :: Int]---- * general quickcheck stuff--options = stdArgs {maxSuccess = 1000}--customCheck = quickCheckWithResult options--return []-allProps = $forAllProperties customCheck-
− ADP/Fusion/QuickCheck/Set.hs
@@ -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-
− ADP/Fusion/QuickCheck/Subword.hs
@@ -1,225 +0,0 @@--{-# Options_GHC -O0 #-}---- |------ TODO need to carefully check all props against boundary errors!--- Especially the 2-dim cases!--module ADP.Fusion.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.Unboxed as VU--import Data.PrimitiveArray--import ADP.Fusion-import ADP.Fusion.QuickCheck.Common------ * Outside checks---- ** two non-terminals on the r.h.s.------ A_ij -> B_ik C_kj------ B*_ik -> A*_ij C_kj--- C*_kj -> B_ik A*_ij--prop_sv_OI ox@(O (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) )- | j <- [ k .. highest ] ]--prop_sv_IO ox@(O (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) )- | j <= highest, i <- [ 0 .. k ] ]---- ** three non-terminals on the r.h.s. (this provides situations where two--- syntactic terminals are on the same side)------ A_ij -> B_ik C_kl D_lj------ B*_ik -> A*_ij C_kl D_lj--- 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- 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) )- | j <- [ k .. highest ], l <- [ k .. j ] ]--prop_sv_IOI ox@(O (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) )- | i <- [ 0 .. k ], j <- [ l .. highest ] ]--prop_sv_IIO ox@(O (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) )- | j <= highest, i <- [ 0 .. l ], k <- [ i .. l ] ]---- ** four non-terminals on the r.h.s. ?---- ** five non-terminals on the r.h.s. ?---- ** Non-terminal and terminal combinations--prop_cOc ox@(O( 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- ls = [ ( csS VU.! (i-1)- , unsafeIndex xoS (O $ subword (i-1) (j+1))- , csS VU.! (j ) )- | i > 0 && j < highest ]--prop_ccOcc ox@(O(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- ls = [ ( csS VU.! (i-2)- , csS VU.! (i-1)- , unsafeIndex xoS (O $ 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- 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- ls = [ ( csS VU.! (i-1)- , unsafeIndex xoS (O $ subword (i-1) (j+3))- , csS VU.! (j )- , csS VU.! (j+1)- , csS VU.! (j+2) )- | i > 0 && j < highest -2 ]---- ** Terminals, syntactic terminals, and non-terminals--prop_cOcIc ox@(O (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- ls = [ ( csS VU.! (i-1)- , unsafeIndex xoS (O $ subword (i-1) j )- , csS VU.! (k )- , 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- 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- ls = [ ( csS VU.! (i )- , unsafeIndex xsS ( subword (i+1) (k-1))- , csS VU.! (k-1)- , unsafeIndex xoS (O $ 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- ls = [ () | i==0 && j==highest ]----- ** Multi-tape cases--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- 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- ls = [ ( Z :. (csS VU.! i) :. (csS VU.! k)- , unsafeIndex xsSS (Z :. subword (i+1) j :. subword (k+1) l) )- | j<=highest && l<=highest- , i+1<=j && k+1<=l ]--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- 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- , i+1<=j && k+1<=l ]--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- 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)) )- | j<=highest && l<=highest- , i+2<=j && k+2<=l ]----highest = 10--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 = 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 ] ]--xsSS :: Unboxed (Z:.Subword:.Subword) ( (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] ]---- * general quickcheck stuff--options = stdArgs {maxSuccess = 10000}--customCheck = quickCheckWithResult options--return []-allProps = $forAllProperties customCheck-
ADP/Fusion/SynVar/Array.hs view
@@ -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 -{-+import Data.Proxy+import Data.Strict.Tuple hiding (snd)+import Data.Vector.Fusion.Stream.Monadic+import Prelude hiding (map,mapM) -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RankNTypes #-}+import Data.PrimitiveArray hiding (map) -{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}+import ADP.Fusion.Base+import ADP.Fusion.SynVar.Backtrack+import ADP.Fusion.SynVar.Indices --- | 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.+import ADP.Fusion.SynVar.Array.TermSymbol+import ADP.Fusion.SynVar.Array.Type -module ADP.Fusion.Table.Array--- ( MTbl (..)--- , BtTbl (..)- ( ITbl (..)--- , Backtrack (..)- , ToBT (..)- ) where -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 Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR,topmostIndex, Outside(..))-import qualified Data.PrimitiveArray as PA--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!+ , 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 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 #-}--}+ ( Monad mB+ , 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 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 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 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 #-}--} -{--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 #-}
− ADP/Fusion/SynVar/Array/Point.hs
@@ -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 #-}-
− ADP/Fusion/SynVar/Array/Set.hs
@@ -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 #-}-
− ADP/Fusion/SynVar/Array/Subword.hs
@@ -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 #-}-
ADP/Fusion/SynVar/Array/TermSymbol.hs view
@@ -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 @@ --- | 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 @@ {-# 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 !
ADP/Fusion/SynVar/Array/Type.hs view
@@ -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 @@ 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,8 +39,12 @@ 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 , PrimArrayOps arr i x@@ -59,6 +67,10 @@ 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 (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 @@ . 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 @@ . map (\s -> S5 s Z Z (getIdx s) (getOmx s)) $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is) {-# Inline mkStream #-}+-}+
ADP/Fusion/SynVar/Fill.hs view
@@ -117,7 +117,7 @@ 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 @@ {-# 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
ADP/Fusion/SynVar/Indices.hs view
@@ -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 @@ ++ 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) @@ -140,5 +156,9 @@ {-# INLINE [1] mk #-} {-# INLINE [1] step #-} {-# INLINE tableIndices #-}+-}+++ -}
+ ADP/Fusion/SynVar/Indices/Classes.hs view
@@ -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 #-}+
+ ADP/Fusion/SynVar/Indices/Point.hs view
@@ -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 #-}+
+ ADP/Fusion/SynVar/Indices/Set0.hs view
@@ -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 #-}+
+ ADP/Fusion/SynVar/Indices/Subword.hs view
@@ -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 #-}+
+ ADP/Fusion/SynVar/Indices/Unit.hs view
@@ -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 #-}+
ADP/Fusion/SynVar/Recursive/Subword.hs view
@@ -3,7 +3,6 @@ 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)
ADP/Fusion/SynVar/Split/Subword.hs view
@@ -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 @@ 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 ( 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 ( 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 ( 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
ADP/Fusion/SynVar/Split/Type.hs view
@@ -11,7 +11,6 @@ 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,9 +49,18 @@ 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
ADP/Fusion/Term/Chr.hs view
@@ -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
ADP/Fusion/Term/Chr/Point.hs view
@@ -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 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 #-} --- TODO @Inline [0]@ ???+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 #-} -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 #-}
+ ADP/Fusion/Term/Chr/Set0.hs view
@@ -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 #-}+
ADP/Fusion/Term/Chr/Subword.hs view
@@ -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 @@ 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 #-}+ ( 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 where+++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 #-}
ADP/Fusion/Term/Chr/Type.hs view
@@ -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 @@ 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
ADP/Fusion/Term/Deletion.hs view
@@ -3,11 +3,13 @@ ( 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 {-
ADP/Fusion/Term/Deletion/Point.hs view
@@ -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 @@ 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 TermStaticVar Deletion PointL where+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 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 #-}
ADP/Fusion/Term/Deletion/Subword.hs view
@@ -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 @@ 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 #-}+ ( 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 TermStaticVar Deletion Subword where+++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 termStaticVar #-}- {-# Inline termStreamIndex #-}+ {-# Inline [0] termStaticVar #-}+ {-# Inline [0] termStreamIndex #-}++instance TermStaticVar Deletion (Subword O) where+ termStaticVar _ sv _ = sv+ termStreamIndex _ _ ij = ij+ {-# Inline [0] termStaticVar #-}+ {-# Inline [0] termStreamIndex #-}
ADP/Fusion/Term/Deletion/Type.hs view
@@ -23,5 +23,5 @@ {-# Inline getIdx #-} {-# Inline getOmx #-} -type instance TermArg (TermSymbol a Deletion) = TermArg a :. ()+type instance TermArg Deletion = ()
+ ADP/Fusion/Term/Deletion/Unit.hs view
@@ -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 #-}+
ADP/Fusion/Term/Edge/Set.hs view
@@ -3,8 +3,7 @@ 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 @@ 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 ( 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 ( 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
ADP/Fusion/Term/Edge/Type.hs view
@@ -28,5 +28,5 @@ 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
ADP/Fusion/Term/Epsilon.hs view
@@ -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 {-
ADP/Fusion/Term/Epsilon/Point.hs view
@@ -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 @@ 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 TermStaticVar Epsilon PointL where+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 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 #-}
+ ADP/Fusion/Term/Epsilon/Set.hs view
@@ -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 #-}+
ADP/Fusion/Term/Epsilon/Subword.hs view
@@ -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 ADP.Fusion.Base import ADP.Fusion.Term.Epsilon.Type ---import Data.Vector.Fusion.Util - instance- ( Monad m- , MkStream m ls Subword- ) => MkStream m (ls :!: Epsilon) Subword where- mkStream (ls :!: Epsilon) (IStatic ()) hh ij@(Subword (i:.j))- = staticCheck (i==j)- $ map (ElmEpsilon (subword i j) (subword 0 0))- $ mkStream ls (IStatic ()) hh ij+ ( 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 (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 #-} +instance+ ( 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 (\(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- , 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 #-}+ ( 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 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 #-}
ADP/Fusion/Term/Epsilon/Type.hs view
@@ -23,5 +23,5 @@ {-# Inline getIdx #-} {-# Inline getOmx #-} -type instance TermArg (TermSymbol a Epsilon) = TermArg a :. ()+type instance TermArg Epsilon = ()
+ ADP/Fusion/Term/Epsilon/Unit.hs view
@@ -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 #-}+
ADP/Fusion/Term/PeekIndex/Subword.hs view
@@ -14,9 +14,9 @@ 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
ADP/Fusion/Term/PeekIndex/Type.hs view
@@ -27,5 +27,5 @@ 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
ADP/Fusion/Term/Strng/Point.hs view
@@ -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 @@ 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 #-}
ADP/Fusion/Term/Strng/Subword.hs view
@@ -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 @@ +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@@ -41,4 +73,6 @@ {-# Inline [0] mk #-} {-# Inline [0] step #-} {-# Inline mkStream #-}++-}
ADP/Fusion/Term/Strng/Type.hs view
@@ -52,5 +52,5 @@ 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
ADPfusion.cabal view
@@ -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 @@ 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 @@ 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 @@ 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 @@ 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 @@ ADP.Fusion.TH.Common default-extensions: BangPatterns+ , ConstraintKinds+ , CPP , DataKinds , DefaultSignatures , FlexibleContexts@@ -152,6 +158,7 @@ , ScopedTypeVariables , StandaloneDeriving , TemplateHaskell+ , TupleSections , TypeFamilies , TypeOperators , TypeSynonymInstances@@ -455,19 +462,39 @@ 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
changelog.md view
@@ -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 -------
src/Durbin.hs view
@@ -26,7 +26,7 @@ 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 @@ spl <<< tt % tt ... h ) tt = toNonEmpty t+ {-# Inline tt #-} in (Z:.t) {-# INLINE grammar #-} @@ -106,10 +107,11 @@ !(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
src/NeedlemanWunsch.hs view
@@ -28,7 +28,6 @@ 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 @@ -- 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 @@ 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 @@ 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
src/Nussinov.hs view
@@ -13,7 +13,7 @@ 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 @@ 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 @@ 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 #-}
src/OverlappingPalindromes.hs view
@@ -26,7 +26,6 @@ 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 @@ 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 ()
src/PartNussinov.hs view
@@ -14,7 +14,6 @@ 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 @@ -> 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 @@ -- * 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 @@ 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 @@ 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 @@ $ 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 #-} {-
src/Pseudoknot.hs view
@@ -10,7 +10,6 @@ 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 @@ } {-# 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 @@ -} {-# 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)
src/SplitTests.hs view
@@ -26,7 +26,6 @@ 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 @@ 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 ()
+ tests/QuickCheck/Common.hs view
@@ -0,0 +1,10 @@++{-# Options_GHC -O0 #-}++module QuickCheck.Common where++import Debug.Trace++++tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
+ tests/QuickCheck/Point.hs view
@@ -0,0 +1,320 @@++{-# Options_GHC -O0 #-}++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.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++import ADP.Fusion++++-- * Epsilon cases++prop_Epsilon ix@(PointL j) = zs == ls where+ zs = (id <<< Epsilon ... stoList) maxPLi ix+ ls = [ () | j == 0 ]++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) ... stoList) (Z:.maxPLi) ix+ ls = [ Z:.() | j == 0 ]++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@(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_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 ... stoList) maxPLo ix+ ls = [ ( unsafeIndex xsPo (PointL $ j+1)+ , ()+ , xs VU.! (j+0)+ ) | j >= 0, j <= (maxI-1) ]+{-# Noinline prop_O_ItNC #-}++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) ... stoList) (Z:.maxPLo) ix+ ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+1))+ , Z:.()+ , Z:.xs VU.! (j+0)+ ) | j >= 0, j <= (maxI-1) ]++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) ... 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<=(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) ... 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<=maxI, l<=maxI ]++++-- * terminal cases++-- | A single character terminal++prop_Tt ix@(Z:.PointL j) = zs == ls where+ 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) ... 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) ... 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 ... stoList) maxPLi ix+ ls = [ unsafeIndex xsP ix | j>=0, j<=maxI ]++prop_O_It ix@(PointL j) = zs == ls where+ t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+ 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 ... stoList) (Z:.maxPLi) ix+ ls = [ unsafeIndex xsZP ix | j>=0, j<=maxI ]++prop_O_ZIt ix@(Z:.PointL j) = zs == ls where+ t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)+ 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 ... stoList) maxPLi ix+ ls = [ ( unsafeIndex xsP (PointL $ j-1)+ , xs VU.! (j-1)+ ) | j>=1, j<=maxI ]++-- | @A^*_j -> A^*_{j+1} c_{j+1)@ !++prop_O_ItC ix@(PointL j) = zs == ls where+ t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+ zs = ((,) <<< t % chr xs ... stoList) maxPLo ix+ ls = [ ( unsafeIndex xsPo (PointL $ j+1)+ , xs VU.! (j+0)+ ) | j >= 0, j < maxI ]++prop_O_ItCC ix@(PointL j) = zs == ls where+ t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+ 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 <= (maxI-2) ]+{-# Noinline prop_O_ItCC #-}++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) ... stoList) (Z:.maxPLo) ix+ ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+2))+ , Z:.xs VU.! (j+0)+ , Z:.xs VU.! (j+1)+ ) | 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) ... 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<=maxI, l<=maxI ]++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) ... 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<=(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) ... stoList) (O (Z:.maxPLo)) ix+-}++-- * 'Strng' tests++-- ** Just the 'Strng' terminal++prop_ManyS ix@(PointL j) = zs == ls where+ 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 ... 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) ... 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) ... 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 ... 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 ... 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) ... 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) ... 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) ... 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) ... 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 -> SM.map f . mkStream (build xs) (initialContext ij) lu $ ij++class GetIxs x i where+ type R x i :: *+ getIxs :: Elm x i -> R x i++instance GetIxs S i where+ type R S i = Z:.(i,i)+ getIxs e = Z:.(getIdx e, getOmx e)++instance GetIxs ls i => GetIxs (ls :!: Chr a b) i where+ type R (ls :!: Chr a b) i = R ls i :. (i,i)+ getIxs (ElmChr _ i o s) = getIxs s :. (i,o)++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 I) Int+xsP = fromList (PointL 0) maxPLi [0 ..]++xsZP :: Unboxed (Z:.PointL I) Int+xsZP = fromList (Z:.PointL 0) (Z:.maxPLi) [0 ..]++xsPo :: Unboxed (PointL O) Int+xsPo = fromList (PointL 0) maxPLo [0 ..]++xsZPo :: Unboxed (Z:.PointL O) Int+xsZPo = fromList (Z:.PointL 0) (Z:.maxPLo) [0 ..]++xsPP :: Unboxed (Z:.PointL I:.PointL I) Int+xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPLi:.maxPLi) [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 I:.PointL I) Int))+ zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPLi:.maxPLi) [0 ..]++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 } -- 0}++customCheck = quickCheckWithResult options++return []+allProps = $forAllProperties customCheck++++#ifdef ADPFUSION_TEST_SUITE_PROPERTIES+testgroup_point = $(testGroupGenerator)+#endif+
+ tests/QuickCheck/Set.hs view
@@ -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++
+ tests/QuickCheck/Subword.hs view
@@ -0,0 +1,230 @@++{-# Options_GHC -O0 #-}++-- |+--+-- TODO need to carefully check all props against boundary errors!+-- Especially the 2-dim cases!++module QuickCheck.Subword where++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++++-- * Outside checks++-- ** two non-terminals on the r.h.s.+--+-- A_ij -> B_ik C_kj+--+-- B*_ik -> A*_ij C_kj+-- C*_kj -> B_ik A*_ij++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 ... stoList) maxSWo ox+ ls = [ ( unsafeIndex xoS (subword i j)+ , unsafeIndex xsS (subword k j) )+ | j <- [ k .. highest ] ]++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 ... 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+-- syntactic terminals are on the same side)+--+-- A_ij -> B_ik C_kl D_lj+--+-- B*_ik -> A*_ij C_kl D_lj+-- C*_kl -> B_ik A*_ij D_lj+-- D*_lj -> B_ik C_kl A*_ij++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 ... 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@(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 ... 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@(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 ... 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. ?++-- ** five non-terminals on the r.h.s. ?++-- ** Non-terminal and terminal combinations++prop_cOc ox@(Subword (i:.j)) = zs == ls where+ toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))+ zs = ((,,) <<< chr csS % toa % chr csS ... stoList) maxSWo ox+ ls = [ ( csS VU.! (i-1)+ , unsafeIndex xoS (subword (i-1) (j+1))+ , csS VU.! (j ) )+ | i > 0 && j < highest ]++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 ... stoList) maxSWo ox+ ls = [ ( csS VU.! (i-2)+ , csS VU.! (i-1)+ , unsafeIndex xoS (subword (i-2) (j+2))+ , csS VU.! (j )+ , csS VU.! (j+1) )+ | i > 1 && j < highest -1 ]++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 ... stoList) maxSWo ox+ ls = [ ( csS VU.! (i-1)+ , unsafeIndex xoS (subword (i-1) (j+3))+ , csS VU.! (j )+ , csS VU.! (j+1)+ , csS VU.! (j+2) )+ | i > 0 && j < highest -2 ]++-- ** Terminals, syntactic terminals, and non-terminals++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 ... stoList) maxSWo ox+ ls = [ ( csS VU.! (i-1)+ , unsafeIndex xoS (subword (i-1) j )+ , csS VU.! (k )+ , unsafeIndex xsS (subword (k+1) (j-1))+ , csS VU.! (j-1) )+ | i > 0, j <- [ k+2 .. highest ] ]++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 ... stoList) maxSWo ox+ ls = [ ( csS VU.! (i )+ , unsafeIndex xsS (subword (i+1) (k-1))+ , csS VU.! (k-1)+ , unsafeIndex xoS (subword i (j+1))+ , csS VU.! (j ) )+ | j+1 <= highest, k>1, i <- [ 0 .. k-2 ] ]++-- ** Epsilonness++prop_Epsilon ox@(Subword (i:.j)) = zs == ls where+ zs = (id <<< Epsilon ... stoList) (maxSWo) ox+ ls = [ () | i==0 && j==highest ]+++-- ** Multi-tape cases++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 ... stoList) (Z:.subword 0 highest:.subword 0 highest) ix+ ls = [ ( unsafeIndex xsSS ix ) | j<=highest && l<=highest ]++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 ... 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+ , i+1<=j && k+1<=l ]++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) ... 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+ , i+1<=j && k+1<=l ]++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) ... 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)) )+ | j<=highest && l<=highest+ , i+2<=j && k+2<=l ]++++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 I) (Int,Int)+xsS = fromList (subword 0 0) (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 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] ]++-- * general quickcheck stuff++options = stdArgs {maxSuccess = 10000}++customCheck = quickCheckWithResult options++return []+allProps = $forAllProperties customCheck++++#ifdef ADPFUSION_TEST_SUITE_PROPERTIES+testgroup_subword = $(testGroupGenerator)+#endif+
tests/performance.hs view
@@ -48,7 +48,7 @@ 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 @@ -- | 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 @@ 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
tests/properties.hs view
@@ -4,87 +4,16 @@ module Main where -import Test.Framework.Providers.QuickCheck2-import Test.Framework.TH--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+--import Test.Framework.Providers.QuickCheck2+--import Test.Framework.TH+import Test.Framework -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]