diff --git a/ADP/Fusion/Base.hs b/ADP/Fusion/Base.hs --- a/ADP/Fusion/Base.hs +++ b/ADP/Fusion/Base.hs @@ -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 diff --git a/ADP/Fusion/Base/Classes.hs b/ADP/Fusion/Base/Classes.hs --- a/ADP/Fusion/Base/Classes.hs +++ b/ADP/Fusion/Base/Classes.hs @@ -2,7 +2,6 @@ module ADP.Fusion.Base.Classes where import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Size import qualified Data.Vector.Fusion.Stream.Monadic as S import Data.PrimitiveArray @@ -14,13 +13,16 @@ | 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 diff --git a/ADP/Fusion/Base/Multi.hs b/ADP/Fusion/Base/Multi.hs --- a/ADP/Fusion/Base/Multi.hs +++ b/ADP/Fusion/Base/Multi.hs @@ -2,11 +2,15 @@ module ADP.Fusion.Base.Multi where import qualified Data.Vector.Fusion.Stream.Monadic as S +import Data.Vector.Fusion.Stream.Monadic import Data.Strict.Tuple +import Data.Proxy +import Prelude hiding (map) -import Data.PrimitiveArray +import Data.PrimitiveArray hiding (map) import ADP.Fusion.Base.Classes +import ADP.Fusion.Base.TyLvlIx @@ -30,6 +34,7 @@ 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 + ) diff --git a/ADP/Fusion/Base/Point.hs b/ADP/Fusion/Base/Point.hs --- a/ADP/Fusion/Base/Point.hs +++ b/ADP/Fusion/Base/Point.hs @@ -1,8 +1,7 @@ module ADP.Fusion.Base.Point where -import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..),flatten) -import Data.Vector.Fusion.Stream.Size +import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) import Debug.Trace import Prelude hiding (map,filter) @@ -13,35 +12,35 @@ -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 #-} diff --git a/ADP/Fusion/Base/Set.hs b/ADP/Fusion/Base/Set.hs --- a/ADP/Fusion/Base/Set.hs +++ b/ADP/Fusion/Base/Set.hs @@ -6,52 +6,57 @@ module ADP.Fusion.Base.Set where import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr) -import Data.Vector.Fusion.Stream.Size import Debug.Trace import Prelude hiding (map,filter) import Data.Bits +import Data.Bits.Ordered -import Data.PrimitiveArray +import Data.PrimitiveArray hiding (map) import ADP.Fusion.Base.Classes import ADP.Fusion.Base.Multi -type instance TblConstraint BitSet = TableConstraint -type instance TblConstraint (BitSet:>Interface i:>Interface j) = TableConstraint +type instance TblConstraint (BitSet t) = TableConstraint +type instance TblConstraint (BS2 i j t) = TableConstraint -instance RuleContext BitSet where - type Context BitSet = InsideContext Int +instance RuleContext (BitSet I) where + type Context (BitSet I) = InsideContext Int initialContext _ = IStatic 0 {-# Inline initialContext #-} -instance RuleContext (Outside BitSet) where - type Context (Outside BitSet) = OutsideContext () - initialContext _ = OStatic () +-- | The @Int@ in an @OutsideContext@ counts how many bits need to be fixed +-- statically. I.e. if the bits @{1,2}@ are set in @X -> Y t@, and @t@ has +-- size @1@, then @Y@ will have @{1,2,3}@, @{1,2,4}@ and so on, with @t@ +-- having @3, 4, ...@ as values. + +instance RuleContext (BitSet O) where + type Context (BitSet O) = OutsideContext Int + initialContext _ = OStatic 0 {-# Inline initialContext #-} -instance RuleContext (Complement BitSet) where - type Context (Complement BitSet) = ComplementContext +instance RuleContext (BitSet C) where + type Context (BitSet C) = ComplementContext initialContext _ = Complemented {-# Inline initialContext #-} -instance RuleContext (BS2I First Last) where - type Context (BS2I First Last) = InsideContext Int +instance RuleContext (BS2 First Last I) where + type Context (BS2 First Last I) = InsideContext Int initialContext _ = IStatic 0 {-# Inline initialContext #-} -instance RuleContext (Outside (BS2I First Last)) where - type Context (Outside (BS2I First Last)) = OutsideContext () +instance RuleContext (BS2 First Last O) where + type Context (BS2 First Last O) = OutsideContext () initialContext _ = OStatic () {-# Inline initialContext #-} -instance RuleContext (Complement (BS2I First Last)) where - type Context (Complement (BS2I First Last)) = ComplementContext +instance RuleContext (BS2 First Last C) where + type Context (BS2 First Last C) = ComplementContext initialContext _ = Complemented {-# Inline initialContext #-} @@ -59,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 diff --git a/ADP/Fusion/Base/Subword.hs b/ADP/Fusion/Base/Subword.hs --- a/ADP/Fusion/Base/Subword.hs +++ b/ADP/Fusion/Base/Subword.hs @@ -5,7 +5,6 @@ module ADP.Fusion.Base.Subword where import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr) -import Data.Vector.Fusion.Stream.Size import Debug.Trace import Prelude hiding (map,filter) @@ -16,55 +15,62 @@ -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 #-} diff --git a/ADP/Fusion/Base/Term.hs b/ADP/Fusion/Base/Term.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Base/Term.hs @@ -0,0 +1,55 @@ + +module ADP.Fusion.Base.Term where + +{- + +import Data.Vector.Fusion.Stream.Monadic +import Prelude hiding (map) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base.Classes +import ADP.Fusion.Base.Multi + + + +data TermState s a i e = TState + { sS :: !s -- | state coming in from the left + , sIx :: !a -- | @I/C@ index from @sS@ + , sOx :: !a -- | @O@ index from @sS@ +-- , tt :: !u -- | @I/C@ building up state to index the @table@. + , iIx :: !i -- | @I/C@ building up state to hand over to next symbol + , iOx :: !i -- | @O@ building up state to hand over to next symbol + , eTS :: !e -- | element data + } + +class TermStream m t a i where + termStream :: t -> Context i -> i -> i -> Stream m (TermState s a Z Z) -> Stream m (TermState s a i (TermArg t)) + +instance TermStream m M a Z where + termStream _ _ _ _ = id + {-# Inline termStream #-} + +-- | +-- +-- TODO need @t -> ElmType t@ type function +-- +-- TODO need to actually return an @ElmType t@ can do that instead of +-- returning @u@ !!! + +addTermStream1 + :: ( Monad m + , TermStream m (TermSymbol M t) (Z:.a) (Z:.i) + , s ~ Elm x0 a + , Element x0 a + ) + => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,i,i) +addTermStream1 t c u i + = map (\(TState sS _ _ (Z:.ii) (Z:.oo) (Z:.ee)) -> (sS,ee,ii,oo)) + . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i) + . map (\s -> TState s (Z:.getIdx s) (Z:.getOmx s) Z Z Z) +{-# Inline addTermStream1 #-} + + +-} + diff --git a/ADP/Fusion/Base/TyLvlIx.hs b/ADP/Fusion/Base/TyLvlIx.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Base/TyLvlIx.hs @@ -0,0 +1,77 @@ + +-- | Type-level indexing functionality + +module ADP.Fusion.Base.TyLvlIx where + +import Data.Proxy +import GHC.TypeLits + +import Data.PrimitiveArray hiding (map) + + + +-- | Given some complete index list @ixTy@ and some lower-dimensional +-- version @myTy@, walk down along @ixTy@ until we have @is:.i ~ ms:.m@ and +-- return @m@. + +class GetIndexGo ixTy myTy (cmp :: Ordering) where + type ResolvedIx ixTy myTy cmp :: * + getIndexGo :: ixTy -> (Proxy myTy) -> (Proxy cmp) -> ResolvedIx ixTy myTy cmp + +instance GetIndexGo (ix:.i) (my:.m) EQ where + type ResolvedIx (ix:.i) (my:.m) EQ = i + getIndexGo (ix:.i) _ _ = i + {-# Inline getIndexGo #-} + +instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where + type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m))) + getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m)))) + {-# Inline getIndexGo #-} + +instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where + type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z)) + getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z))) + {-# Inline getIndexGo #-} + +instance GetIndexGo Z Z EQ where + type ResolvedIx Z Z EQ = Z + getIndexGo _ _ _ = Z + {-# Inline getIndexGo #-} + +-- | Wrap @GetIndexGo@ and the type-level shenanigans. + +type GetIndex l r = GetIndexGo l r (CmpNat (ToNat l) (ToNat r)) + +type GetIx l r = ResolvedIx l r (CmpNat (ToNat l) (ToNat r)) + +-- | Simplifying wrapper around @getIndexGo@. + +getIndex + :: forall ixTy myTy + . GetIndex ixTy myTy + => ixTy + -> Proxy myTy + -> GetIx ixTy myTy +getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy))) +{-# Inline getIndex #-} + + + +-- | Given some index structure @x@, return the dimensional number in +-- @Nat@s. + +type family ToNat x :: Nat + +type instance ToNat Z = 0 +type instance ToNat (is:.i) = ToNat is + 1 + + + +{- + +testggg :: (Z:.Int:.Char) -> Int +testggg ab = getIndex ab (Proxy :: Proxy (Z:.Int)) -- (Z:.(3::Int)) +{-# NoInline testggg #-} + +-} + diff --git a/ADP/Fusion/Base/Unit.hs b/ADP/Fusion/Base/Unit.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Base/Unit.hs @@ -0,0 +1,96 @@ + +-- | +-- +-- TODO the 'mkStream' instances here are probably wonky for everything +-- that is non-static. + +module ADP.Fusion.Base.Unit where + +import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) +import Debug.Trace +import Prelude hiding (map,filter) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base.Classes +import ADP.Fusion.Base.Multi + + + +instance RuleContext (Unit I) where + type Context (Unit I) = InsideContext () + initialContext _ = IStatic () + {-# Inline initialContext #-} + +instance RuleContext (Unit O) where + type Context (Unit O) = OutsideContext () + initialContext _ = OStatic () + {-# Inline initialContext #-} + +instance RuleContext (Unit C) where + type Context (Unit C) = ComplementContext + initialContext _ = Complemented + {-# Inline initialContext #-} + + + +instance (Monad m) => MkStream m S (Unit I) where + mkStream S _ Unit Unit = singleton $ ElmS Unit Unit + {-# Inline mkStream #-} + +instance (Monad m) => MkStream m S (Unit O) where + mkStream S _ Unit Unit = singleton $ ElmS Unit Unit + {-# Inline mkStream #-} + +instance (Monad m) => MkStream m S (Unit C) where + mkStream S _ Unit Unit = singleton $ ElmS Unit Unit + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m S is + ) => MkStream m S (is:.Unit I) where + mkStream S (vs:._) (us:._) (is:._) + = map (\(ElmS zi zo) -> ElmS (zi:.Unit) (zo:.Unit)) + $ mkStream S vs us is + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m S is + ) => MkStream m S (is:.Unit O) where + mkStream S (vs:._) (us:._) (is:._) + = map (\(ElmS zi zo) -> ElmS (zi:.Unit) (zo:.Unit)) + $ mkStream S vs us is + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m S is + ) => MkStream m S (is:.Unit C) where + mkStream S (vs:._) (us:._) (is:._) + = map (\(ElmS zi zo) -> ElmS (zi:.Unit) (zo:.Unit)) + $ mkStream S vs us is + {-# Inline mkStream #-} + + + +instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit I) where + tableStaticVar _ _ _ _ = IStatic () + tableStreamIndex _ _ _ _ = Unit + {-# Inline [0] tableStaticVar #-} + {-# Inline [0] tableStreamIndex #-} + +instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit O) where + tableStaticVar _ _ _ _ = OStatic () + tableStreamIndex _ _ _ _ = Unit + {-# Inline [0] tableStaticVar #-} + {-# Inline [0] tableStreamIndex #-} + +instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit C) where + tableStaticVar _ _ _ _ = Complemented + tableStreamIndex _ _ _ _ = Unit + {-# Inline [0] tableStaticVar #-} + {-# Inline [0] tableStreamIndex #-} + + diff --git a/ADP/Fusion/QuickCheck/Common.hs b/ADP/Fusion/QuickCheck/Common.hs deleted file mode 100644 --- a/ADP/Fusion/QuickCheck/Common.hs +++ /dev/null @@ -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 diff --git a/ADP/Fusion/QuickCheck/Point.hs b/ADP/Fusion/QuickCheck/Point.hs deleted file mode 100644 --- a/ADP/Fusion/QuickCheck/Point.hs +++ /dev/null @@ -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 - diff --git a/ADP/Fusion/QuickCheck/Set.hs b/ADP/Fusion/QuickCheck/Set.hs deleted file mode 100644 --- a/ADP/Fusion/QuickCheck/Set.hs +++ /dev/null @@ -1,248 +0,0 @@ - -{-# Options_GHC -O0 #-} - -module ADP.Fusion.QuickCheck.Set where - -import Data.Bits -import Data.Vector.Fusion.Util -import Debug.Trace -import qualified Data.List as L -import qualified Data.Vector.Fusion.Stream as S -import qualified Data.Vector.Unboxed as VU -import Test.QuickCheck hiding (NonEmpty) -import Test.QuickCheck.All -import Test.QuickCheck.Monadic - -import Data.Bits.Ordered -import Data.PrimitiveArray - -import ADP.Fusion -import ADP.Fusion.QuickCheck.Common - - - --- * BitSets without interfaces - --- ** Inside checks - -prop_b_ii ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - zs = ((,) <<< tia % tib ... S.toList) highestB ix - ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) - | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] - , let kk = popShiftL ix (BitSet k) - ] - -prop_b_ii_nn ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - zs = ((,) <<< tia % tib ... S.toList) highestB ix - ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) - | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] - , let kk = popShiftL ix (BitSet k) - , popCount kk > 0 - , popCount (ix `xor` kk) > 0 - ] - -prop_b_iii ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix - ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm ) - | k <- VU.toList . popCntSorted $ popCount ix - , l <- VU.toList . popCntSorted $ popCount ix - popCount k - , let kk = popShiftL ix (BitSet k) - , let ll = popShiftL (ix `xor` kk) (BitSet l) - , let mm = (ix `xor` (kk .|. ll)) - ] - -prop_b_iii_nnn ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix - ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm ) - | k <- VU.toList . popCntSorted $ popCount ix - , l <- VU.toList . popCntSorted $ popCount ix - popCount k - , let kk = popShiftL ix (BitSet k) - , let ll = popShiftL (ix `xor` kk) (BitSet l) - , let mm = (ix `xor` (kk .|. ll)) - , popCount kk > 0, popCount ll > 0, popCount mm > 0 - ] - - --- * Outside checks --- These checks are very similar to those in the @Subword@ module. We just --- need to be a bit more careful, as indexed sets have overlap. - --- ** Two non-terminals. --- --- @A_s -> B_(s\t) C_t (s\t) ++ t == s@ --- @s = 111 , s\t = 101, t = 010@ --- --- with @Z@ the full set. --- @Z = 1111@ - --- @B*_Z\(s\t) -> A*_Z\s C_t@ --- @Z\(s\t) = 1010, Z\s = 1000, t = 010@ - - - - --- * BitSets with two interfaces - --- ** Inside checks - -prop_bii_i :: BS2I First Last -> Bool -prop_bii_i ix@(s:>i:>j) = zs == ls where - tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) - zs = (id <<< tia ... S.toList) highestBII ix - ls = [ xsBII ! ix ] - -prop_bii_i_n :: BS2I First Last -> Bool -prop_bii_i_n ix@(s:>i:>j) = zs == ls where - tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) - zs = (id <<< tia ... S.toList) highestBII ix - ls = [ xsBII ! ix | popCount s > 0 ] - --- | Edges should never work as a single terminal element. - -prop_bii_e :: BS2I First Last -> Bool -prop_bii_e ix@(s:>Iter i:>Iter j) = zs == ls where - e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) - zs = (id <<< e ... S.toList) highestBII ix - ls = [] :: [ (Int,Int) ] - --- | Edges extend only in cases where in @i -> j@, @i@ actually happens to --- be a true interface. - -prop_bii_ie :: BS2I First Last -> Bool -prop_bii_ie ix@(s:>i:>Iter j) = zs == ls where - tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) - e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) - zs = ((,) <<< tia % e ... S.toList) highestBII ix - ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) ) - | let t = s `clearBit` j - , k <- activeBitsL t ] - -prop_bii_ie_n :: BS2I First Last -> Bool -prop_bii_ie_n ix@(s:>i:>Iter j) = zs == ls where - tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) - e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) - zs = ((,) <<< tia % e ... S.toList) highestBII ix - ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) ) - | let t = s `clearBit` j - , popCount t >= 2 - , k <- activeBitsL t - , k /= getIter i - ] - -prop_bii_iee :: BS2I First Last -> Bool -prop_bii_iee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where - tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) - e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) - zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix - ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) ) - | let tmp = (s `clearBit` j) - , l <- activeBitsL tmp - , l /= getIter i - , let t = tmp `clearBit` l - , k <- activeBitsL t - , let kk = Iter k - ] - -prop_bii_ieee :: BS2I First Last -> Bool -prop_bii_ieee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where - tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) - e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) - zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix - ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) ) - | let tmpM = (s `clearBit` j) - , m <- activeBitsL tmpM - , m /= getIter i - , let tmpL = (tmpM `clearBit` m) - , l <- activeBitsL tmpL - , l /= getIter i - , let t = tmpL `clearBit` l - , k <- activeBitsL t - , let kk = Iter k - ] - -prop_bii_iee_n :: BS2I First Last -> Bool -prop_bii_iee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where - tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) - e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) - zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix - ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) ) - | let tmp = (s `clearBit` j) - , l <- activeBitsL tmp - , l /= getIter i - , let t = tmp `clearBit` l - , popCount t >= 2 - , k <- activeBitsL t - , k /= getIter i - , let kk = Iter k - ] - -prop_bii_ieee_n :: BS2I First Last -> Bool -prop_bii_ieee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where - tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) - e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) - zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix - ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) ) - | let tmpM = (s `clearBit` j) - , m <- activeBitsL tmpM - , m /= getIter i - , let tmpL = (tmpM `clearBit` m) - , l <- activeBitsL tmpL - , l /= getIter i - , let t = tmpL `clearBit` l - , popCount t >= 2 - , k <- activeBitsL t - , k /= getIter i - , let kk = Iter k - ] - --- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where --- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- zs = ((,) <<< tia % tib ... S.toList) highestBII ix --- ls = [ ( xsBII ! kk , xsBII ! ll ) --- | k <- VU.toList . popCntSorted $ popCount s --- , ki <- if k==0 then [0] else activeBitsL k --- , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki) --- , let kk = (BitSet k:>Iter ki:>Iter kj) --- , let l = s `xor` BitSet k --- , li <- if l==0 then [0] else activeBitsL l --- , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li) --- , let ll = (l:>Iter li:>Iter lj) --- ] - - - --- * Helper functions - -highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary -highestB = BitSet $ 2^(highBit+1) -1 -highestBII = highestB :> Iter (highBit-1) :> Iter (highBit-1) -- assuming @highBit >= 1@ - -xsB :: Unboxed BitSet Int -xsB = fromList (BitSet 0) highestB [ 0 .. ] - -xoB :: Unboxed (Outside BitSet) Int -xoB = fromList (O (BitSet 0)) (O highestB) [ 0 .. ] - -xsBII :: Unboxed (BitSet:>Interface First:>Interface Last) Int -xsBII = fromList (BitSet 0:>Iter 0:>Iter 0) highestBII [ 0 .. ] - --- * general quickcheck stuff - -options = stdArgs {maxSuccess = 1000} - -customCheck = quickCheckWithResult options - -return [] -allProps = $forAllProperties customCheck - diff --git a/ADP/Fusion/QuickCheck/Subword.hs b/ADP/Fusion/QuickCheck/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/QuickCheck/Subword.hs +++ /dev/null @@ -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 - diff --git a/ADP/Fusion/SynVar/Array.hs b/ADP/Fusion/SynVar/Array.hs --- a/ADP/Fusion/SynVar/Array.hs +++ b/ADP/Fusion/SynVar/Array.hs @@ -1,293 +1,137 @@ module ADP.Fusion.SynVar.Array ( module ADP.Fusion.SynVar.Array.Type - , module ADP.Fusion.SynVar.Array.Point - , module ADP.Fusion.SynVar.Array.Set - , module ADP.Fusion.SynVar.Array.Subword + , module ADP.Fusion.SynVar.Array ) where -import ADP.Fusion.SynVar.Array.Point -import ADP.Fusion.SynVar.Array.Set -import ADP.Fusion.SynVar.Array.Subword -import ADP.Fusion.SynVar.Array.TermSymbol -import ADP.Fusion.SynVar.Array.Type -{- +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 #-} diff --git a/ADP/Fusion/SynVar/Array/Point.hs b/ADP/Fusion/SynVar/Array/Point.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Array/Point.hs +++ /dev/null @@ -1,79 +0,0 @@ - -module ADP.Fusion.SynVar.Array.Point where - -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic -import Data.Vector.Fusion.Stream.Size -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Prelude hiding (map,mapM) ---import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Backtrack - - - -instance - ( Monad m - , Element ls PointL - , PrimArrayOps arr PointL x - , MkStream m ls PointL - ) => MkStream m (ls :!: ITbl m arr PointL x) PointL where - mkStream (ls :!: ITbl _ _ c t _) (IStatic d) u j@(PointL pj) - = let ms = minSize c in ms `seq` - map (ElmITbl (t!j) j (PointL 0)) - $ mkStream ls (IVariable d) u (PointL $ pj - ms) - -- We can't really make sure that this is the only time we access the - -- ITbl, so the user should know what they are doing. - mkStream (ls :!: ITbl _ _ c t _) (IVariable d) u j@(PointL pj) - = flatten mk step Unknown $ mkStream ls (IVariable d) u (delay_inline PointL $! pj - ms) - where mk s = let PointL k = getIdx s in return (s :. k) - step (s :. k) - | k+ms>pj = return $ Done - | otherwise = return $ Yield (ElmITbl (t!PointL k) (PointL k) (PointL 0) s) (s :. k+1) - !ms = minSize c - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - -instance - ( Monad mB - , Element ls PointL - , PrimArrayOps arr PointL x - , MkStream mB ls PointL - ) => MkStream mB (ls :!: Backtrack (ITbl mF arr PointL x) mF mB r) PointL where - mkStream (ls :!: BtITbl c t bt) (IStatic d) u j@(PointL pj) - = let ms = minSize c in ms `seq` - mapM (\s -> bt u j >>= \bb -> return $ ElmBtITbl (t!j) (bb {-bt u j-}) j (PointL 0) s) - $ mkStream ls (IVariable d) u (PointL $ pj - ms) - {-# INLINE mkStream #-} - -instance - ( Monad m - , Element ls (Outside PointL) - , PrimArrayOps arr (Outside PointL) x - , MkStream m ls (Outside PointL) - ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where - mkStream (ls :!: ITbl _ _ c t _) (OStatic d) u (O (PointL pj)) - = let ms = minSize c in ms `seq` - map (\z -> let o = getOmx z - in ElmITbl (t ! o) o o z) - $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms) - {-# Inline mkStream #-} - -instance - ( Monad mB - , Element ls (Outside PointL) - , PrimArrayOps arr (Outside PointL) x - , MkStream mB ls (Outside PointL) - ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where - mkStream (ls :!: BtITbl c t bt) (OStatic d) u (O (PointL pj)) - = let ms = minSize c in ms `seq` - mapM (\s -> let o = getOmx s in bt u o >>= \bb -> return $ ElmBtITbl (t!o) (bb{-bt u o-}) o o s) - $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms) - {-# INLINE mkStream #-} - diff --git a/ADP/Fusion/SynVar/Array/Set.hs b/ADP/Fusion/SynVar/Array/Set.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Array/Set.hs +++ /dev/null @@ -1,164 +0,0 @@ - -module ADP.Fusion.SynVar.Array.Set where - -import Data.Bits -import Data.Bits.Extras -import Data.Bits.Ordered -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic -import Data.Vector.Fusion.Stream.Size -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Prelude hiding (map) -import Control.Applicative ((<$>)) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Backtrack - - - --- * Bitsets without any interfaces. - --- NOTE that we have to give as the filled index elements all bits that are --- set in total, not just those we set right here. Otherwise the next --- element will try a wrong set of indices. --- --- NOTE even in the @IStatic@ case, we need to use flatten. If a node --- requested a reserved bit, we need to free each reserved bit at least --- once. - -instance - ( Monad m - , Element ls BitSet - , PrimArrayOps arr BitSet x - , MkStream m ls BitSet - ) => MkStream m (ls :!: ITbl m arr BitSet x) BitSet where - mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u s - = flatten mk step Unknown $ mkStream ls (delay_inline IVariable $ rp - csize) u s - where !csize | c==EmptyOk = 0 - | c==NonEmpty = 1 - mk z - | cm < csize = return (z , mask , Nothing) - | otherwise = return (z , mask , Just k ) - where k = (BitSet $ 2^cm-1) - cm = popCount mask - rp - mask = s `xor` (getIdx z) - step (_,_,Nothing) = return $ Done - step (z,mask,Just k) - | pk > popCount s - rp = return $ Done - | otherwise = let kk = popShiftL mask k - in return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,setSucc (BitSet 0) (2^pk -1) k) - where pk = popCount k - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - mkStream (ls :!: ITbl _ _ c t _) (IVariable rp) u s - = flatten mk step Unknown $ mkStream ls (IVariable rp) u s - where mk z - | c==EmptyOk = return (z , mask , cm , Just 0 ) - | cm == 0 = return (z , mask , cm , Nothing) -- we are non-empty but have no free bits left - | c==NonEmpty = return (z , mask , cm , Just 1 ) - where mask = s `xor` (getIdx z) -- bits that are still free - cm = popCount mask - step (z,mask,cm,Nothing) = return $ Done - step (z,mask,cm,Just k ) - | popCount s < popCount (kk .|. getIdx z) + rp = return $ Done - | otherwise = return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,cm,setSucc (BitSet 0) (2^cm -1) k) - where kk = popShiftL mask k - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - - - --- * Bitsets with two interfaces. --- --- NOTE These are annoying to get right, if you also want to have good --- performance. - -instance - ( Monad m - , Element ls (BS2I First Last) - , PrimArrayOps arr (BS2I First Last) x - , MkStream m ls (BS2I First Last) - , Show x - ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where - mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u sij@(s:>i:>j@(Iter jj)) - = flatten mk step Unknown $ mkStream ls (delay_inline IVariable rpn) u (delay_inline id $ tij) - -- calculate new index. if we don't know the right-most interface - -- anymore, than someone has taken it already. Also, if this - -- synvar may be empty, do not modify the index. Otherwise, if - -- @j@ is still known, remove it from the index set. - where tij | jj == -1 = sij - | c == EmptyOk = sij - | c == NonEmpty = s `clearBit` jj :> i :> Iter (-1) - -- In case we do not know the rightmost interface, we instead - -- increase the number of reserved bits. - rpn | jj == -1 - && c == NonEmpty = rp+1 - | otherwise = rp - nec | c == NonEmpty = 1 - | c == EmptyOk = 0 - mk z - -- in case we have a non-empty synvar but not enough bits, we - -- shall have nothing. We only need one extra mask bit, because - -- @j@ is still known. - | popCount mask < 1 && c == NonEmpty && j >= 0 = return $ Naught - -- If @j@ is not known we need two bits to be non-empty. - | popCount mask < 2 && c == NonEmpty && j < 0 = return $ Naught - -- Not enough bits to reserve. - | popCount mask - rp < 0 = return $ Naught - -- @j@ is still known, just create the sets ending in @j@ - | j >= 0 = return $ This (z,mask) - -- @j@ is not known, we have a lot of work to do. Create the - -- required @bits@ and prepare a @mask@ which will set the - -- correct bits. - | j < 0 = return $ That (z,mask,Just bits,maybeLsb bits) - -- we somehow ended up with an improper state - | otherwise = error $ show (sij,mask,bits) - where (zs:>_:>Iter zk) = getIdx z - mask = s `xor` zs - bits = BitSet $ 2 ^ (popCount mask - rp - nec) - 1 - step Naught = return $ Done - -- In case @j@ is known, we calculate the bits @msk@ that are not - -- filled yet. We grab the previous right interface @zk@ and use - -- it as the new left interface. We also use @j@ as the right - -- interface. @ix@ holds everything that is now covered, withe - -- the interface @i@ and @j@. - step (This (z,mask)) = return $ Yield (ElmITbl (t!(msk:>k:>j)) ix undefbs2i z) Naught - where (zs:>_:>zk) = getIdx z - k = Iter $ getIter zk - ix = (zs .|. msk) :> i :> j - msk = if popCount mask == 0 then mask else mask `setBit` getIter k `setBit` jj - -- whenever there is nothing more to do in the variable case. - step (That (z,mask,Nothing,_)) = return $ Done - -- We need to permute our population a bit. Once done, we grab - -- the lowest significant bit. - step (That (z,mask,Just bits,Nothing)) = return $ Skip (That (z,mask,nbts, maybeLsb =<< nbts)) - where nbts = popPermutation (popCount mask) bits - -- The variable case. - step (That (z,mask,Just bits,Just y)) - -- we do not have enough bits to be non-empty. - | popCount bb < 2 && c == NonEmpty - -- our two interfaces are the same, but we are non-empty in - -- which case this shouldn't happen. - || getIter kk == getIter yy && c == NonEmpty - -- our pop-count plus reserved count doesn't match up with the - -- mask. We skip this as well. - || popCount bb + rp /= popCount mask = return $ Skip (That (z,mask,Just bits, maybeNextActive y bits)) - -- finally, we can create the index for the current stuff - -- @bb:>kk:>yy@ and prepare the full index, going from @i@ to - -- @yy@, because someone grabbed @j@ already. Must have been - -- an @Edge@ or s.th. similar. - | otherwise = return $ Yield (ElmITbl (t!(bb:>kk:>yy)) ((zs .|. bb):>i:>yy) undefbs2i z) - (That (z,mask,Just bits, maybeNextActive y bits)) - where (zs:>_:>zk) = getIdx z - kk = Iter $ getIter zk - yy = Iter . lsb $ popShiftL mask (bit y) - bb = popShiftL mask bits `setBit` getIter kk `setBit` getIter yy - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - diff --git a/ADP/Fusion/SynVar/Array/Subword.hs b/ADP/Fusion/SynVar/Array/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Array/Subword.hs +++ /dev/null @@ -1,318 +0,0 @@ - -{-# Language MagicHash #-} - -module ADP.Fusion.SynVar.Array.Subword where - -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Size -import Data.Vector.Fusion.Util (delay_inline) -import Data.Vector.Fusion.Stream.Monadic -import Debug.Trace -import Prelude hiding (map,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Backtrack - --- TODO think about what we are about to do -import GHC.Prim (reallyUnsafePtrEquality#) - - - - --- TODO delay inline @(subword i $ j - minSize c)@ or face fusion-breakage. --- Can we just have @Inline [0] subword@ to fix this? - -instance - ( Monad m - , Element ls Subword - , PrimArrayOps arr Subword x - , MkStream m ls Subword - ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where - mkStream (ls :!: ITbl _ _ c t _) (IStatic ()) hh (Subword (i:.j)) - = map (\s -> let (Subword (_:.l)) = getIdx s - in ElmITbl (t ! subword l j) (subword l j) (subword 0 0) s) - $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c)) - mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j)) - = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c)) - where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c) - step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s - l = j - z - kl = subword k l - return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - -instance - ( Monad mB - , Element ls Subword - , MkStream mB ls Subword - , PrimArrayOps arr Subword x - ) => MkStream mB (ls :!: Backtrack (ITbl mF arr Subword x) mF mB r) Subword where - mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh ij@(Subword (i:.j)) - = mapM (\s -> let Subword (_:.l) = getIdx s - lj = subword l j - in bt hh lj >>= \ ~bb -> return $ ElmBtITbl (t ! lj) (bb {-bt hh lj-}) lj (subword 0 0) s) - $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c)) - mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh ij@(Subword (i:.j)) - = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c)) - where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c) - step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s - l = j - z - kl = subword k l - bt hh kl >>= \ ~bb -> return $ Yield (ElmBtITbl (t ! kl) (bb {-bt hh kl-}) kl (subword 0 0) s) (s:.z-1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - - -instance - ( Monad m - , Element ls (Outside Subword) - , PrimArrayOps arr (Outside Subword) x - , MkStream m ls (Outside Subword) - ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where - -- TODO what about @c / minSize@ - mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j))) - = map (\s -> let O (Subword (k:._)) = getOmx s - kj = O $ Subword (k:.j+dj) - in ElmITbl (t ! kj) (O $ Subword (i:.j+dj)) kj s) -- @ij@ or s.th. else shouldn't matter? - $ mkStream ls (OFirstLeft (di:.dj)) u ij - mkStream (ls :!: ITbl _ _ c t _) (ORightOf (di:.dj)) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j))) - = flatten mk step Unknown $ mkStream ls (OFirstLeft (di:.dj)) u ij - where mk s = return (s:.j+dj) - step (s:.l) | l <= h = do let (O (Subword (k:._))) = getIdx s - kl = O $ Subword (k:.l) - return $ Yield (ElmITbl (t ! kl) (O (Subword (j+dj:.j+dj))) kl s) (s:.l+1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft d) u ij = error "Array/Outside Subword : OFirstLeft : should never be reached!" - mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij = error "Array/Outside Subword : OLeftOf : should never be reached!" - {-# Inline mkStream #-} - - - -instance - ( Monad m - , Element ls (Outside Subword) - , PrimArrayOps arr Subword x - , MkStream m ls (Outside Subword) - ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where - -- TODO what about @c / minSize@ - mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j))) - = map (\s -> let O (Subword (_:.k)) = getIdx s - o@(O (Subword (_:.l))) = getOmx s - kl = Subword (k-dj:.l-dj) - in ElmITbl (t ! kl) (O (Subword (k:.l))) o s) - $ mkStream ls (ORightOf (di:.dj)) u ij - mkStream (ls :!: ITbl _ _ c t _) (ORightOf d) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j))) - = flatten mk step Unknown $ mkStream ls (ORightOf d) u ij - where mk s = let O (Subword (_:.l)) = getIdx s - in return (s :.l:.l + minSize c) - step (s:.k:.l) - | let O (Subword (_:.o)) = getOmx s - , l <= o = do let kl = Subword (k:.l) - return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.k:.l+1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft (di:.dj)) u ij@(O (Subword (i:.j))) - = map (\s -> let O (Subword (l:._)) = getOmx s - O (Subword (_:.k)) = getIdx s - kl = Subword (k:.i-di) - in ElmITbl (t ! kl) (O kl) (getOmx s) s) - $ mkStream ls (OLeftOf (di:.dj)) u ij - mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij@(O (Subword (i:.j))) - = flatten mk step Unknown $ mkStream ls (OLeftOf d) u ij - where mk s = let O (Subword (_:.l)) = getIdx s in return (s:.l) - step (s:.l) | l <= i = do let O (Subword (_:.k)) = getIdx s - kl = Subword (k:.l) - return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.l+1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - -instance - ( Monad m - , Element ls (Complement Subword) - , PrimArrayOps arr Subword x - , MkStream m ls (Complement Subword) - ) => MkStream m (ls :!: ITbl m arr Subword x) (Complement Subword) where - mkStream (ls :!: ITbl _ _ c t _) Complemented u ij - = map (\s -> let (C ix) = getIdx s - in ElmITbl (t ! ix) (C ix) (getOmx s) s) - $ mkStream ls Complemented u ij - {-# Inline mkStream #-} - -instance - ( Monad m - , Element ls (Complement Subword) - , PrimArrayOps arr (Outside Subword) x - , MkStream m ls (Complement Subword) - ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Complement Subword) where - mkStream (ls :!: ITbl _ _ c t _) Complemented u ij - = map (\s -> let (C ox) = getOmx s -- TODO shouldn't this be @getIdx@ as well? on the count of everything being terminals in Complement? - in ElmITbl (t ! (O ox)) (getIdx s) (C ox) s) - $ mkStream ls Complemented u ij - {-# Inline mkStream #-} - - - -instance ModifyConstraint (ITbl m arr Subword x) where - toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f - toEmpty (ITbl b l _ arr f) = ITbl b l EmptyOk arr f - {-# Inline toNonEmpty #-} - {-# Inline toEmpty #-} - -instance ModifyConstraint (Backtrack (ITbl mF arr Subword x) mF mB r) where - toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt - toEmpty (BtITbl _ arr bt) = BtITbl EmptyOk arr bt - {-# Inline toNonEmpty #-} - {-# Inline toEmpty #-} - - - -instance - ( Monad m - , Element ls Subword -- (Z:.Subword:.Subword) - , FirstSecond ls (arr (Z:.Subword:.Subword) x) - , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword - , PrimArrayOps arr (Z:.Subword:.Subword) x - , MkStream m ls Subword - , Show x - ) => MkStream m (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword where - mkStream (ls :!: ITbl _ _ c t elm) (IStatic ()) hh (Subword (i:.j)) - = map (\s -> let (Subword (_:.l)) = getIdx s - ab = if greenLight ls t - then greenIdx ls (undefined :: Subword) t s - else subword 0 0 - in -- traceShow ("13",ab,subword l j,t!(Z:.ab:.subword l j)) $ - ElmITbl (t ! (Z:.ab:.subword l j)) (subword l j) (subword 0 0) s) - $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0)) - mkStream (ls :!: ITbl _ _ c t elm) (IVariable ()) hh (Subword (i:.j)) - = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0)) - where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0) - step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s - l = j - z - kl = subword k l - ab = if greenLight ls t - then greenIdx ls (undefined :: Subword) t s - else subword 0 0 - --traceShow ("02",ab,subword k l,t!(Z:.ab:.subword k l)) $ - return $ Yield (ElmITbl (t ! (Z:.ab:.kl)) kl (subword 0 0) s) (s:.z-1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - -instance - ( Monad mB - , FirstSecond ls (arr (Z:.Subword:.Subword) x) - , FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword - , PrimArrayOps arr (Z:.Subword:.Subword) x - , Element ls Subword - , MkStream mB ls Subword - , Show r - ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword where - mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh (Subword (i:.j)) - = mapM (\s -> let (Subword (_:.l)) = getIdx s - lj = subword l j - light = greenLight ls t - ab = if light - then greenIdx ls (undefined :: Subword) t s - else lj -- subword 0 0 - ablj = if light - then Z:.ab:.lj - else Z:.subword 0 0:.subword 0 0 -- Z:.lj:.lj - in bt (Prelude.snd $ bounds t) ablj >>= \ ~bb -> {- traceShow (ab,lj,bb) $ -} return $ ElmBtITbl (t ! ablj) bb lj (subword 0 0) s) - $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0)) - mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh (Subword (i:.j)) - = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - 0)) - where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - 0) - step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s - l = j - z - kl = subword k l - light = greenLight ls t - ab = if light - then greenIdx ls (undefined :: Subword) t s - else kl -- subword 0 0 - abkl = if light - then Z:.ab:.kl - else Z:.subword 0 0:.subword 0 0 -- Z:.kl:.kl - bt (Prelude.snd $ bounds t) abkl >>= \ ~bb -> {- traceShow (ab,kl,bb) $ -} return $ Yield (ElmBtITbl (t!abkl) bb kl (subword 0 0) s) (s:.z-1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - --- | Get the previous index; this should really be made generic! --- --- TODO This is probably a REALLY STUPID IDEA ;-) - -class FirstSecond x k where - greenLight :: x -> k -> Bool - -class FirstSecondIdx x k i where - greenIdx :: x -> i -> k -> Elm x i -> Subword - -instance FirstSecond S k where - greenLight S _ = False - {-# Inline greenLight #-} - - - -instance - ( FirstSecond ls (arr (Z:.Subword:.Subword) x) - ) => FirstSecond (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) where - greenLight (ls :!: ITbl _ _ _ t _) t' = - case reallyUnsafePtrEquality# t t' of - -- TODO speaking of stupid ideas! - 1# -> True - _ -> greenLight ls t' - {-# Inline greenLight #-} - -instance - ( FirstSecond ls (arr (Z:.Subword:.Subword) x) - ) => FirstSecond (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) where - greenLight (ls :!: BtITbl _ t _) t' = - case reallyUnsafePtrEquality# t t' of - -- TODO speaking of stupid ideas! - 1# -> True - _ -> greenLight ls t' - {-# Inline greenLight #-} - - - -instance FirstSecondIdx S k i where - greenIdx S _ _ _ = error "shouldn't arrive here!" - {-# Inline greenIdx #-} - -instance - ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword - , Elm ls Subword ~ RecElm (ls :!: ITbl m arr (Z:.Subword:.Subword) x) Subword - , Element ls Subword - ) => FirstSecondIdx (ls :!: ITbl m arr (Z:.Subword:.Subword) x) (arr (Z:.Subword:.Subword) x) Subword where - greenIdx (ls :!: ITbl _ _ _ t _) _ t' e = - case reallyUnsafePtrEquality# t t' of - 1# -> let ab = getIdx e in ab - _ -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g - {-# Inline greenIdx #-} - -instance - ( FirstSecondIdx ls (arr (Z:.Subword:.Subword) x) Subword - , Elm ls Subword ~ RecElm (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) Subword - , Element ls Subword - ) => FirstSecondIdx (ls :!: Backtrack (ITbl mF arr (Z:.Subword:.Subword) x) mF mB r) (arr (Z:.Subword:.Subword) x) Subword where - greenIdx (ls :!: BtITbl _ t _) _ t' e = - case reallyUnsafePtrEquality# t t' of - 1# -> let ab = getIdx e in ab - _ -> let g = getElm e in greenIdx ls (undefined :: Subword) t' g - {-# Inline greenIdx #-} - diff --git a/ADP/Fusion/SynVar/Array/TermSymbol.hs b/ADP/Fusion/SynVar/Array/TermSymbol.hs --- a/ADP/Fusion/SynVar/Array/TermSymbol.hs +++ b/ADP/Fusion/SynVar/Array/TermSymbol.hs @@ -1,12 +1,16 @@ -- | TODO migrate instances to correct modules +-- +-- TODO need to find out if we can reduce the total number of instances +-- required here. Probably not trivial since there are, in principle, @n*m@ +-- instances that we need to handle. module ADP.Fusion.SynVar.Array.TermSymbol where +import Data.Proxy import Data.Strict.Tuple hiding (snd) -import Data.Vector.Fusion.Stream.Size import Data.Vector.Fusion.Util (delay_inline) -import Data.Vector.Fusion.Stream.Monadic +import Data.Vector.Fusion.Stream.Monadic hiding (flatten) import Debug.Trace import Prelude hiding (map,mapM) @@ -18,57 +22,115 @@ --- | 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 ! diff --git a/ADP/Fusion/SynVar/Array/Type.hs b/ADP/Fusion/SynVar/Array/Type.hs --- a/ADP/Fusion/SynVar/Array/Type.hs +++ b/ADP/Fusion/SynVar/Array/Type.hs @@ -1,10 +1,14 @@ +{-# Language DataKinds #-} +{-# Language TypeOperators #-} + module ADP.Fusion.SynVar.Array.Type where import Data.Strict.Tuple hiding (uncurry,snd) -import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM) +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) import Debug.Trace import Prelude hiding (map,head,mapM) +import Data.Proxy import Data.PrimitiveArray hiding (map) @@ -27,7 +31,7 @@ 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 #-} +-} + diff --git a/ADP/Fusion/SynVar/Fill.hs b/ADP/Fusion/SynVar/Fill.hs --- a/ADP/Fusion/SynVar/Fill.hs +++ b/ADP/Fusion/SynVar/Fill.hs @@ -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 diff --git a/ADP/Fusion/SynVar/Indices.hs b/ADP/Fusion/SynVar/Indices.hs --- a/ADP/Fusion/SynVar/Indices.hs +++ b/ADP/Fusion/SynVar/Indices.hs @@ -3,8 +3,22 @@ -- need 'tableIndices' in multi-dimensional tables as the type of the -- multi-dimensional indices is generic. -module ADP.Fusion.SynVar.Indices where +module ADP.Fusion.SynVar.Indices + ( module ADP.Fusion.SynVar.Indices.Classes + , module ADP.Fusion.SynVar.Indices.Point + , module ADP.Fusion.SynVar.Indices.Set0 + , module ADP.Fusion.SynVar.Indices.Subword + , module ADP.Fusion.SynVar.Indices.Unit + ) where +import ADP.Fusion.SynVar.Indices.Classes +import ADP.Fusion.SynVar.Indices.Point +import ADP.Fusion.SynVar.Indices.Set0 +import ADP.Fusion.SynVar.Indices.Subword +import ADP.Fusion.SynVar.Indices.Unit + + +{- import Data.Vector.Fusion.Stream.Size (Size(Unknown)) import Data.Vector.Fusion.Stream.Monadic (flatten,map,Stream, Step(..)) import Prelude hiding (map) @@ -15,6 +29,8 @@ + + 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 #-} +-} + + + -} diff --git a/ADP/Fusion/SynVar/Indices/Classes.hs b/ADP/Fusion/SynVar/Indices/Classes.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/SynVar/Indices/Classes.hs @@ -0,0 +1,76 @@ + +-- | Classes that enumerate the index structure necessary for actually +-- performing the indexing. +-- +-- TODO Currently, we only provide dense index generation. + +module ADP.Fusion.SynVar.Indices.Classes where + +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..)) +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base + + + +-- | This type classes enable enumeration both in single- and multi-dim +-- cases. The type @a@ is the type of the /full stack/ of indices, i.e. the +-- full multi-tape problem. + +class AddIndexDense a u i where + addIndexDenseGo + :: (Monad m) + => TblConstraint u -> Context i -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i) + +instance AddIndexDense a Z Z where + addIndexDenseGo _ _ _ _ = id + {-# Inline addIndexDenseGo #-} + +-- | @SvState@ holds the state that is currently being built up by +-- @AddIndexDense@. We have both @tIx@ (and @tOx@) and @iIx@ (and @iOx@). +-- For most index structures, the indices will co-incide; however for some, +-- this will not be true -- herein for @Set@ index structures. + +data SvState s a u i = SvS + { sS :: !s -- | state coming in from the left + , sIx :: !a -- | @I/C@ index from @sS@ + , sOx :: !a -- | @O@ index from @sS@ + , tx :: !u -- | @I/C@ building up state to index the @table@. + , iIx :: !i -- | @I/C@ building up state to hand over to next symbol + , iOx :: !i -- | @O@ building up state to hand over to next symbol + } + + +-- | Given an incoming stream with indices, this adds indices for the +-- current syntactic variable / symbol. + +addIndexDense + :: ( Monad m + , AddIndexDense a u i + , GetIndex a i + , s ~ Elm x0 a + , Element x0 a + ) + => TblConstraint u -> Context i -> i -> i -> Stream m s -> Stream m (s,u,i,i) +addIndexDense t c u i = map (\(SvS s _ _ z i' o') -> (s,z,i',o')) . addIndexDenseGo t c u i . map (\s -> (SvS s (getIdx s) (getOmx s) Z Z Z)) +{-# Inline addIndexDense #-} + +-- | In case of 1-dim tables, we wrap the index creation in a multi-dim +-- system and remove the @Z@ later on. This allows us to have to write only +-- a single instance. + +addIndexDense1 + :: ( Monad m + , AddIndexDense (Z:.a) (Z:.u) (Z:.i) + , GetIndex (Z:.a) (Z:.i) + , s ~ Elm x0 a + , Element x0 a + ) + => TblConstraint u -> Context i -> i -> i -> Stream m s -> Stream m (s,u,i,i) +addIndexDense1 t c u i = map (\(SvS s _ _ (Z:.z) (Z:.i') (Z:.o')) -> (s,z,i',o')) + . addIndexDenseGo (Z:.t) (Z:.c) (Z:.u) (Z:.i) + . map (\s -> (SvS s (Z:.getIdx s) (Z:.getOmx s) Z Z Z)) +{-# Inline addIndexDense1 #-} + diff --git a/ADP/Fusion/SynVar/Indices/Point.hs b/ADP/Fusion/SynVar/Indices/Point.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/SynVar/Indices/Point.hs @@ -0,0 +1,73 @@ + +module ADP.Fusion.SynVar.Indices.Point where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) +import Data.Vector.Fusion.Util (delay_inline) +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base +import ADP.Fusion.SynVar.Indices.Classes + + + +instance + ( AddIndexDense a us is + , GetIndex a (is:.PointL I) + , GetIx a (is:.PointL I) ~ (PointL I) + ) => AddIndexDense a (us:.PointL I) (is:.PointL I) where + addIndexDenseGo (cs:._) (vs:.IStatic d) (us:.u) (is:.i) + = map (\(SvS s a b t y' z') -> SvS s a b (t:.i) (y':.i) (z':.PointL 0)) + . addIndexDenseGo cs vs us is + addIndexDenseGo (cs:.c) (vs:.IVariable d) (us:.u) (is:.PointL i) + = flatten mk step . addIndexDenseGo cs vs us is + where mk svS = let PointL k = getIndex (sIx svS) (Proxy :: Proxy (is:.PointL I)) + in return $ svS :. k + step (svS@(SvS s a b t y' z') :. k) + | k + csize > i = return $ Done + | otherwise = return $ Yield (SvS s a b (t:.PointL k) (y':.PointL k) (z':.PointL 0)) (svS :. k+1) + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + csize = delay_inline minSize c + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDense a us is + , GetIndex a (is:.PointL O) + , GetIx a (is:.PointL O) ~ (PointL O) + ) => AddIndexDense a (us:.PointL O) (is:.PointL O) where + addIndexDenseGo (cs:.c) (vs:.OStatic d) (us:.u) (is:.i) + = map (\(SvS s a b t y' z') -> let o = getIndex b (Proxy :: Proxy (is:.PointL O)) + in SvS s a b (t:.o) (y':.o) (z':.o)) + . addIndexDenseGo cs vs us is + where csize = delay_inline minSize c + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDense a us is + , GetIndex a (is:.PointL C) + , GetIx a (is:.PointL C) ~ (PointL C) + ) => AddIndexDense a (us:.PointL I) (is:.PointL C) where + addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i) + = map (\(SvS s a b t y z) -> let PointL k = getIndex a (Proxy :: Proxy (is:.PointL C)) + kT = PointL k + kC = PointL k + in SvS s a b (t:.kT) (y:.kC) (z:.kC)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDense a us is + , GetIndex a (is:.PointL C) + , GetIx a (is:.PointL C) ~ (PointL C) + ) => AddIndexDense a (us:.PointL O) (is:.PointL C) where + addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i) + = map (\(SvS s a b t y z) -> let PointL k = getIndex a (Proxy :: Proxy (is:.PointL C)) + kT = PointL k + kC = PointL k + in SvS s a b (t:.kT) (y:.kC) (z:.kC)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + diff --git a/ADP/Fusion/SynVar/Indices/Set0.hs b/ADP/Fusion/SynVar/Indices/Set0.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/SynVar/Indices/Set0.hs @@ -0,0 +1,160 @@ + +-- | @Set0@ provides index movement for sets with no interfaces. +-- +-- TODO Sets with 1 and 2 interfaces will go into @Set1@ and @Set2@ +-- modules. + +module ADP.Fusion.SynVar.Indices.Set0 where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) +import Data.Vector.Fusion.Util (delay_inline) +import Debug.Trace +import Prelude hiding (map,head,mapM) +import Data.Bits.Extras +import Data.Bits + +import Data.PrimitiveArray hiding (map) +import Data.Bits.Ordered + +import ADP.Fusion.Base +import ADP.Fusion.SynVar.Indices.Classes + + + +-- * Bitsets without any boundaries +-- +-- TODO outside and complement code + +instance + ( AddIndexDense a us is + , GetIndex a (is:.BitSet I) + , GetIx a (is:.BitSet I) ~ (BitSet I) + ) => AddIndexDense a (us:.BitSet I) (is:.BitSet I) where + addIndexDenseGo (cs:.c) (vs:.IStatic rb) (us:.u) (is:.i) + = flatten mk step . addIndexDenseGo cs vs us is + -- @mk@ builds up the index we start with. First we ask in @l@ + -- for the index from the previous symbol. Then we calculate the + -- @mask@, the bits we can still set. This is @i@ minus the @l@ + -- bits. Then we calculate the population count. For this we ask + -- for the @popCount mask@ and lower it by the constraint @rb@ + -- (why?). Finally, we set exactly popCount bits in @k@. These + -- @k@ bits are *not* the bits from the @mask@ but rather the + -- lowest bits. + -- @rb@ should be set by more-right symbols in case they need to + -- reserve some bits but otherwise are static. + where mk svS + | cm < csize = return $ Nothing + | otherwise = {- traceShow ("I0",l,mask,k) . -} return $ Just (svS :. mask :. k) + where k = (BitSet $ 2^cm-1) + cm = popCount mask - rb + mask = i `xor` l + l = getIndex (sIx svS) (Proxy :: Proxy (is:.BitSet I)) + step Nothing = return $ Done + -- @step Just ...@ performs a non-trivial step. First we + -- calculate the population count of the index for this symbol as + -- @pk@. This will terminate once the popcount is higher than the + -- index @i@ minus the reserved count @rb@. + -- In case we don't terminate, we calculate the actual index @kk@ + -- by shifting the key @k@ around with our @mask@. The local + -- index is given by @kk@, while the set of all active bits is + -- @kk .|. aa@. + -- + -- TODO is the stopping criterion actually right? Should'nd we + -- look at all set bits? Also consider the comment above on @rb@. + step (Just (svS@(SvS s a b t y' z') :. mask :. k)) + | pk > popCount i - rb = return $ Done + | otherwise = let kk = popShiftL mask k + aa = getIndex a (Proxy :: Proxy (is:.BitSet I)) + in return $ Yield (SvS s a b (t:.kk) (y':.(kk.|.aa)) (z':.0)) + ((svS :. mask :.) <$> setSucc 0 (2^pm -1) k) + where pk = popCount k + pm = popCount mask + csize = delay_inline minSize c -- minimal set size via constraints + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + addIndexDenseGo (cs:.c) (vs:.IVariable rb) (us:.u) (is:.i) + = flatten mk step . addIndexDenseGo cs vs us is + -- @mk@ builds up the initially set population. In case of + -- @EmptyOk@ no bits are set. Otherwise we check first if we have + -- bits left. If @cm==0@ then we immediately quit. If not, we + -- activate one bit. + where mk svS + | c==EmptyOk = return $ Just (svS :. mask :. cm :. 0) + | cm == 0 = return $ Nothing + | c==NonEmpty = return $ Just (svS :. mask :. cm :. 1) + where mask = i `xor` l + cm = popCount mask + l = getIndex (sIx svS) (Proxy :: Proxy (is:.BitSet I)) + step Nothing = return $ Done + -- if the possible popcount in @i@ is less than the total + -- popcount in @kk@ and @l@ and the reserved bits in @rb@, then + -- we continue. This means returning @kk@ as the bitset for + -- indexing; @kk.|.l@ as all set bits. @setSucc@ will rotate + -- through all permutations for each popcount and mask. + step (Just (svS@(SvS s a b t y' z') :. mask :. cm :. k)) + | popCount i < popCount (kk .|. l) + rb = return $ Done + | otherwise = return $ Yield (SvS s a b (t:.kk) (y':.(kk.|.l)) (z':.0)) + ((svS :. mask :. cm :.) <$> setSucc 0 (2^cm -1) k) + where kk = popShiftL mask k + l = getIndex a (Proxy :: Proxy (is:.BitSet I)) + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + {-# Inline addIndexDenseGo #-} + +-- | Outside / Outside synvar indices are either @OStatic@ or @ORightOf@. +-- Of course, the single outside synvar is not to the right of itself, but +-- it is the final @RightOf@ object before we have the @FirstLeft@ object. + +instance + ( AddIndexDense a us is + , GetIndex a (is:.BitSet O) + , GetIx a (is:.BitSet O) ~ (BitSet O) + ) => AddIndexDense a (us:.BitSet O) (is:.BitSet O) where + addIndexDenseGo (cs:.c) (vs:.OStatic rb) (us:.u) (is:.i) + = flatten mk step . addIndexDenseGo cs vs us is + -- We need to make the number of @0@s smaller, or make the number + -- of @1@s larger. By an amount given by @rb@. + where mk svS + -- not enough free bits with reserved count + | rb + popCount b >= popCount u = return $ Nothing + | otherwise = return $ Just (svS :. mask :. k) + where a = getIndex (sIx svS) (Proxy :: Proxy (is:.BitSet O)) + b = getIndex (sOx svS) (Proxy :: Proxy (is:.BitSet O)) + mask = u `xor` b -- all bits available for permutations (upper bound, without already set bits) + k = BitSet $ 2 ^ rb - 1 -- the bits we want to trigger + step Nothing = return $ Done + -- | @step@ can now provide the outside index with @+rb@ more + -- bits, while the inside index wont have those. The idea is that + -- @outside@ provides the mask we can now plug additional + -- @inside@ objects in -- but only in those plug-ports where @i@ + -- is zero. + step (Just (svS@(SvS s a b t y' z') :. mask :. k)) + -- drawing the next bitset ends up over the limit + | pk > rb = return $ Done + | otherwise = + let aa = getIndex a (Proxy :: Proxy (is:.BitSet O)) -- this is our inside-type index, it will not be modified here + bb = getIndex b (Proxy :: Proxy (is:.BitSet O)) + kk = popShiftL mask k + tt = kk .|. bb -- the (smaller, more @1@ bits) lookup index + in return $ Yield (SvS s a b (t:.tt) (y':.aa) (z':.tt)) + ((svS :. mask :.) <$> setSucc 0 (2^rb -1) k) + where pk = popCount k + csize = delay_inline minSize c + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + addIndexDenseGo (cs:.c) (vs:.ORightOf rb) (us:.u) (is:.i) + = undefined + {-# Inline addIndexDenseGo #-} + +-- | + +instance + ( AddIndexDense a us is + , GetIndex a (is:.BitSet O) + , GetIx a (is:.BitSet O) ~ (BitSet O) + ) => AddIndexDense a (us:.BitSet I) (is:.BitSet O) where +-- addIndexDenseGo (cs:.c) (vs:.OFirstLeft rb) (us:.u) (is:.i) +-- = error "ping" + {-# Inline addIndexDenseGo #-} + diff --git a/ADP/Fusion/SynVar/Indices/Subword.hs b/ADP/Fusion/SynVar/Indices/Subword.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/SynVar/Indices/Subword.hs @@ -0,0 +1,220 @@ + +-- | Instance code for @Inside@, @Outside@, and @Complement@ indices. +-- +-- TODO actual @Outside@ and @Complement@ code ... +-- +-- TODO we have quite a lot of @subword i j@ code where only the @type@ +-- is different; check if @coerce@ yields improved performance or if the +-- compiler optimizes this out! + +module ADP.Fusion.SynVar.Indices.Subword where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),filter) +import Data.Vector.Fusion.Util (delay_inline) +import Prelude hiding (map,head,mapM,filter) +import Debug.Trace + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base +import ADP.Fusion.SynVar.Indices.Classes + + + +-- | +-- @ +-- Table: Inside +-- Grammar: Inside +-- +-- The minSize condition for @IStatic@ is guaranteed via the use of +-- @tableStreamIndex@ (not here, in individual synvars), where @j@ is set +-- to @j-1@ for the next-left symbol! +-- @ + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Subword I) + , GetIx a (is:.Subword I) ~ (Subword I) + ) => AddIndexDense a (us:.Subword I) (is:.Subword I) where + addIndexDenseGo (cs:._) (vs:.IStatic ()) (us:.Subword (_:.u)) (is:.Subword (i:.j)) + = staticCheck (j<=u) + . map (\(SvS s a b t y' z') -> let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I)) + lj = subword l j + oo = subword 0 0 + in SvS s a b (t:.lj) (y':.lj) (z':.oo)) + . addIndexDenseGo cs vs us is + addIndexDenseGo (cs:.c) (vs:.IVariable ()) (us:.Subword (_:.u)) (is:.Subword (i:.j)) + = staticCheck (j<=u) + . flatten mk step . addIndexDenseGo cs vs us is + where mk svS = let (Subword (_:.l)) = getIndex (sIx svS) (Proxy :: Proxy (is:.Subword I)) + in return $ svS :. (j - l - csize) + step (svS@(SvS s a b t y' z') :. zz) + | zz >= 0 = do let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword I)) + l = j - zz ; kl = subword k l + oo = subword 0 0 + return $ Yield (SvS s a b (t:.kl) (y':.kl) (z':.oo)) (svS :. zz-1) + | otherwise = return $ Done + csize = delay_inline minSize c + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + {-# Inline addIndexDenseGo #-} + +-- | +-- @ +-- Table: Outside +-- Grammar: Outside +-- @ +-- +-- TODO Take care of @c@ in all cases to correctly handle @NonEmpty@ tables +-- and the like. + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Subword O) + , GetIx a (is:.Subword O) ~ (Subword O) + ) => AddIndexDense a (us:.Subword O) (is:.Subword O) where + addIndexDenseGo (cs:.c) (vs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j)) + = map (\(SvS s a b t y' z') -> let Subword (k:._) = getIndex b (Proxy :: Proxy (is:.Subword O)) + kj = subword k (j+dj) + ij' = subword i j -- (j+dj) + oo = subword 0 0 + in SvS s a b (t:.kj) (y':.ij') (z':.kj)) + . addIndexDenseGo cs vs us is + addIndexDenseGo (cs:.c) (vs:.ORightOf (di:.dj)) (us:.Subword (_:.h)) (is:.Subword (i:.j)) + = flatten mk step . addIndexDenseGo cs vs us is + where mk svS = return (svS :. j+dj) + step (svS@(SvS s a b t y' z') :. l) + | l <= h = let Subword (k:._) = getIndex a (Proxy :: Proxy (is:.Subword O)) + kl = subword k l + jj = subword (j+dj) (j+dj) + oo = subword 0 0 + in return $ Yield (SvS s a b (t:.kl) (y':.jj) (z':.kl)) (svS :. l+1) + | otherwise = return Done + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + addIndexDenseGo _ (_:.OFirstLeft _) _ _ = error "SynVar.Indices.Subword : OFirstLeft" + addIndexDenseGo _ (_:.OLeftOf _) _ _ = error "SynVar.Indices.Subword : LeftOf" + {-# Inline addIndexDenseGo #-} + +-- | +-- @ +-- Table: Inside +-- Grammar: Outside +-- @ +-- +-- TODO take care of @c@ + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Subword O) + , GetIx a (is:.Subword O) ~ (Subword O) + ) => AddIndexDense a (us:.Subword I) (is:.Subword O) where + addIndexDenseGo (cs:.c) (vs:.OStatic (di:.dj)) (us:.u) (is:.Subword (i:.j)) + = map (\(SvS s a b t y' z') -> let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O)) + ll@(Subword (_:.l)) = getIndex b (Proxy :: Proxy (is:.Subword O)) + klI = subword (k-dj) (l-dj) + klO = subword (k-dj) (l-dj) + oo = subword 0 0 + in SvS s a b (t:.klI) (y':.klO) (z':.ll)) + . addIndexDenseGo cs vs us is + addIndexDenseGo (cs:.c) (vs:.ORightOf d) (us:.u) (is:.Subword (i:.j)) + = flatten mk step . addIndexDenseGo cs vs us is + where mk svS = let Subword (_:.l) = getIndex (sIx svS) (Proxy :: Proxy (is:.Subword O)) + in return (svS :. l :. l + csize) + step (svS@(SvS s a b t y' z') :. k :. l) + | l <= o = return $ Yield (SvS s a b (t:.klI) (y':.klO) (z':.zo)) + (svS :. k :. l+1) + | otherwise = return $ Done + where zo@(Subword (_:.o)) = getIndex b (Proxy :: Proxy (is:.Subword O)) + klI = subword k l + klO = subword k l + oo = subword 0 0 + csize = minSize c + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + addIndexDenseGo (cs:.c) (vs:.OFirstLeft (di:.dj)) (us:.u) (is:.Subword (i:.j)) + = map (\(SvS s a b t y' z') -> let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O)) + ll@(Subword (l:._)) = getIndex b (Proxy :: Proxy (is:.Subword O)) + klI = subword k $ i - di + klO = subword k $ i - di + oo = subword 0 0 + in SvS s a b (t:.klI) (y':.klO) (z':.ll)) + . addIndexDenseGo cs vs us is + addIndexDenseGo (cs:.c) (vs:.OLeftOf d) (us:.u) (is:.Subword (i:.j)) + = flatten mk step . addIndexDenseGo cs vs us is + where mk svS = let Subword (_:.l) = getIndex (sIx svS) (Proxy :: Proxy (is:.Subword O)) + in return $ svS :. l + step (svS@(SvS s a b t y' z') :. l) + | l <= i = let Subword (_:.k) = getIndex a (Proxy :: Proxy (is:.Subword O)) + omx = getIndex b (Proxy :: Proxy (is:.Subword O)) + klI = subword k l + klO = subword k l + oo = subword 0 0 + in return $ Yield (SvS s a b (t:.klI) (y':.klO) (z':.omx)) + (svS :. l+1) + | otherwise = return $ Done + csize = minSize c + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + {-# Inline addIndexDenseGo #-} + + + + +-- TODO +-- @ +-- Table: Inside +-- Grammar: Complement +-- @ + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Subword C) + , GetIx a (is:.Subword C) ~ (Subword C) + ) => AddIndexDense a (us:.Subword I) (is:.Subword C) where + addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i) + = map (\(SvS s a b t y' z') -> let Subword kk = getIndex a (Proxy :: Proxy (is:.Subword C)) + kT = Subword kk -- @k@ Table + kC = Subword kk + in SvS s a b (t:.kT) (y':.kC) (z':.kC)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + +-- TODO +-- @ +-- Table: Outside +-- Grammar: Complement +-- @ + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Subword C) + , GetIx a (is:.Subword C) ~ (Subword C) + ) => AddIndexDense a (us:.Subword O) (is:.Subword C) where + addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i) + = map (\(SvS s a b t y' z') -> let Subword kk = getIndex a (Proxy :: Proxy (is:.Subword C)) + kT = Subword kk + kC = Subword kk + in SvS s a b (t:.kT) (y':.kC) (z':.kC)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + +-- | +-- @ +-- Table: Complement +-- Grammar: Complement +-- @ + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Subword C) + , GetIx a (is:.Subword C) ~ (Subword C) + ) => AddIndexDense a (us:.Subword C) (is:.Subword C) where + addIndexDenseGo (cs:.c) (vs:.Complemented) (us:.u) (is:.i) + = map (\(SvS s a b t y' z') -> let k = getIndex a (Proxy :: Proxy (is:.Subword C)) + oo = subword 0 0 + in SvS s a b (t:.k) (y':.k) (z':.oo)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + diff --git a/ADP/Fusion/SynVar/Indices/Unit.hs b/ADP/Fusion/SynVar/Indices/Unit.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/SynVar/Indices/Unit.hs @@ -0,0 +1,58 @@ + +-- | TODO if we have a table that has min-size @>0@ we need to immediately +-- terminate @addIndexDenseGo@ ! + +module ADP.Fusion.SynVar.Indices.Unit where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) +import Data.Vector.Fusion.Util (delay_inline) +import Prelude hiding (map,head,mapM) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base +import ADP.Fusion.SynVar.Indices.Classes + + + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Unit I) + , GetIx a (is:.Unit I) ~ (Unit I) + ) => AddIndexDense a (us:.Unit I) (is:.Unit I) where + addIndexDenseGo (cs:._) (vs:.IStatic ()) (us:._) (is:._) + = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Unit O) + , GetIx a (is:.Unit O) ~ (Unit O) + ) => AddIndexDense a (us:.Unit O) (is:.Unit O) where + addIndexDenseGo (cs:._) (vs:.OStatic ()) (us:._) (is:._) + = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Unit C) + , GetIx a (is:.Unit C) ~ (Unit C) + ) => AddIndexDense a (us:.Unit I) (is:.Unit C) where + addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._) + = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + +instance + ( AddIndexDense a us is + , GetIndex a (is:.Unit C) + , GetIx a (is:.Unit C) ~ (Unit C) + ) => AddIndexDense a (us:.Unit O) (is:.Unit C) where + addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._) + = map (\(SvS s a b t y' z') -> SvS s a b (t:.Unit) (y':.Unit) (z':.Unit)) + . addIndexDenseGo cs vs us is + {-# Inline addIndexDenseGo #-} + diff --git a/ADP/Fusion/SynVar/Recursive/Subword.hs b/ADP/Fusion/SynVar/Recursive/Subword.hs --- a/ADP/Fusion/SynVar/Recursive/Subword.hs +++ b/ADP/Fusion/SynVar/Recursive/Subword.hs @@ -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) diff --git a/ADP/Fusion/SynVar/Split/Subword.hs b/ADP/Fusion/SynVar/Split/Subword.hs --- a/ADP/Fusion/SynVar/Split/Subword.hs +++ b/ADP/Fusion/SynVar/Split/Subword.hs @@ -1,10 +1,16 @@ +-- | +-- +-- TODO Rewrite to use the new index-generating system. +-- +-- TODO Take care of minsize constraints! These are somewhat tricky. We +-- have one constraint for dimension in the table. + module ADP.Fusion.SynVar.Split.Subword where import Data.Strict.Tuple import Data.Proxy -import Data.Vector.Fusion.Stream.Monadic -import Data.Vector.Fusion.Stream.Size +import Data.Vector.Fusion.Stream.Monadic hiding (flatten) import Data.Vector.Fusion.Util (delay_inline) import Debug.Trace import GHC.TypeLits @@ -24,15 +30,15 @@ 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 diff --git a/ADP/Fusion/SynVar/Split/Type.hs b/ADP/Fusion/SynVar/Split/Type.hs --- a/ADP/Fusion/SynVar/Split/Type.hs +++ b/ADP/Fusion/SynVar/Split/Type.hs @@ -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 diff --git a/ADP/Fusion/Term/Chr.hs b/ADP/Fusion/Term/Chr.hs --- a/ADP/Fusion/Term/Chr.hs +++ b/ADP/Fusion/Term/Chr.hs @@ -2,10 +2,12 @@ module ADP.Fusion.Term.Chr ( module ADP.Fusion.Term.Chr.Type , module ADP.Fusion.Term.Chr.Point + , module ADP.Fusion.Term.Chr.Set0 , module ADP.Fusion.Term.Chr.Subword ) where import ADP.Fusion.Term.Chr.Point +import ADP.Fusion.Term.Chr.Set0 import ADP.Fusion.Term.Chr.Subword import ADP.Fusion.Term.Chr.Type diff --git a/ADP/Fusion/Term/Chr/Point.hs b/ADP/Fusion/Term/Chr/Point.hs --- a/ADP/Fusion/Term/Chr/Point.hs +++ b/ADP/Fusion/Term/Chr/Point.hs @@ -1,6 +1,7 @@ module ADP.Fusion.Term.Chr.Point where +import Data.Proxy import Data.Strict.Tuple import Debug.Trace import qualified Data.Vector.Fusion.Stream.Monadic as S @@ -11,81 +12,65 @@ import 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 #-} diff --git a/ADP/Fusion/Term/Chr/Set0.hs b/ADP/Fusion/Term/Chr/Set0.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Chr/Set0.hs @@ -0,0 +1,64 @@ + +-- | @Chr@ on sets is equivalent to having a @Vertex@ symbol. Each bit +-- denotes one vertex point. + +module ADP.Fusion.Term.Chr.Set0 where + +import Data.Proxy +import Data.Strict.Tuple +import Data.Vector.Fusion.Util (delay_inline) +import Debug.Trace +import Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Generic as VG +import Prelude hiding (map) +import Data.Bits +import Data.Bits.Extras (msb) +import Data.Bits.Ordered + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base +import ADP.Fusion.Term.Chr.Type + + + +instance + ( TmkCtx1 m ls (Chr r x) (BitSet i) + ) => MkStream m (ls :!: Chr r x) (BitSet i) where + mkStream (ls :!: Chr f xs) sv us is + = S.map (\(ss,ee,ii,oo) -> ElmChr ee ii oo ss) + . addTermStream1 (Chr f xs) sv us is + $ mkStream ls (termStaticVar (Chr f xs) sv is) us (termStreamIndex (Chr f xs) sv is) + {-# Inline mkStream #-} + +instance + ( TstCtx1 m ts a is (BitSet I) + ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.BitSet I) where + termStream (ts:|Chr f xs) (cs:.IStatic rb) (us:.u) (is:.i) + = staticCheck (rb <= popCount i && i <= u && VG.length xs > msb u) + . S.flatten mk step . termStream ts cs us is + -- we task all set bits @bs@ and also the index @i@ and calculate + -- the non-set bits @mask@. The mask should have a popcount equal + -- to @rb + 1@. We then active bit 0 and proceed with @step@. + where mk svS = let bs = getIndex (tIx svS) (Proxy :: Proxy (is:.BitSet I)) + mask = i `xor` bs + in {- traceShow ("Chr",i,bs,mask,lsbZ mask) $ -} return (svS :. mask :. lsbZ mask) + -- In case we can still do a step via @k>=0@, we active bit @k@ + -- in @aa@. + step (svS@(TState s a b ii oo ee) :. mask :. k ) + | k < 0 = return $ Done + | otherwise = + let aa = getIndex a (Proxy :: Proxy (is:.BitSet I)) + in return $ Yield (TState s a b (ii:.setBit aa k) (oo:.0) (ee:.f xs k)) + (svS :. mask :. nextActiveZ k mask) + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + {-# Inline termStream #-} + +instance TermStaticVar (Chr r x) (BitSet I) where + termStaticVar _ (IStatic rb) _ = IStatic $ rb + 1 + termStaticVar _ (IVariable rb) _ = IVariable $ rb + 1 + termStreamIndex _ _ b = b + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + diff --git a/ADP/Fusion/Term/Chr/Subword.hs b/ADP/Fusion/Term/Chr/Subword.hs --- a/ADP/Fusion/Term/Chr/Subword.hs +++ b/ADP/Fusion/Term/Chr/Subword.hs @@ -1,6 +1,7 @@ module ADP.Fusion.Term.Chr.Subword where +import Data.Proxy import Data.Strict.Tuple import Data.Vector.Fusion.Util (delay_inline) import Debug.Trace @@ -16,66 +17,80 @@ 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 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 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 #-} diff --git a/ADP/Fusion/Term/Chr/Type.hs b/ADP/Fusion/Term/Chr/Type.hs --- a/ADP/Fusion/Term/Chr/Type.hs +++ b/ADP/Fusion/Term/Chr/Type.hs @@ -1,4 +1,10 @@ +-- | +-- +-- TODO Rename @Chr@ to @Vtx@, a vertex parser is a generalization of +-- a char parser. But this is only semantics, so not super important to do +-- now. + module ADP.Fusion.Term.Chr.Type where import Data.Strict.Tuple @@ -52,5 +58,5 @@ deriving instance (Show i, Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i) -type instance TermArg (TermSymbol a (Chr r x)) = TermArg a :. r +type instance TermArg (Chr r x) = r diff --git a/ADP/Fusion/Term/Deletion.hs b/ADP/Fusion/Term/Deletion.hs --- a/ADP/Fusion/Term/Deletion.hs +++ b/ADP/Fusion/Term/Deletion.hs @@ -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 {- diff --git a/ADP/Fusion/Term/Deletion/Point.hs b/ADP/Fusion/Term/Deletion/Point.hs --- a/ADP/Fusion/Term/Deletion/Point.hs +++ b/ADP/Fusion/Term/Deletion/Point.hs @@ -1,6 +1,7 @@ module ADP.Fusion.Term.Deletion.Point where +import Data.Proxy import Data.Strict.Tuple import qualified Data.Vector.Fusion.Stream.Monadic as S @@ -12,51 +13,46 @@ 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 #-} diff --git a/ADP/Fusion/Term/Deletion/Subword.hs b/ADP/Fusion/Term/Deletion/Subword.hs --- a/ADP/Fusion/Term/Deletion/Subword.hs +++ b/ADP/Fusion/Term/Deletion/Subword.hs @@ -1,6 +1,7 @@ module ADP.Fusion.Term.Deletion.Subword where +import Data.Proxy import Data.Strict.Tuple import Data.Vector.Fusion.Stream.Monadic as S import Prelude hiding (map) @@ -13,20 +14,76 @@ 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 #-} diff --git a/ADP/Fusion/Term/Deletion/Type.hs b/ADP/Fusion/Term/Deletion/Type.hs --- a/ADP/Fusion/Term/Deletion/Type.hs +++ b/ADP/Fusion/Term/Deletion/Type.hs @@ -23,5 +23,5 @@ {-# Inline getIdx #-} {-# Inline getOmx #-} -type instance TermArg (TermSymbol a Deletion) = TermArg a :. () +type instance TermArg Deletion = () diff --git a/ADP/Fusion/Term/Deletion/Unit.hs b/ADP/Fusion/Term/Deletion/Unit.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Deletion/Unit.hs @@ -0,0 +1,55 @@ + +module ADP.Fusion.Term.Deletion.Unit where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S + +import Data.PrimitiveArray + +import ADP.Fusion.Base +import ADP.Fusion.Term.Deletion.Type + + + +instance + ( TmkCtx1 m ls Deletion (Unit i) + ) => MkStream m (ls :!: Deletion) (Unit i) where + mkStream (ls :!: Deletion) sv us is + = S.map (\(ss,ee,ii,oo) -> ElmDeletion ii oo ss) + . addTermStream1 Deletion sv us is + $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is) + {-# Inline mkStream #-} + + + +instance + ( TstCtx1 m ts a is (Unit I) + ) => TermStream m (TermSymbol ts Deletion) a (is:.Unit I) where + termStream (ts:|Deletion) (cs:.IStatic ()) (us:._) (is:._) + = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.())) + . termStream ts cs us is + {-# Inline termStream #-} + +instance + ( TstCtx1 m ts a is (Unit O) + ) => TermStream m (TermSymbol ts Deletion) a (is:.Unit O) where + termStream (ts:|Deletion) (cs:.OStatic ()) (us:._) (is:._) + = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.())) + . termStream ts cs us is + {-# Inline termStream #-} + + + +instance TermStaticVar Deletion (Unit I) where + termStaticVar _ _ _ = IStatic () + termStreamIndex _ _ _ = Unit + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + +instance TermStaticVar Deletion (Unit O) where + termStaticVar _ _ _ = OStatic () + termStreamIndex _ _ _ = Unit + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + diff --git a/ADP/Fusion/Term/Edge/Set.hs b/ADP/Fusion/Term/Edge/Set.hs --- a/ADP/Fusion/Term/Edge/Set.hs +++ b/ADP/Fusion/Term/Edge/Set.hs @@ -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 diff --git a/ADP/Fusion/Term/Edge/Type.hs b/ADP/Fusion/Term/Edge/Type.hs --- a/ADP/Fusion/Term/Edge/Type.hs +++ b/ADP/Fusion/Term/Edge/Type.hs @@ -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 diff --git a/ADP/Fusion/Term/Epsilon.hs b/ADP/Fusion/Term/Epsilon.hs --- a/ADP/Fusion/Term/Epsilon.hs +++ b/ADP/Fusion/Term/Epsilon.hs @@ -2,12 +2,16 @@ module ADP.Fusion.Term.Epsilon ( module ADP.Fusion.Term.Epsilon.Type , module ADP.Fusion.Term.Epsilon.Point + , module ADP.Fusion.Term.Epsilon.Set , module ADP.Fusion.Term.Epsilon.Subword + , module ADP.Fusion.Term.Epsilon.Unit ) where import ADP.Fusion.Term.Epsilon.Point +import ADP.Fusion.Term.Epsilon.Set import ADP.Fusion.Term.Epsilon.Subword import ADP.Fusion.Term.Epsilon.Type +import ADP.Fusion.Term.Epsilon.Unit {- diff --git a/ADP/Fusion/Term/Epsilon/Point.hs b/ADP/Fusion/Term/Epsilon/Point.hs --- a/ADP/Fusion/Term/Epsilon/Point.hs +++ b/ADP/Fusion/Term/Epsilon/Point.hs @@ -1,6 +1,7 @@ module ADP.Fusion.Term.Epsilon.Point where +import Data.Proxy import Data.Strict.Tuple import qualified Data.Vector.Fusion.Stream.Monadic as S @@ -12,51 +13,46 @@ 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 #-} diff --git a/ADP/Fusion/Term/Epsilon/Set.hs b/ADP/Fusion/Term/Epsilon/Set.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Epsilon/Set.hs @@ -0,0 +1,98 @@ + +module ADP.Fusion.Term.Epsilon.Set where + +import Data.Proxy +import Data.Strict.Tuple +import Data.Vector.Fusion.Stream.Monadic as S +import Prelude hiding (map) + +import Data.Bits.Ordered +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Base +import ADP.Fusion.Term.Epsilon.Type + + + +-- ** No boundaries + +instance + ( TmkCtx1 m ls Epsilon (BitSet i) + ) => MkStream m (ls :!: Epsilon) (BitSet i) where + mkStream (ls :!: Epsilon) sv us is + = map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss) + . addTermStream1 Epsilon sv us is + $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) + {-# Inline mkStream #-} + + + +instance + ( TstCtx1 m ts a is (BitSet I) + ) => TermStream m (TermSymbol ts Epsilon) a (is:.BitSet I) where + termStream (ts:|Epsilon) (cs:.IStatic r) (us:.u) (is:.i) + = staticCheck (i==0) + . map (\(TState s a b ii oo ee) -> + TState s a b (ii:.0) (oo:.0) (ee:.()) ) + . termStream ts cs us is + {-# Inline termStream #-} + +instance + ( TstCtx1 m ts a is (BitSet O) + ) => TermStream m (TermSymbol ts Epsilon) a (is:.BitSet O) where + termStream (ts:|Epsilon) (cs:.OStatic r) (us:.u) (is:.i) + = staticCheck (i==u) + . map (\(TState s a b ii oo ee) -> + TState s a b (ii:.u) (oo:.u) (ee:.()) ) + . termStream ts cs us is + {-# Inline termStream #-} + + + +instance TermStaticVar Epsilon (BitSet I) where + termStaticVar _ sv _ = sv + termStreamIndex _ _ b = b + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + +instance TermStaticVar Epsilon (BitSet O) where + termStaticVar _ sv _ = sv + termStreamIndex _ _ b = b + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + + + +-- ** Two boundaries + +instance + ( TmkCtx1 m ls Epsilon (BS2 First Last i) + ) => MkStream m (ls :!: Epsilon) (BS2 First Last i) where + mkStream (ls :!: Epsilon) sv us is + = map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss) + . addTermStream1 Epsilon sv us is + $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) + {-# Inline mkStream #-} + +instance + ( TstCtx1 m ts a is (BS2 First Last I) + ) => TermStream m (TermSymbol ts Epsilon) a (is:.BS2 First Last I) where + termStream (ts:|Epsilon) (cs:.IStatic r) (us:.u) (is:.BS2 bs _ _) + = staticCheck (bs==0) + . map (\(TState s a b ii oo ee) -> + TState s a b (ii:.BS2 0 0 0) (oo:.BS2 0 0 0) (ee:.()) ) + . termStream ts cs us is + {-# Inline termStream #-} + +instance + ( TstCtx1 m ts a is (BS2 First Last O) + ) => TermStream m (TermSymbol ts Epsilon) a (is:.BS2 First Last O) where + termStream (ts:|Epsilon) (cs:.OStatic r) (us:.BS2 ub uf ul) (is:.BS2 bs f l) + = staticCheck (ub==bs) + . map (\(TState s a b ii oo ee) -> + let i' = getIndex a (Proxy :: Proxy (is:.BS2 First Last O)) + o' = getIndex b (Proxy :: Proxy (is:.BS2 First Last O)) + in TState s a b (ii:.i') (oo:.o') (ee:.()) ) + . termStream ts cs us is + {-# Inline termStream #-} + diff --git a/ADP/Fusion/Term/Epsilon/Subword.hs b/ADP/Fusion/Term/Epsilon/Subword.hs --- a/ADP/Fusion/Term/Epsilon/Subword.hs +++ b/ADP/Fusion/Term/Epsilon/Subword.hs @@ -1,6 +1,7 @@ module ADP.Fusion.Term.Epsilon.Subword where +import Data.Proxy import Data.Strict.Tuple import Data.Vector.Fusion.Stream.Monadic as S import Prelude hiding (map) @@ -10,44 +11,52 @@ import 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 #-} diff --git a/ADP/Fusion/Term/Epsilon/Type.hs b/ADP/Fusion/Term/Epsilon/Type.hs --- a/ADP/Fusion/Term/Epsilon/Type.hs +++ b/ADP/Fusion/Term/Epsilon/Type.hs @@ -23,5 +23,5 @@ {-# Inline getIdx #-} {-# Inline getOmx #-} -type instance TermArg (TermSymbol a Epsilon) = TermArg a :. () +type instance TermArg Epsilon = () diff --git a/ADP/Fusion/Term/Epsilon/Unit.hs b/ADP/Fusion/Term/Epsilon/Unit.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Epsilon/Unit.hs @@ -0,0 +1,55 @@ + +module ADP.Fusion.Term.Epsilon.Unit where + +import Data.Proxy +import Data.Strict.Tuple +import qualified Data.Vector.Fusion.Stream.Monadic as S + +import Data.PrimitiveArray + +import ADP.Fusion.Base +import ADP.Fusion.Term.Epsilon.Type + + + +instance + ( TmkCtx1 m ls Epsilon (Unit i) + ) => MkStream m (ls :!: Epsilon) (Unit i) where + mkStream (ls :!: Epsilon) sv us is + = S.map (\(ss,ee,ii,oo) -> ElmEpsilon ii oo ss) + . addTermStream1 Epsilon sv us is + $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) + {-# Inline mkStream #-} + + + +instance + ( TstCtx1 m ts a is (Unit I) + ) => TermStream m (TermSymbol ts Epsilon) a (is:.Unit I) where + termStream (ts:|Epsilon) (cs:.IStatic ()) (us:._) (is:._) + = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.())) + . termStream ts cs us is + {-# Inline termStream #-} + +instance + ( TstCtx1 m ts a is (Unit O) + ) => TermStream m (TermSymbol ts Epsilon) a (is:.Unit O) where + termStream (ts:|Epsilon) (cs:.OStatic ()) (us:._) (is:._) + = S.map (\(TState s a b ii oo ee) -> TState s a b (ii:.Unit) (oo:.Unit) (ee:.())) + . termStream ts cs us is + {-# Inline termStream #-} + + + +instance TermStaticVar Epsilon (Unit I) where + termStaticVar _ _ _ = IStatic () + termStreamIndex _ _ _ = Unit + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + +instance TermStaticVar Epsilon (Unit O) where + termStaticVar _ _ _ = OStatic () + termStreamIndex _ _ _ = Unit + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} + diff --git a/ADP/Fusion/Term/PeekIndex/Subword.hs b/ADP/Fusion/Term/PeekIndex/Subword.hs --- a/ADP/Fusion/Term/PeekIndex/Subword.hs +++ b/ADP/Fusion/Term/PeekIndex/Subword.hs @@ -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 diff --git a/ADP/Fusion/Term/PeekIndex/Type.hs b/ADP/Fusion/Term/PeekIndex/Type.hs --- a/ADP/Fusion/Term/PeekIndex/Type.hs +++ b/ADP/Fusion/Term/PeekIndex/Type.hs @@ -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 diff --git a/ADP/Fusion/Term/Strng/Point.hs b/ADP/Fusion/Term/Strng/Point.hs --- a/ADP/Fusion/Term/Strng/Point.hs +++ b/ADP/Fusion/Term/Strng/Point.hs @@ -1,6 +1,7 @@ module ADP.Fusion.Term.Strng.Point where +import Data.Proxy import Data.Strict.Tuple import Debug.Trace import qualified Data.Vector.Fusion.Stream.Monadic as S @@ -14,30 +15,84 @@ instance - ( Monad m - , Element ls PointL - , MkStream m ls PointL - ) => MkStream m (ls :!: Strng v x) PointL where - mkStream (ls :!: Strng f minL maxL xs) (IStatic d) (PointL u) (PointL i) - = staticCheck (i - minL >= 0 && i <= u && minL <= maxL) - $ S.map (\z -> let PointL j = getIdx z in ElmStrng (f j (i-j) xs) (PointL i) (PointL 0) z) - $ mkStream ls (IVariable $ d + maxL - minL) (PointL u) (PointL $ i - minL) - mkStream _ _ _ _ = error "mkStream / Strng / PointL / IVariable" + ( TmkCtx1 m ls (Strng v x) (PointL i) + ) => MkStream m (ls :!: Strng v x) (PointL i) where + mkStream (ls :!: strng@(Strng _ minL maxL xs)) sv us is + = S.map (\(ss,ee,ii,oo) -> ElmStrng ee ii oo ss) + . addTermStream1 strng sv us is + $ mkStream ls (termStaticVar strng sv is) us (termStreamIndex strng sv is) {-# Inline mkStream #-} -instance TermStaticVar (Strng v x) PointL where - termStaticVar _ (IStatic d) _ = IVariable d - termStaticVar _ (IVariable d) _ = IVariable d + + +instance + ( TstCtx1 m ts a is (PointL I) + ) => TermStream m (TermSymbol ts (Strng v x)) a (is:.PointL I) where + -- + termStream (ts:|Strng f minL maxL v) (cs:.IStatic d) (us:.PointL u) (is:.PointL i) + = S.map (\(TState s a b ii oo ee) -> + let PointL k = getIndex a (Proxy :: Proxy (is:.PointL I)) + in TState s a b (ii:.PointL i) (oo:.PointL 0) (ee:.f k (i-k) v)) + . termStream ts cs us is + -- + termStream (ts:|Strng f minL maxL v) (cs:.IVariable d) (us:.PointL u) (is:.PointL i) + = S.flatten mk step . termStream ts cs us is + where mk (tstate@(TState s a b ii oo ee)) = + let PointL k = getIndex a (Proxy :: Proxy (is:.PointL I)) + in return (tstate, i-k-d-minL) + step (tstate@(TState s a b ii oo ee), z) + | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s a b (ii:.PointL l) (oo:.o) (ee:.f k (l-k+1) v)) (tstate, z-1) + | otherwise = return $ S.Done + where PointL k = getIndex a (Proxy :: Proxy (is:.PointL I)) + o = PointL 0 + l = i - z - d + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + {-# Inline termStream #-} + +instance + ( TstCtx1 m ts a is (PointL O) + ) => TermStream m (TermSymbol ts (Strng v x)) a (is:.PointL O) where + -- + termStream (ts:|Strng f minL maxL v) (cs:.OStatic d) (us:.PointL u) (is:.PointL i) + = S.map (\(TState s a b ii oo ee) -> + let PointL k = getIndex a (Proxy :: Proxy (is:.PointL O)) + o = getIndex b (Proxy :: Proxy (is:.PointL O)) + in TState s a b (ii:.PointL (i-d+1)) (oo:.o) (ee:.f k (i-k) v)) -- @i-d+1 or k-d+1@ ? + . termStream ts cs us is + -- + termStream (ts:|Strng f minL maxL v) (cs:.ORightOf d) (us:.PointL u) (is:.PointL i) + = S.flatten mk step . termStream ts cs us is + where mk (tstate@(TState s a b ii oo ee)) = + let PointL k = getIndex a (Proxy :: Proxy (is:.PointL O)) + in return (tstate, i-k-d-minL) + step (tstate@(TState s a b ii oo ee), z) + | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s a b (ii:.PointL l) (oo:.o) (ee:.f k (l-k+1) v)) (tstate, z-1) + | otherwise = return $ S.Done + where PointL k = getIndex a (Proxy :: Proxy (is:.PointL O)) + o = getIndex b (Proxy :: Proxy (is:.PointL O)) + l = i - z - d + {-# Inline [0] mk #-} + {-# Inline [0] step #-} + {-# Inline termStream #-} + + + +instance TermStaticVar (Strng v x) (PointL I) where + termStaticVar (Strng _ minL maxL _) (IStatic d) _ = IVariable $ d + maxL - minL + termStaticVar _ (IVariable d) _ = IVariable d -- TODO is this right? + -- termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL + -- {-# Inline [0] termStaticVar #-} {-# Inline [0] termStreamIndex #-} -instance - ( Monad m - , TerminalStream m a is - ) => TerminalStream m (TermSymbol a (Strng v x)) (is:.PointL) where - terminalStream (a:|Strng f minL maxL xs) (sv:.IStatic d) (is:.i@(PointL j)) - = S.map (\(S6 s (zi:.PointL pi) (zo:._) is os e) -> S6 s zi zo (is:.i) (os:.PointL 0) (e:.f pi (j-pi) xs)) - . iPackTerminalStream a sv (is:.i) - {-# Inline terminalStream #-} +instance TermStaticVar (Strng v x) (PointL O) where + termStaticVar (Strng _ minL maxL _) (OStatic d) _ = ORightOf $ d + maxL - minL + termStaticVar _ (ORightOf d) _ = ORightOf 0 -- TODO is this right? + -- + termStreamIndex _ _ j = j + -- + {-# Inline [0] termStaticVar #-} + {-# Inline [0] termStreamIndex #-} diff --git a/ADP/Fusion/Term/Strng/Subword.hs b/ADP/Fusion/Term/Strng/Subword.hs --- a/ADP/Fusion/Term/Strng/Subword.hs +++ b/ADP/Fusion/Term/Strng/Subword.hs @@ -1,9 +1,8 @@ module ADP.Fusion.Term.Strng.Subword where - +import Data.Proxy import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Size import Data.Vector.Fusion.Util (delay_inline) import Debug.Trace import Prelude hiding (map) @@ -17,21 +16,54 @@ +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 #-} + +-} diff --git a/ADP/Fusion/Term/Strng/Type.hs b/ADP/Fusion/Term/Strng/Type.hs --- a/ADP/Fusion/Term/Strng/Type.hs +++ b/ADP/Fusion/Term/Strng/Type.hs @@ -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 diff --git a/ADPfusion.cabal b/ADPfusion.cabal --- a/ADPfusion.cabal +++ b/ADPfusion.cabal @@ -1,5 +1,5 @@ name: ADPfusion -version: 0.4.1.1 +version: 0.5.0.0 author: Christian Hoener zu Siederdissen, 2011-2015 copyright: Christian Hoener zu Siederdissen, 2011-2015 homepage: https://github.com/choener/ADPfusion @@ -11,7 +11,7 @@ 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: @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,12 @@ +0.5.0.0 +------- + +- complete re-design of Inside / Outside / Complement handling based on phantom + types +- very liberal combination of multi-tape grammars +- simplified index generation system (both faster, and easier to write new + symbol now) + 0.4.1.1 ------- diff --git a/src/Durbin.hs b/src/Durbin.hs --- a/src/Durbin.hs +++ b/src/Durbin.hs @@ -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 diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs --- a/src/NeedlemanWunsch.hs +++ b/src/NeedlemanWunsch.hs @@ -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 diff --git a/src/Nussinov.hs b/src/Nussinov.hs --- a/src/Nussinov.hs +++ b/src/Nussinov.hs @@ -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 #-} diff --git a/src/OverlappingPalindromes.hs b/src/OverlappingPalindromes.hs --- a/src/OverlappingPalindromes.hs +++ b/src/OverlappingPalindromes.hs @@ -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 () diff --git a/src/PartNussinov.hs b/src/PartNussinov.hs --- a/src/PartNussinov.hs +++ b/src/PartNussinov.hs @@ -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 #-} {- diff --git a/src/Pseudoknot.hs b/src/Pseudoknot.hs --- a/src/Pseudoknot.hs +++ b/src/Pseudoknot.hs @@ -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) diff --git a/src/SplitTests.hs b/src/SplitTests.hs --- a/src/SplitTests.hs +++ b/src/SplitTests.hs @@ -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 () diff --git a/tests/QuickCheck/Common.hs b/tests/QuickCheck/Common.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheck/Common.hs @@ -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 diff --git a/tests/QuickCheck/Point.hs b/tests/QuickCheck/Point.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheck/Point.hs @@ -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 + diff --git a/tests/QuickCheck/Set.hs b/tests/QuickCheck/Set.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheck/Set.hs @@ -0,0 +1,314 @@ + +{-# Options_GHC -O0 #-} + +module QuickCheck.Set where + +import Data.Bits +import Data.Bits.Extras (msb) +import Data.Vector.Fusion.Util +import Debug.Trace +import qualified Data.List as L +import qualified Data.Vector.Fusion.Stream.Monadic as SM +import qualified Data.Vector.Unboxed as VU +import Test.QuickCheck.All +import Test.QuickCheck hiding (NonEmpty) +import Test.QuickCheck.Monadic +#ifdef ADPFUSION_TEST_SUITE_PROPERTIES +import Test.Framework.TH +import Test.Framework.Providers.QuickCheck2 +#endif + +import Data.Bits.Ordered +import Data.PrimitiveArray + +import ADP.Fusion +import QuickCheck.Common + + + +-- * BitSets without interfaces + +-- ** Inside checks + +prop_BS0_I_Eps ix@(BitSet _) = zs == ls where + zs = (id <<< Epsilon ... stoList) highestBi ix + ls = [ () | ix == 0 ] + +prop_BS0_I_Iv ix@(BitSet _) = {- traceShow (zs,ls) $ -} L.sort zs == L.sort ls where + tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + zs = ((,) <<< tia % chr csB0 ... stoList) highestBi ix + ls = [ (xsB ! (clearBit ix a), csB0 VU.! a) | a <- activeBitsL ix ] + +prop_BS0_I_Ivv ix@(BitSet _) = {- traceShow (zs,ls) $ -} L.sort zs == L.sort ls where + tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + zs = ((,,) <<< tia % chr csB0 % chr csB0 ... stoList) highestBi ix + ls = [ (xsB ! (clearBit (clearBit ix a) b), csB0 VU.! a, csB0 VU.! b) | a <- activeBitsL ix, b <- activeBitsL ix, a /=b ] + +prop_BS0_I_II ix@(BitSet _) = zs == ls where + tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + zs = ((,) <<< tia % tib ... stoList) highestBi ix + ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) + | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] + , let kk = popShiftL ix (BitSet k) + ] + +prop_BS0_I_JJ ix@(BitSet _) = zs == ls where + tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) + tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) + zs = ((,) <<< tia % tib ... stoList) highestBi ix + ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) + | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] + , let kk = popShiftL ix (BitSet k) + , popCount kk > 0 + , popCount (ix `xor` kk) > 0 + ] + +prop_BS0_I_III ix@(BitSet _) = {- traceShow (zs,ls) $ -} zs == ls where + tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + zs = ((,,) <<< tia % tib % tic ... stoList) highestBi ix + ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm ) + | k <- VU.toList . popCntSorted $ popCount ix + , l <- VU.toList . popCntSorted $ popCount ix - popCount k + , let kk = popShiftL ix (BitSet k) + , let ll = popShiftL (ix `xor` kk) (BitSet l) + , let mm = (ix `xor` (kk .|. ll)) + ] + +prop_BS0_I_JJJ ix@(BitSet _) = zs == ls where + tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) + tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) + tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) + zs = ((,,) <<< tia % tib % tic ... stoList) highestBi ix + ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm ) + | k <- VU.toList . popCntSorted $ popCount ix + , l <- VU.toList . popCntSorted $ popCount ix - popCount k + , let kk = popShiftL ix (BitSet k) + , let ll = popShiftL (ix `xor` kk) (BitSet l) + , let mm = (ix `xor` (kk .|. ll)) + , popCount kk > 0, popCount ll > 0, popCount mm > 0 + ] + + +-- * Outside checks +-- These checks are very similar to those in the @Subword@ module. We just +-- need to be a bit more careful, as indexed sets have overlap. + +prop_BS0_O_Eps ix@(BitSet _) = zs == ls where + zs = (id <<< Epsilon ... stoList) highestBo ix + ls = [ () | ix == highestBo ] + +prop_BS0_O_O ix@(BitSet _) = zs == ls where + tia = ITbl 0 0 EmptyOk xoB (\ _ _ -> Id 1) + zs = (id <<< tia ... stoList) highestBo ix + ls = [ xoB ! ix ] + +--prop_BS0_O_IO ix@(BitSet _) = zs == ls where +-- tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) +-- tib = ITbl 0 0 EmptyOk xoB (\ _ _ -> Id 1) +-- zs = ((,) <<< tia % tib ... stoList) highestBo ix +-- ls = [] +-- {- +-- ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) +-- | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] +-- , let kk = popShiftL ix (BitSet k) +-- ] -} + +{- +prop_BS0_I_II ix@(BitSet _) = zs == ls where + tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) + zs = ((,) <<< tia % tib ... stoList) highestBi ix + ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) + | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] + , let kk = popShiftL ix (BitSet k) + ] +-} + + +-- ** Two non-terminals. +-- +-- @A_s -> B_(s\t) C_t (s\t) ++ t == s@ +-- @s = 111 , s\t = 101, t = 010@ +-- +-- with @Z@ the full set. +-- @Z = 1111@ + +-- @B*_Z\(s\t) -> A*_Z\s C_t@ +-- @Z\(s\t) = 1010, Z\s = 1000, t = 010@ + + + + +-- * BitSets with two interfaces + +-- ** Inside checks + +--prop_bii_i :: BS2 First Last I -> Bool +--prop_bii_i ix@(BS2 s i j) = zs == ls where +-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) +-- zs = (id <<< tia ... stoList) highestBII ix +-- ls = [ xsBII ! ix ] +-- +--prop_bii_i_n :: BS2 First Last I -> Bool +--prop_bii_i_n ix@(BS2 s i j) = zs == ls where +-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) +-- zs = (id <<< tia ... stoList) highestBII ix +-- ls = [ xsBII ! ix | popCount s > 0 ] + +-- | Edges should never work as a single terminal element. + +--prop_bii_e :: BS2 First Last I -> Bool +--prop_bii_e ix@(BS2 s (Iter i) (Iter j)) = zs == ls where +-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) +-- zs = (id <<< e ... stoList) highestBII ix +-- ls = [] :: [ (Int,Int) ] + +-- | Edges extend only in cases where in @i -> j@, @i@ actually happens to +-- be a true interface. + +--prop_bii_ie :: BS2 First Last I -> Bool +--prop_bii_ie ix@(BS2 s i (Iter j)) = zs == ls where +-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) +-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) +-- zs = ((,) <<< tia % e ... stoList) highestBII ix +-- ls = [ ( xsBII ! (BS2 t i (Iter k :: Interface Last)) , (k,j) ) +-- | let t = s `clearBit` j +-- , k <- activeBitsL t ] +-- +--prop_bii_ie_n :: BS2 First Last I -> Bool +--prop_bii_ie_n ix@(BS2 s i (Iter j)) = zs == ls where +-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) +-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) +-- zs = ((,) <<< tia % e ... stoList) highestBII ix +-- ls = [ ( xsBII ! (BS2 t i (Iter k :: Interface Last)) , (k,j) ) +-- | let t = s `clearBit` j +-- , popCount t >= 2 +-- , k <- activeBitsL t +-- , k /= getIter i +-- ] +-- +--prop_bii_iee :: BS2 First Last I -> Bool +--prop_bii_iee ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where +-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) +-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) +-- zs = ((,,) <<< tia % e % e ... stoList) highestBII ix +-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,j) ) +-- | let tmp = (s `clearBit` j) +-- , l <- activeBitsL tmp +-- , l /= getIter i +-- , let t = tmp `clearBit` l +-- , k <- activeBitsL t +-- , let kk = Iter k +-- ] +-- +--prop_bii_ieee :: BS2 First Last I -> Bool +--prop_bii_ieee ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where +-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) +-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) +-- zs = ((,,,) <<< tia % e % e % e ... stoList) highestBII ix +-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,m) , (m,j) ) +-- | let tmpM = (s `clearBit` j) +-- , m <- activeBitsL tmpM +-- , m /= getIter i +-- , let tmpL = (tmpM `clearBit` m) +-- , l <- activeBitsL tmpL +-- , l /= getIter i +-- , let t = tmpL `clearBit` l +-- , k <- activeBitsL t +-- , let kk = Iter k +-- ] +-- +--prop_bii_iee_n :: BS2 First Last I -> Bool +--prop_bii_iee_n ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where +-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) +-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) +-- zs = ((,,) <<< tia % e % e ... stoList) highestBII ix +-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,j) ) +-- | let tmp = (s `clearBit` j) +-- , l <- activeBitsL tmp +-- , l /= getIter i +-- , let t = tmp `clearBit` l +-- , popCount t >= 2 +-- , k <- activeBitsL t +-- , k /= getIter i +-- , let kk = Iter k +-- ] +-- +--prop_bii_ieee_n :: BS2 First Last I -> Bool +--prop_bii_ieee_n ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where +-- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) +-- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) +-- zs = ((,,,) <<< tia % e % e % e ... stoList) highestBII ix +-- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,m) , (m,j) ) +-- | let tmpM = (s `clearBit` j) +-- , m <- activeBitsL tmpM +-- , m /= getIter i +-- , let tmpL = (tmpM `clearBit` m) +-- , l <- activeBitsL tmpL +-- , l /= getIter i +-- , let t = tmpL `clearBit` l +-- , popCount t >= 2 +-- , k <- activeBitsL t +-- , k /= getIter i +-- , let kk = Iter k +-- ] + +-- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where +-- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) +-- tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) +-- zs = ((,) <<< tia % tib ... stoList) highestBII ix +-- ls = [ ( xsBII ! kk , xsBII ! ll ) +-- | k <- VU.toList . popCntSorted $ popCount s +-- , ki <- if k==0 then [0] else activeBitsL k +-- , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki) +-- , let kk = (BitSet k:>Iter ki:>Iter kj) +-- , let l = s `xor` BitSet k +-- , li <- if l==0 then [0] else activeBitsL l +-- , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li) +-- , let ll = (l:>Iter li:>Iter lj) +-- ] + + + +-- * Helper functions + +stoList = unId . SM.toList + +highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary +highestBi :: BitSet I +highestBi = BitSet $ 2^(highBit+1) -1 +highestBo :: BitSet O +highestBo = BitSet $ 2^(highBit+1) -1 +highestBII = BS2 highestBi (Iter $ highBit-1) (Iter $ highBit-1) -- assuming @highBit >= 1@ + +xsB :: Unboxed (BitSet I) Int +xsB = fromList (BitSet 0) highestBi [ 0 .. ] + +xoB :: Unboxed (BitSet O) Int +xoB = fromList (BitSet 0) highestBo [ 0 .. ] + +xsBII :: Unboxed (BS2 First Last I) Int +xsBII = fromList (BS2 0 0 0) highestBII [ 0 .. ] + +csB0 :: VU.Vector Int +csB0 = VU.fromList [ i | i <- [0 .. msb highestBi] ] + +-- * general quickcheck stuff + +options = stdArgs {maxSuccess = 1000} + +customCheck = quickCheckWithResult options + +return [] +allProps = $forAllProperties customCheck + + + +#ifdef ADPFUSION_TEST_SUITE_PROPERTIES +testgroup_set = $(testGroupGenerator) +#endif + + diff --git a/tests/QuickCheck/Subword.hs b/tests/QuickCheck/Subword.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheck/Subword.hs @@ -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 + diff --git a/tests/performance.hs b/tests/performance.hs --- a/tests/performance.hs +++ b/tests/performance.hs @@ -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 diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -4,87 +4,16 @@ module Main where -import Test.Framework.Providers.QuickCheck2 -import Test.Framework.TH - -import 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]