ADPfusion 0.5.0.0 → 0.5.1.0
raw patch · 52 files changed
+1199/−939 lines, 52 filesdep −monad-primitivedep −singletonsdep ~PrimitiveArraydep ~basedep ~template-haskellnew-component:exe:spectest
Dependencies removed: monad-primitive, singletons
Dependency ranges changed: PrimitiveArray, base, template-haskell, th-orphans, vector
Files
- ADP/Fusion/Base/Classes.hs +76/−26
- ADP/Fusion/Base/Multi.hs +89/−73
- ADP/Fusion/Base/Point.hs +47/−44
- ADP/Fusion/Base/Set.hs +24/−12
- ADP/Fusion/Base/Subword.hs +36/−20
- ADP/Fusion/Base/TyLvlIx.hs +32/−0
- ADP/Fusion/Base/Unit.hs +11/−9
- ADP/Fusion/SynVar/Array.hs +29/−44
- ADP/Fusion/SynVar/Array/TermSymbol.hs +22/−22
- ADP/Fusion/SynVar/Array/Type.hs +40/−81
- ADP/Fusion/SynVar/Fill.hs +37/−18
- ADP/Fusion/SynVar/Indices/Classes.hs +39/−19
- ADP/Fusion/SynVar/Indices/Point.hs +24/−35
- ADP/Fusion/SynVar/Indices/Set0.hs +31/−34
- ADP/Fusion/SynVar/Indices/Subword.hs +53/−82
- ADP/Fusion/SynVar/Indices/Unit.hs +12/−20
- ADP/Fusion/SynVar/Recursive/Type.hs +67/−36
- ADP/Fusion/SynVar/Split/Subword.hs +40/−38
- ADP/Fusion/SynVar/Split/Type.hs +31/−29
- ADP/Fusion/Term/Chr/Point.hs +11/−12
- ADP/Fusion/Term/Chr/Set0.hs +10/−9
- ADP/Fusion/Term/Chr/Subword.hs +29/−27
- ADP/Fusion/Term/Chr/Type.hs +5/−7
- ADP/Fusion/Term/Deletion/Point.hs +9/−10
- ADP/Fusion/Term/Deletion/Subword.hs +28/−26
- ADP/Fusion/Term/Deletion/Type.hs +3/−5
- ADP/Fusion/Term/Deletion/Unit.hs +7/−7
- ADP/Fusion/Term/Edge/Set.hs +6/−6
- ADP/Fusion/Term/Edge/Type.hs +4/−6
- ADP/Fusion/Term/Epsilon/Point.hs +9/−10
- ADP/Fusion/Term/Epsilon/Set.hs +19/−20
- ADP/Fusion/Term/Epsilon/Subword.hs +11/−12
- ADP/Fusion/Term/Epsilon/Type.hs +3/−5
- ADP/Fusion/Term/Epsilon/Unit.hs +7/−7
- ADP/Fusion/Term/PeekIndex/Subword.hs +1/−1
- ADP/Fusion/Term/PeekIndex/Type.hs +5/−7
- ADP/Fusion/Term/Strng/Point.hs +22/−25
- ADP/Fusion/Term/Strng/Subword.hs +16/−10
- ADP/Fusion/Term/Strng/Type.hs +4/−6
- ADPfusion.cabal +52/−7
- changelog.md +6/−0
- src/Durbin.hs +16/−4
- src/NeedlemanWunsch.hs +3/−3
- src/Nussinov.hs +2/−2
- src/OverlappingPalindromes.hs +2/−2
- src/PartNussinov.hs +5/−5
- src/Pseudoknot.hs +2/−2
- src/SpecTest.hs +116/−0
- src/SplitTests.hs +2/−2
- tests/QuickCheck/Point.hs +27/−35
- tests/QuickCheck/Subword.hs +16/−16
- tests/performance.hs +1/−1
ADP/Fusion/Base/Classes.hs view
@@ -1,6 +1,7 @@ module ADP.Fusion.Base.Classes where +import Data.Proxy import Data.Strict.Tuple import qualified Data.Vector.Fusion.Stream.Monadic as S @@ -28,6 +29,34 @@ type Context i :: * initialContext :: i -> Context i +-- | While we ostensibly use an index of type @i@ we typically do not need+-- every element of an @i@. For example, when looking at 'Subword's, we do+-- not need both element of @j:.k@ but only @k@.+-- Also, inside grammars do need fewer moving indices than outside+-- grammars.+--+-- TODO Sometimes, the actual RunningIndex ctors are not erased. This could+-- be due to <https://ghc.haskell.org/trac/ghc/ticket/2289>. To test, we+-- should transform RunningIndex into a type class to give us access to the+-- left and right member, also we should create instances a la+-- @RunningIndex (is :. Subword I) = RiSwI !(RunningIndex is) !Int@.+-- Hopefully, these are completely erased.++{-+class RunningIndexCl i where+ type RecursiveRl i :: *+ type ThisRI i :: *+-}++data family RunningIndex i :: *++data instance RunningIndex (is:.i) = !(RunningIndex is) :.: !(RunningIndex i)++data instance RunningIndex Z = RiZ++deriving instance Show (RunningIndex Z)++ -- | During construction of the stream, we need to extract individual elements -- from symbols in production rules. An element in a stream is fixed by both, -- the type @x@ of the actual argument we want to grab (say individual@@ -41,8 +70,7 @@ type RecElm x i :: * type Arg x :: * getArg :: Elm x i -> Arg x- getIdx :: Elm x i -> i- getOmx :: Elm x i -> i+ getIdx :: Elm x i -> RunningIndex i getElm :: Elm x i -> RecElm x i -- | @mkStream@ creates the actual stream of elements (@Elm@) that will be fed@@ -80,16 +108,14 @@ instance ( ) => Element S i where- data Elm S i = ElmS !i !i+ data Elm S i = ElmS !(RunningIndex i) type Arg S = Z- getArg (ElmS _ _) = Z- getIdx (ElmS i _) = i- getOmx (ElmS _ o) = o+ getArg (ElmS _) = Z+ getIdx (ElmS i) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} -deriving instance Show ix => Show (Elm S ix)+deriving instance (Show (RunningIndex ix)) => Show (Elm S ix) -- | 'staticCheck' acts as a static filter. If 'b' is true, we keep all stream -- elements. If 'b' is false, we discard all stream elements.@@ -114,35 +140,59 @@ -- indices, or finally they can be 'OnlyZero' (only @i==j@ allowed) which is -- useful in multi-dimensional casese. -data TableConstraint- = EmptyOk- | NonEmpty- | OnlyZero- deriving (Eq,Show)+--data TableConstraint+-- = EmptyOk+-- | NonEmpty+-- | OnlyZero+-- deriving (Eq,Show) +data EmptyOk = EmptyOk++data NonEmpty = NonEmpty++class MinSize c where+ minSize :: c -> Int++instance MinSize EmptyOk where+ minSize EmptyOk = 0+ {-# Inline minSize #-}++instance MinSize NonEmpty where+ minSize NonEmpty = 1+ {-# Inline minSize #-}++{- minSize :: TableConstraint -> Int minSize NonEmpty = 1 minSize _ = 0-{-# INLINE minSize #-}+{-# Inline [0] minSize #-}+-} -- | -- -- TODO Rewrite to generalize easily over multi-dim cases. class ModifyConstraint t where- toNonEmpty :: t -> t- toEmpty :: t -> t---- |--type family TblConstraint x :: *+ type TNE t :: *+ type TE t :: *+ toNonEmpty :: t -> TNE t+ toEmpty :: t -> TE t -type instance TblConstraint (is:.i) = TblConstraint is :. TblConstraint i-type instance TblConstraint Z = Z+--+--instance ModifyConstraint EmptyOk+-- type TNE EmptyOk = NonEmpty+-- type TE EmptyOk = --- TODO move into the sub-modules+-- | -type instance TblConstraint (PointL t) = TableConstraint-type instance TblConstraint (PointR t) = TableConstraint-type instance TblConstraint (Subword t) = TableConstraint+--type family TblConstraint x :: *+--+--type instance TblConstraint (is:.i) = TblConstraint is :. TblConstraint i+--type instance TblConstraint Z = Z+--+---- TODO move into the sub-modules+--+--type instance TblConstraint (PointL t) = TableConstraint+--type instance TblConstraint (PointR t) = TableConstraint+--type instance TblConstraint (Subword t) = TableConstraint
ADP/Fusion/Base/Multi.hs view
@@ -37,50 +37,43 @@ 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)+ data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !(RunningIndex i) !(Elm ls i) type Arg (ls :!: TermSymbol a b) = Arg ls :. TermArg (TermSymbol a b)- getArg (ElmTS a _ _ ls) = getArg ls :. a- getIdx (ElmTS _ i _ _ ) = i- getOmx (ElmTS _ _ o _ ) = o+ getArg (ElmTS a _ ls) = getArg ls :. a+ getIdx (ElmTS _ i _ ) = i {-# INLINE getArg #-} {-# INLINE getIdx #-} -deriving instance (Show i, Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)+deriving instance (Show i, Show (RunningIndex i), Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i) instance ( Monad m , MkStream m ls i , Element ls i--- , TerminalStream m (TermSymbol a b) i , TermStaticVar (TermSymbol a b) i- , TermStream m (TermSymbol a b) i i+ , TermStream m (TermSymbol a b) (Elm ls 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)+ = map (\(TState sS ii ee) -> ElmTS ee ii 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)+ . map (\s -> TState s RiZ Z) $ mkStream ls (termStaticVar ts sv i) lu (termStreamIndex ts sv i) {-# Inline mkStream #-} --- | Handles each individual argument within a stack of terminal symbols.--class TerminalStream m t i where- terminalStream :: t -> Context i -> i -> S.Stream m (S5 s j j i i) -> S.Stream m (S6 s j j i i (TermArg t))--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 #-}--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 #-}+---- | Handles each individual argument within a stack of terminal symbols.+--+--class TerminalStream m t i where+-- terminalStream :: t -> Context i -> i -> S.Stream m (S5 s j j i i) -> S.Stream m (S6 s j j i i (TermArg t))+--+--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 #-}+--+--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 => MkStream m S Z where- mkStream _ _ _ _ = S.singleton (ElmS Z Z)+ mkStream _ _ _ _ = S.singleton (ElmS RiZ) {-# INLINE mkStream #-} -- | For multi-dimensional terminals we need to be able to calculate how the@@ -94,8 +87,8 @@ instance TermStaticVar M Z where termStaticVar _ _ _ = Z termStreamIndex _ _ _ = Z- {-# INLINE termStaticVar #-}- {-# INLINE termStreamIndex #-}+ {-# INLINE [0] termStaticVar #-}+ {-# INLINE [0] termStreamIndex #-} instance ( TermStaticVar a is@@ -103,26 +96,26 @@ ) => TermStaticVar (TermSymbol a b) (is:.i) where termStaticVar (a:|b) (vs:.v) (is:.i) = termStaticVar a vs is :. termStaticVar b v i termStreamIndex (a:|b) (vs:.v) (is:.i) = termStreamIndex a vs is :. termStreamIndex b v i- {-# 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 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 S7 a b c d e f g = S7 !a !b !c !d !e !f !g+ {-# INLINE [0] termStaticVar #-}+ {-# INLINE [0] termStreamIndex #-} -data S8 a b c d e f g h = S8 !a !b !c !d !e !f !g !h+--data S3 a b c = S3 !a !b !c+--+--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 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 #-}+--fromTerminalStream (S6 s Z Z i o e) = ElmTS e i o s+--{-# INLINE fromTerminalStream #-} -toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s)-{-# INLINE toTerminalStream #-}+--toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s)+--{-# INLINE toTerminalStream #-} instance RuleContext Z where type Context Z = Z@@ -134,17 +127,17 @@ initialContext (is:.i) = initialContext is:.initialContext i {-# INLINE initialContext #-} -class TableStaticVar u i where- tableStaticVar :: Proxy u -> TblConstraint u -> Context i -> i -> Context i- tableStreamIndex :: Proxy u -> TblConstraint u -> Context i -> i -> i+class TableStaticVar u c i where+ tableStaticVar :: Proxy u -> c -> Context i -> i -> Context i+ tableStreamIndex :: Proxy u -> c -> Context i -> i -> i -instance TableStaticVar u Z where+instance TableStaticVar c u Z where tableStaticVar _ _ _ _ = Z tableStreamIndex _ _ _ _ = Z {-# INLINE [0] tableStaticVar #-} {-# INLINE [0] tableStreamIndex #-} -instance (TableStaticVar us is, TableStaticVar u i) => TableStaticVar (us:.u) (is:.i) where+instance (TableStaticVar us cs is, TableStaticVar u c i) => TableStaticVar (us:.u) (cs:.c) (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 #-}@@ -152,21 +145,22 @@ -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+data TermState s i e = TState+ { tS :: !s -- ^ state coming in from the left+-- , tIx :: !(RunningIndex a) -- @I/C@ index from @sS@+ , iIx :: !(RunningIndex i) -- ^ @I/C@ 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))+--getTIX :: (Element x0 a, s ~ Elm x0 a) => TermState s a i e -> RunningIndex a+--getTIX (TState s a i e) = getIdx s+--{-# Inline getTIX #-} -instance TermStream m M a Z where- termStream _ _ _ _ = id+class TermStream m t s i where+ termStream :: t -> Context i -> i -> i -> Stream m (TermState s Z Z) -> Stream m (TermState s i (TermArg t))++instance (Monad m) => TermStream m M s Z where+ termStream _ _ _ _ = id -- map (\(!s) -> s) {-# Inline termStream #-} -- |@@ -178,33 +172,55 @@ addTermStream1 :: ( Monad m- , TermStream m (TermSymbol M t) (Z:.a) (Z:.i)- , s ~ Elm x0 a- , Element x0 a+ , TermStream m (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i) )- => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,i,i)+ => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,RunningIndex i) addTermStream1 t c u i- = map (\(TState sS _ _ (Z:.ii) (Z:.oo) (Z:.ee)) -> (sS,ee,ii,oo))+ = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii)) . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i)- . map (\s -> TState s (Z:.getIdx s) (Z:.getOmx s) Z Z Z)+ . map (\s -> TState (elmTerm1 s i) RiZ Z) {-# Inline addTermStream1 #-} +newtype Term1 s = Term1 s++elmTerm1 :: s -> i -> Elm (Term1 s) (Z:.i)+elmTerm1 s _ = ElmTerm1 s+{-# Inline elmTerm1 #-}++instance (s ~ Elm x0 i, Element x0 i) => Element (Term1 s) (Z:.i) where+ newtype Elm (Term1 s) (Z:.i) = ElmTerm1 s+ getIdx (ElmTerm1 s) = RiZ :.: getIdx s+ {-# Inline getIdx #-}+ -- | @Term MkStream@ context type TmkCtx1 m ls t i = ( Monad m , MkStream m ls i- , TermStream m (TermSymbol M t) (Z:.i) (Z:.i)+ , TermStream m (TermSymbol M t) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i) , Element ls i , TermStaticVar t i ) -- | @Term TermStream@ context -type TstCtx1 m ts a is i+--type TstCtx1 m ts s sixty is i+-- = ( Monad m+-- , TermStream m ts s is+-- , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))+-- , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)+-- )++type TstCtx m ts s x0 sixty is i = ( Monad m- , TermStream m ts a is- , GetIndex a (is:.i)- , GetIx a (is:.i) ~ i+ , TermStream m ts s is+ , GetIndex (RunningIndex sixty) (RunningIndex (is:.i))+ , GetIx (RunningIndex sixty) (RunningIndex (is:.i)) ~ (RunningIndex i)+ , Element x0 sixty+ , s ~ Elm x0 sixty )++-- | Shorthand for proxifying @getIndex@++type PRI is i = Proxy (RunningIndex (is:.i))
ADP/Fusion/Base/Point.hs view
@@ -1,6 +1,7 @@ module ADP.Fusion.Base.Point where +import Data.Proxy import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) import Debug.Trace import Prelude hiding (map,filter)@@ -27,85 +28,87 @@ initialContext _ = Complemented {-# Inline initialContext #-} +newtype instance RunningIndex (PointL I) = RiPlI Int +data instance RunningIndex (PointL O) = RiPlO !Int !Int -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 #-}+data instance RunningIndex (PointL C) = RiPlC !Int -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 #-} +instance (Monad m) => MkStream m S (PointL I) where+ mkStream S (IStatic d) (PointL u) (PointL i)+ = staticCheck (i>=0 && i<=d && i<=u)+ . singleton . ElmS $ RiPlI 0+ mkStream S (IVariable _) (PointL u) (PointL i)+ = staticCheck (i>=0 && i<=u)+ . singleton . ElmS $ RiPlI 0+ {-# Inline mkStream #-} instance ( Monad m , MkStream m S is--- , 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))+ = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0)+ . staticCheck (i>=0 && i<=d && i<=u) $ mkStream S vs lus is- {-- mkStream S (vs:.IVariable ) (lus:.PointL u) (is:.PointL i)- = flatten mk step Unknown $ mkStream S vs lus is- where mk e = i `seq` return (e,i)- step (ElmS zi zo,k )- | k>=0 && k<=u = return $ Yield (ElmS (zi:.PointL k) (zo:.PointL 0)) (ElmS zi zo, -1)- | otherwise = return $ Done- {-# Inline [0] mk #-}- {-# Inline [0] step #-}- -}- -- TODO here, we have a problem in the interplay of @staticCheck@ or- -- @flatten@ and how we modify @is@. Apparently, once we demand to know- -- about @i@, fusion breaks down. mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i)- = staticCheck (i>=0 && i<=u)- $ map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))+ = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0)+ . staticCheck (i>=0 && i<=u) $ mkStream S vs lus is {-# INLINE mkStream #-} +++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 $ RiPlO i (i+d)+ mkStream S (OFirstLeft d) (PointL u) (PointL i)+ = staticCheck (i>=0 && i+d<=u) . singleton . ElmS $ RiPlO i (i+d)+ {-# Inline mkStream #-}+ instance ( Monad m , 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 zi zo) -> ElmS (zi:.PointL i) (zo:.(PointL $ i+d)))+ . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (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 zi zo) -> ElmS (zi:.PointL i) (zo:.(PointL $ i+d)))+ . map (\(ElmS zi) -> ElmS $ zi :.: RiPlO i (i+d)) $ mkStream S vs us is {-# Inline mkStream #-} -instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (PointL I) where+++instance (Monad m) => MkStream m S (PointL C) where+ mkStream S Complemented (PointL u) (PointL i)+ = staticCheck (i>=0 && i<=u) . singleton . ElmS $ RiPlC i+ {-# Inline mkStream #-}++++instance (MinSize c) => TableStaticVar u c (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)- | c==EmptyOk = PointL j- | c==NonEmpty = PointL $ j-1- | c==OnlyZero = PointL j -- this should then actually request a size in 'tableStaticVar' ...+ tableStreamIndex _ c _ (PointL j) = PointL $ j - minSize c {-# INLINE [0] tableStaticVar #-} {-# INLINE [0] tableStreamIndex #-} -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' ...+instance (MinSize c) => TableStaticVar u c (PointL O) where+ tableStaticVar _ _ (OStatic d) _ = OFirstLeft d+ tableStreamIndex _ c _ (PointL j) = PointL $ j - minSize c+ {-# INLINE [0] tableStaticVar #-}+ {-# INLINE [0] tableStreamIndex #-}++instance (MinSize c) => TableStaticVar u c (PointL C) where+ tableStaticVar _ _ Complemented _ = Complemented+ tableStreamIndex _ c _ (PointL k) = PointL $ k - minSize c {-# INLINE [0] tableStaticVar #-} {-# INLINE [0] tableStreamIndex #-}
ADP/Fusion/Base/Set.hs view
@@ -5,6 +5,7 @@ module ADP.Fusion.Base.Set where +import Data.Proxy import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr) import Debug.Trace import Prelude hiding (map,filter)@@ -18,8 +19,8 @@ -type instance TblConstraint (BitSet t) = TableConstraint-type instance TblConstraint (BS2 i j t) = TableConstraint+--type instance TblConstraint (BitSet t) = TableConstraint+--type instance TblConstraint (BS2 i j t) = TableConstraint @@ -43,8 +44,13 @@ initialContext _ = Complemented {-# Inline initialContext #-} +newtype instance RunningIndex (BitSet I) = RiBsI (BitSet I) +data instance RunningIndex (BitSet O) = RiBsO !(BitSet O) !(BitSet O) +data instance RunningIndex (BitSet C) = RiBsC !(BitSet C) !(BitSet C)++ instance RuleContext (BS2 First Last I) where type Context (BS2 First Last I) = InsideContext Int initialContext _ = IStatic 0@@ -60,8 +66,14 @@ initialContext _ = Complemented {-# Inline initialContext #-} +newtype instance RunningIndex (BS2 First Last I) = RiBs2I (BS2 First Last I) +data instance RunningIndex (BS2 First Last O) = RiBs2O !(BS2 First Last O) !(BS2 First Last O) +data instance RunningIndex (BS2 First Last C) = RiBs2C !(BS2 First Last C) !(BS2 First Last C)+++ instance ( Monad m ) => MkStream m S (BitSet I) where@@ -71,7 +83,7 @@ -- @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+ = staticCheck (rb <= ps) . map (\k -> ElmS . RiBsI $ popShiftL s k) $ unfoldr go strt where strt = Just $ BitSet $ 2^(ps - rb) - 1 ps = popCount s go Nothing = Nothing@@ -79,7 +91,7 @@ -- | 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+ = staticCheck (rb <= popCount s) . singleton . ElmS $ RiBsI 0 {-# Inline mkStream #-} -- | Initial index construction for outside Bitsets. Bits set to @0@@@ -100,11 +112,11 @@ ) => 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+ = staticCheck (rb + popCount s <= popCount u) . singleton . ElmS $ RiBsO 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+ = staticCheck (rb + popCount s <= popCount u) . singleton . ElmS $ RiBsO s s -- mkStream S (OLeftOf rp) u s -- = staticCheck (popCount s + rp <= popCount u) . singleton $ ElmS s s {-# Inline mkStream #-}@@ -117,9 +129,9 @@ ( 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+ = staticCheck (popCount s == 0 && rp == 0) . singleton . ElmS . RiBs2I $ BS2 0 (Iter i) (Iter i) mkStream S (IVariable rp) u sij@(BS2 s (Iter i) _)- = staticCheck (popCount s >= rp) . singleton $ ElmS (BS2 0 (Iter i) (Iter i)) undefbs2i+ = staticCheck (popCount s >= rp) . singleton . ElmS . RiBs2I $ BS2 0 (Iter i) (Iter i) {-# Inline mkStream #-} instance@@ -142,23 +154,23 @@ undefi = (-1) {-# Inline undefi #-} -instance TableStaticVar (u O) (BitSet O) where+instance TableStaticVar (u O) c (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 TableStaticVar c (u I) (BitSet O) where -instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (BitSet I) where+instance (MinSize c) => TableStaticVar u c (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+instance TableStaticVar c u (BS2 i j I) where -- | We sometimes need
ADP/Fusion/Base/Subword.hs view
@@ -30,8 +30,23 @@ initialContext _ = Complemented {-# Inline initialContext #-} +-- | The moving index @k@ in @Subword (i:.k)@. +newtype instance RunningIndex (Subword I) = RiSwI Int +-- | The moving indices @Inside (i:.j)@ and @Outside (k:.l)@ in order @i+-- j k l@.+--+-- TODO can we do with 2x Int?++data instance RunningIndex (Subword O) = RiSwO !Int !Int !Int !Int++-- | The indices @Subword (i:.j)@ in order @i j@.++data instance RunningIndex (Subword C) = RiSwC !Int !Int+++ -- | 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@@ -43,23 +58,27 @@ instance (Monad m) => MkStream m S (Subword I) where mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j))- = staticCheck (i>=0 && i==j && j<=h)+ -- = staticCheck (0<=i && i<=j)+ = filter (const $ 0<=i && i<=j) . singleton- $ ElmS (subword i i) (subword 0 0)+ . ElmS $ RiSwI i mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j))- = filter (const $ 0<=i && i<=j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)+ -- = staticCheck (0<=i && i<=j)+ = filter (const $ 0<=i && i<=j && j<=h)+ . singleton+ . ElmS $ RiSwI i {-# Inline mkStream #-} 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))+ = staticCheck (i==0 && j+dj==h) . singleton . ElmS $ RiSwO i j 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 (subword i' i') (subword i' i')+ in staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton . ElmS $ RiSwO i' i' 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 (subword 0 k) (subword k j))+ $ map (\k -> ElmS $ RiSwO 0 k 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 #-}@@ -70,7 +89,7 @@ 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))+ = map (\(k,l) -> ElmS $ RiSwC k l) $ unfoldr go (i,i) where go (k,l) | k >h || k >j = Nothing@@ -87,22 +106,19 @@ -- , 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))+ = staticCheck (0<=i && i==j) -- && j<=h)+ . map (\(ElmS zi) -> ElmS (zi:.:RiSwI i)) $ mkStream S vs lus ixs mkStream S (vs:.IVariable ()) (lus:.Subword (_:.h)) (ixs:.Subword (i:.j))- = map (\(ElmS zi zo) -> ElmS (zi:.subword i i) (zo:.subword 0 0))- . filter (const $ 0<=i && i<=j && j<=h)+ = map (\(ElmS zi) -> ElmS (zi:.:RiSwI i))+ . staticCheck (0<=i && i<=j) -- filter (const $ 0<=i && i<=j && j<=h) $ mkStream S vs lus ixs {-# Inline mkStream #-} -instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Subword I) where+instance (MinSize c) => TableStaticVar u c (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 ???"+ tableStreamIndex _ c _ (Subword (i:.j)) = subword i (j - minSize c) {-# INLINE [0] tableStaticVar #-} {-# INLINE [0] tableStreamIndex #-} @@ -111,7 +127,7 @@ -- -- TODO @tableStreamIndex@ needs to be fixed -instance TableStaticVar (u O) (Subword O) where+instance TableStaticVar (u O) c (Subword O) where tableStaticVar _ _ (OStatic d) _ = OFirstLeft d tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d tableStreamIndex _ c _ (Subword (i:.j)) = subword i j@@ -123,7 +139,7 @@ -- -- TODO @tableStreamIndex@ needs to be fixed -instance TableStaticVar (u I) (Subword O) where+instance TableStaticVar (u I) c (Subword O) where tableStaticVar _ _ (OStatic d) _ = ORightOf d tableStaticVar _ _ (ORightOf d) _ = ORightOf d tableStaticVar _ _ (OFirstLeft d) _ = OLeftOf d@@ -132,13 +148,13 @@ {-# INLINE [0] tableStaticVar #-} {-# INLINE [0] tableStreamIndex #-} -instance TableStaticVar (u I) (Subword C) where+instance TableStaticVar (u I) c (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+instance TableStaticVar (u O) c (Subword C) where tableStaticVar _ _ _ _ = Complemented tableStreamIndex _ c _ (Subword (i:.j)) = subword i j {-# INLINE [0] tableStaticVar #-}
ADP/Fusion/Base/TyLvlIx.hs view
@@ -8,8 +8,10 @@ import Data.PrimitiveArray hiding (map) +import ADP.Fusion.Base.Classes (RunningIndex (..)) + -- | 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@.@@ -38,6 +40,34 @@ getIndexGo _ _ _ = Z {-# Inline getIndexGo #-} +++instance GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ where+ type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) EQ = RunningIndex i+ getIndexGo (ix:.:i) _ _ = i+ {-# Inline getIndexGo #-}++instance+ ( GetIndexGo (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))+ ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT where+ type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex (my:.m)) GT = ResolvedIx (RunningIndex ix) (RunningIndex (my:.m)) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m))))+ getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex (my:.m)))))+ {-# Inline getIndexGo #-}++instance+ ( GetIndexGo (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))+ ) => GetIndexGo (RunningIndex (ix:.i)) (RunningIndex Z) GT where+ type ResolvedIx (RunningIndex (ix:.i)) (RunningIndex Z) GT = ResolvedIx (RunningIndex ix) (RunningIndex Z) (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z)))+ getIndexGo (ix:.:_) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat (RunningIndex ix)) (ToNat (RunningIndex Z))))+ {-# Inline getIndexGo #-}++instance GetIndexGo (RunningIndex Z) (RunningIndex Z) EQ where+ type ResolvedIx (RunningIndex Z) (RunningIndex Z) EQ = RunningIndex Z+ getIndexGo _ _ _ = RiZ+ {-# Inline getIndexGo #-}+++ -- | Wrap @GetIndexGo@ and the type-level shenanigans. type GetIndex l r = GetIndexGo l r (CmpNat (ToNat l) (ToNat r))@@ -64,6 +94,8 @@ type instance ToNat Z = 0 type instance ToNat (is:.i) = ToNat is + 1+type instance ToNat (RunningIndex Z) = 0+type instance ToNat (RunningIndex (is:.i)) = ToNat (RunningIndex is) + 1
ADP/Fusion/Base/Unit.hs view
@@ -32,18 +32,20 @@ initialContext _ = Complemented {-# Inline initialContext #-} +data instance RunningIndex (Unit t) = RiU + instance (Monad m) => MkStream m S (Unit I) where- mkStream S _ Unit Unit = singleton $ ElmS Unit Unit+ mkStream S _ Unit Unit = singleton $ ElmS RiU {-# Inline mkStream #-} instance (Monad m) => MkStream m S (Unit O) where- mkStream S _ Unit Unit = singleton $ ElmS Unit Unit+ mkStream S _ Unit Unit = singleton $ ElmS RiU {-# Inline mkStream #-} instance (Monad m) => MkStream m S (Unit C) where- mkStream S _ Unit Unit = singleton $ ElmS Unit Unit+ mkStream S _ Unit Unit = singleton $ ElmS RiU {-# Inline mkStream #-} instance@@ -51,7 +53,7 @@ , 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))+ = map (\(ElmS zi) -> ElmS $ zi :.: RiU) $ mkStream S vs us is {-# Inline mkStream #-} @@ -60,7 +62,7 @@ , 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))+ = map (\(ElmS zi) -> ElmS $ zi :.: RiU) $ mkStream S vs us is {-# Inline mkStream #-} @@ -69,25 +71,25 @@ , 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))+ = map (\(ElmS zi) -> ElmS $ zi :.: RiU) $ mkStream S vs us is {-# Inline mkStream #-} -instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit I) where+instance TableStaticVar c u (Unit I) where tableStaticVar _ _ _ _ = IStatic () tableStreamIndex _ _ _ _ = Unit {-# Inline [0] tableStaticVar #-} {-# Inline [0] tableStreamIndex #-} -instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit O) where+instance TableStaticVar c u (Unit O) where tableStaticVar _ _ _ _ = OStatic () tableStreamIndex _ _ _ _ = Unit {-# Inline [0] tableStaticVar #-} {-# Inline [0] tableStreamIndex #-} -instance (TblConstraint u ~ TableConstraint) => TableStaticVar u (Unit C) where+instance TableStaticVar c u (Unit C) where tableStaticVar _ _ _ _ = Complemented tableStreamIndex _ _ _ _ = Unit {-# Inline [0] tableStaticVar #-}
ADP/Fusion/SynVar/Array.hs view
@@ -23,26 +23,25 @@ -- | Constraints needed to use @iTblStream@. -type ITblCx m ls arr x u i =- ( TblConstraint u ~ TableConstraint- , TableStaticVar u i+type ITblCx m ls arr x u c i =+ ( TableStaticVar u c i , MkStream m ls i , Element ls i- , AddIndexDense (Z:.i) (Z:.u) (Z:.i)+ , AddIndexDense (Elm (SynVar1 (Elm ls i)) (Z:.i)) (Z:.u) (Z:.c) (Z:.i) , PrimArrayOps arr u x ) -- | General function for @ITbl@s with skalar indices. iTblStream- :: forall m ls arr x u i . ITblCx m ls arr x u i- => Pair ls (ITbl m arr u x)+ :: forall m ls arr x u c i . ITblCx m ls arr x u c i+ => Pair ls (ITbl m arr c u x) -> Context i -> i -> i- -> Stream m (Elm (ls :!: ITbl m arr u x) i)+ -> Stream m (Elm (ls :!: ITbl m arr c u x) i) iTblStream (ls :!: ITbl _ _ c t _) vs us is- = map (\(s,tt,ii',oo') -> ElmITbl (t!tt) ii' oo' s)+ = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' 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 #-}@@ -50,14 +49,14 @@ -- | 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)+ :: forall mB mF ls arr x r u c i . ITblCx mB ls arr x u c i+ => Pair ls (Backtrack (ITbl mF arr c u x) mF mB r) -> Context i -> i -> i- -> Stream mB (Elm (ls :!: Backtrack (ITbl mF arr u x) mF mB r) i)+ -> Stream mB (Elm (ls :!: Backtrack (ITbl mF arr c 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)+ = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' 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@@ -69,69 +68,55 @@ instance ( Monad m- , ITblCx m ls arr x u (i I)- ) => MkStream m (ls :!: ITbl m arr u x) (i I) where+ , ITblCx m ls arr x u c (i I)+ ) => MkStream m (ls :!: ITbl m arr c u x) (i I) where mkStream = iTblStream {-# Inline mkStream #-} instance ( Monad m- , ITblCx m ls arr x u (i O)- ) => MkStream m (ls :!: ITbl m arr u x) (i O) where+ , ITblCx m ls arr x u c (i O)+ ) => MkStream m (ls :!: ITbl m arr c u x) (i O) where mkStream = iTblStream {-# Inline mkStream #-} instance ( Monad m- , ITblCx m ls arr x u (i C)- ) => MkStream m (ls :!: ITbl m arr u x) (i C) where+ , ITblCx m ls arr x u c (i C)+ ) => MkStream m (ls :!: ITbl m arr c u x) (i C) where mkStream = iTblStream {-# Inline mkStream #-} instance ( Monad mB- , ITblCx mB ls arr x u (i I)- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr u x) mF mB r) (i I) where+ , ITblCx mB ls arr x u c (i I)+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr c u x) mF mB r) (i I) where mkStream = btITblStream {-# Inline mkStream #-} instance ( 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+ , ITblCx mB ls arr x u c (i O)+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr c u x) mF mB r) (i O) where mkStream = btITblStream {-# Inline mkStream #-} instance ( Monad mB- , ITblCx mB ls arr x u (i C)- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr u x) mF mB r) (i C) where+ , ITblCx mB ls arr x u c (i C)+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr c u x) mF mB r) (i C) where mkStream = btITblStream {-# Inline mkStream #-} ---instance ModifyConstraint (ITbl m arr (Subword t) x) where+instance ModifyConstraint (ITbl m arr EmptyOk i x) where+ type TNE (ITbl m arr EmptyOk i x) = ITbl m arr NonEmpty i x+ type TE (ITbl m arr EmptyOk i x) = ITbl m arr EmptyOk i x 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 #-}--instance ModifyConstraint (Backtrack (ITbl mF arr (Subword t) x) mF mB r) where+instance ModifyConstraint (Backtrack (ITbl mF arr EmptyOk i x) mF mB r) where+ type TNE (Backtrack (ITbl mF arr EmptyOk i x) mF mB r) = Backtrack (ITbl mF arr NonEmpty i x) mF mB r+ type TE (Backtrack (ITbl mF arr EmptyOk i x) mF mB r) = Backtrack (ITbl mF arr EmptyOk i x) mF mB r toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt- toEmpty (BtITbl _ arr bt) = BtITbl EmptyOk arr bt {-# Inline toNonEmpty #-}- {-# Inline toEmpty #-}--instance ModifyConstraint (Backtrack (ITbl mF arr (Z:.Subword t:.Subword t) x) mF mB r) where- toNonEmpty (BtITbl _ arr bt) = BtITbl (Z:.NonEmpty:.NonEmpty) arr bt- toEmpty (BtITbl _ arr bt) = BtITbl (Z:.EmptyOk :.EmptyOk ) arr bt- {-# Inline toNonEmpty #-}- {-# Inline toEmpty #-}
ADP/Fusion/SynVar/Array/TermSymbol.hs view
@@ -27,26 +27,26 @@ -- TODO need to handle @minSize@ conditions! instance- ( TstCtx1 m ts a is (Subword I)+ ( TstCtx m ts s x0 i0 is (Subword I) , PrimArrayOps arr (Subword I) x- ) => TermStream m (TermSymbol ts (ITbl m arr (Subword I) x)) a (is:.Subword I) where+ ) => TermStream m (TermSymbol ts (ITbl m arr c (Subword I) x)) s (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) )+ = map (\(TState s ii ee) ->+ let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))+ lj = subword l j+ in TState s (ii:.:RiSwI j) (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))+ where mk tstate@(TState s ii ee) =+ let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I)) in return (tstate, l, j - l)- step (tstate@(TState s a b ii oo ee), k, z)+ step (tstate@(TState s ii 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)+ return $ Yield (TState s (ii:.:RiSwI l) (ee:.t!kl)) (tstate, k, z-1) | otherwise = return $ Done {-# Inline [0] mk #-} {-# Inline [0] step #-}@@ -57,24 +57,24 @@ -- TODO can we combine the @ITbl@ and @BtITbl@ code again? instance- ( TstCtx1 mB ts a is (Subword I)+ ( TstCtx mB ts s x0 i0 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 mB (TermSymbol ts (Backtrack (ITbl mF arr c (Subword I) x) mF mB r)) s (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)) )+ = mapM (\(TState s ii ee) ->+ let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))+ lj = subword l j+ in bt u lj >>= \ ~bb -> return $ TState s (ii:.:RiSwI j) (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))+ where mk tstate@(TState s ii ee) =+ let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I)) in return (tstate, l, j - l)- step (tstate@(TState s a b ii oo ee), k, z)+ step (tstate@(TState s ii 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)+ bt u kl >>= \ ~bb -> return $ Yield (TState s (ii:.:RiSwI l) (ee:.(t!kl,bb))) (tstate, k, z-1) | otherwise = return $ Done {-# Inline [0] mk #-} {-# Inline [0] step #-}@@ -130,7 +130,7 @@ -- {-# Inline terminalStream #-} -instance TermStaticVar (ITbl m arr (Subword I) x) (Subword I) where+instance TermStaticVar (ITbl m arr c (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 !@@ -138,7 +138,7 @@ {-# Inline [0] termStaticVar #-} {-# Inline [0] termStreamIndex #-} -instance TermStaticVar (Backtrack (ITbl mF arr (Subword I) x) mF mB r) (Subword I) where+instance TermStaticVar (Backtrack (ITbl mF arr c (Subword I) x) mF mB r) (Subword I) where termStaticVar _ (IStatic d) _ = IVariable d termStaticVar _ (IVariable d) _ = IVariable d termStreamIndex (BtITbl _ _ _) (IStatic d) (Subword (i:.j)) = subword i j -- TODO minSize handling !
ADP/Fusion/SynVar/Array/Type.hs view
@@ -4,42 +4,42 @@ module ADP.Fusion.SynVar.Array.Type where +import Data.Proxy import Data.Strict.Tuple hiding (uncurry,snd) 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) import ADP.Fusion.Base-import ADP.Fusion.SynVar.Backtrack import ADP.Fusion.SynVar.Axiom+import ADP.Fusion.SynVar.Backtrack import ADP.Fusion.SynVar.Indices -- | Immutable table. -data ITbl m arr i x where+data ITbl m arr c i x where ITbl :: { iTblBigOrder :: !Int , iTblLittleOrder :: !Int- , iTblConstraint :: !(TblConstraint i)+ , iTblConstraint :: !c , iTblArray :: !(arr i x) , iTblFun :: !(i -> i -> m x)- } -> ITbl m arr i x+ } -> ITbl m arr c i x -instance Build (ITbl m arr i x)+instance Build (ITbl m arr c i x) -type instance TermArg (ITbl m arr i x) = x+type instance TermArg (ITbl m arr c 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])- type BacktrackIndex (ITbl mF arr i x) = i+instance GenBacktrackTable (ITbl mF arr c i x) mF mB r where+ data Backtrack (ITbl mF arr c i x) mF mB r = BtITbl !c !(arr i x) !(i -> i -> mB [r])+ type BacktrackIndex (ITbl mF arr c i x) = i toBacktrack (ITbl _ _ c arr _) _ bt = BtITbl c arr bt {-# Inline toBacktrack #-} -type instance TermArg (Backtrack (ITbl mF arr i x) mF mB r) = (x,[r])+type instance TermArg (Backtrack (ITbl mF arr c i x) mF mB r) = (x,[r]) @@ -49,8 +49,8 @@ ( Monad m , PrimArrayOps arr i x , IndexStream i- ) => Axiom (ITbl m arr i x) where- type AxiomStream (ITbl m arr i x) = m x+ ) => Axiom (ITbl m arr c i x) where+ type AxiomStream (ITbl m arr c i x) = m x axiom (ITbl _ _ c arr _) = do k <- (head . uncurry streamDown) $ bounds arr return $ arr ! k@@ -60,8 +60,8 @@ ( Monad mB , PrimArrayOps arr i x , IndexStream i- ) => Axiom (Backtrack (ITbl mF arr i x) mF mB r) where- type AxiomStream (Backtrack (ITbl mF arr i x) mF mB r) = mB [r]+ ) => Axiom (Backtrack (ITbl mF arr c i x) mF mB r) where+ type AxiomStream (Backtrack (ITbl mF arr c i x) mF mB r) = mB [r] axiom (BtITbl c arr bt) = do h <- (head . uncurry streamDown) $ bounds arr bt (snd $ bounds arr) h@@ -71,36 +71,32 @@ -- * '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- type RecElm (ls :!: ITbl m arr j x) i = Elm ls i- getArg (ElmITbl x _ _ ls) = getArg ls :. x- getIdx (ElmITbl _ i _ _ ) = i- getOmx (ElmITbl _ _ o _ ) = o- getElm (ElmITbl _ _ _ ls) = ls+instance Element ls i => Element (ls :!: ITbl m arr c j x) i where+ data Elm (ls :!: ITbl m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i)+ type Arg (ls :!: ITbl m arr c j x) = Arg ls :. x+ type RecElm (ls :!: ITbl m arr c j x) i = Elm ls i+ getArg (ElmITbl x _ ls) = getArg ls :. x+ getIdx (ElmITbl _ i _ ) = i+ getElm (ElmITbl _ _ ls) = ls {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} {-# Inline getElm #-} -deriving instance (Show i, Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr j x) i)+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr c j x) i) -instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i where- data Elm (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i = ElmBtITbl !x [r] !i !i !(Elm ls i)- type Arg (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) = Arg ls :. (x, [r])- type RecElm (ls :!: (Backtrack (ITbl mF arr j x) mF mB r)) i = Elm ls i- getArg (ElmBtITbl x s _ _ ls) = getArg ls :. (x,s)- getIdx (ElmBtITbl _ _ i _ _ ) = i- getOmx (ElmBtITbl _ _ _ o _ ) = o- getElm (ElmBtITbl _ _ _ _ ls) = ls+instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r)) i where+ data Elm (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r)) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i)+ type Arg (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r)) = Arg ls :. (x, [r])+ type RecElm (ls :!: (Backtrack (ITbl mF arr c j x) mF mB r)) i = Elm ls i+ getArg (ElmBtITbl x s _ ls) = getArg ls :. (x,s)+ getIdx (ElmBtITbl _ _ i _ ) = i+ getElm (ElmBtITbl _ _ _ ls) = ls {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} {-# Inline getElm #-} -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+instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: (Backtrack (ITbl mF arr c i x) mF mB r)) i) where+ show (ElmBtITbl x _ i s) = show (x,i) ++ " " ++ show s @@ -109,13 +105,13 @@ instance ( Monad m , Element ls (is:.i)- , TableStaticVar (us:.u) (is:.i)- , AddIndexDense (is:.i) (us:.u) (is:.i)+ , TableStaticVar (us:.u) (cs:.c) (is:.i)+ , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i) , MkStream m ls (is:.i) , PrimArrayOps arr (us:.u) x- ) => MkStream m (ls :!: ITbl m arr (us:.u) x) (is:.i) where+ ) => MkStream m (ls :!: ITbl m arr (cs:.c) (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)+ = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' 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 #-}@@ -123,52 +119,15 @@ instance ( Monad mB , Element ls (is:.i)- , TableStaticVar (us:.u) (is:.i)- , AddIndexDense (is:.i) (us:.u) (is:.i)+ , TableStaticVar (us:.u) (cs:.c) (is:.i)+ , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i) , MkStream mB ls (is:.i) , PrimArrayOps arr (us:.u) x- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (us:.u) x) mF mB r) (is:.i) where+ ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (cs:.c) (us:.u) x) mF mB r) (is:.i) where mkStream (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)+ = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' 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))- , TableStaticVar (Outside (is:.i))- , TableIndices (Outside (is:.i))- , MkStream m ls (Outside (is:.i))- , PrimArrayOps arr (Outside (is:.i)) x- , Show (is:.i)- ) => MkStream m (ls :!: ITbl m arr (Outside (is:.i)) x) (Outside (is:.i)) where- mkStream (ls :!: ITbl _ _ c t _) vs lu is- = map (\(S5 s _ _ i o) -> ElmITbl (t ! o) 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)- {-# Inline mkStream #-}--}--{--instance- ( Monad mB- , Element ls (Outside (is:.i))- , TableStaticVar (Outside (is:.i))- , TableIndices (Outside (is:.i))- , MkStream mB ls (Outside (is:.i))- , PrimArrayOps arr (Outside (is:.i)) x- , Show (is:.i)- ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside (is:.i)) x) mF mB r) (Outside (is:.i)) where- mkStream (ls :!: BtITbl c t bt) vs us is- = mapM (\(S5 s _ _ i o) -> bt us o >>= \bb -> return $ ElmBtITbl (t ! o) (bb {-bt us o-}) 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)- {-# Inline mkStream #-}--}-
ADP/Fusion/SynVar/Fill.hs view
@@ -17,6 +17,7 @@ import Data.PrimitiveArray import ADP.Fusion.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules+import ADP.Fusion.SynVar.Recursive import Debug.Trace @@ -94,21 +95,42 @@ {-# Inline tableLittleOrder #-} {-# Inline tableBigOrder #-} -instance (TableOrder ts) => TableOrder (ts:.ITbl im arr i x) where+instance (TableOrder ts) => TableOrder (ts:.ITbl im arr c i x) where tableLittleOrder (ts:.ITbl _ tlo _ _ _) = tlo : tableLittleOrder ts tableBigOrder (ts:.ITbl tbo _ _ _ _) = tbo : tableBigOrder ts {-# Inline tableLittleOrder #-} {-# Inline tableBigOrder #-} +-- | @IRec@s do not need an order, given that they do not memoize.++instance (TableOrder ts) => TableOrder (ts:.IRec im c i x) where+ tableLittleOrder (ts:._) = tableLittleOrder ts+ tableBigOrder (ts:._) = tableBigOrder ts+ {-# Inline tableLittleOrder #-}+ {-# Inline tableBigOrder #-}+ -- ** individual instances for filling a *single cell* instance+ ( Monad om+ ) => MutateCell p Z im om i where+ mutateCell _ _ _ _ Z _ _ = return ()+ {-# INLINE mutateCell #-}++instance+ ( MutateCell CFG ts im om i+ , PrimMonad om+ ) => MutateCell CFG (ts:.IRec im c i x) im om i where+ mutateCell h bo lo mrph (ts:._) lu i = do+ mutateCell h bo lo mrph ts lu i+ {-# Inline mutateCell #-}++instance ( PrimArrayOps arr i x , MPrimArrayOps arr i x , MutateCell CFG ts im om i , PrimMonad om- , Show x, Show i- ) => MutateCell CFG (ts:.ITbl im arr i x) im om i where+ ) => MutateCell CFG (ts:.ITbl im arr c i x) im om i where mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu i = do mutateCell h bo lo mrph ts lu i when (bo==tbo && lo==tlo) $ do@@ -124,7 +146,7 @@ , MPrimArrayOps arr ZS2 x , MutateCell MonotoneMCFG ts im om ZS2 , PrimMonad om- ) => MutateCell MonotoneMCFG (ts:.ITbl im arr ZS2 x) im om ZS2 where+ ) => MutateCell MonotoneMCFG (ts:.ITbl im arr c ZS2 x) im om ZS2 where mutateCell h bo lo mrph (ts:.ITbl tbo tlo c arr f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do mutateCell h bo lo mrph ts lu iklj when (bo==tbo && lo==tlo && k<=l) $ do@@ -138,7 +160,7 @@ , MPrimArrayOps arr (Subword I) x , MutateCell h ts im om (Z:.Subword I:.Subword I) , PrimMonad om- ) => MutateCell h (ts:.ITbl im arr (Subword I) x) im om (Z:.Subword I:.Subword I) where+ ) => MutateCell h (ts:.ITbl im arr c (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@@ -156,30 +178,27 @@ instance ( Monad om- , MutateCell h (ts:.ITbl im arr i x) im om i+ , MutateCell h (ts:.ITbl im arr c i x) im om i , PrimArrayOps arr i x , Show i , IndexStream i- , TableOrder (ts:.ITbl im arr i x)- ) => MutateTables h (ts:.ITbl im arr i x) im om where+ , TableOrder (ts:.ITbl im arr c i x)+ ) => MutateTables h (ts:.ITbl im arr c i x) im om where mutateTables h mrph tt@(_:.ITbl _ _ _ arr _) = do let (from,to) = bounds arr -- TODO (1) find the set of orders for the synvars let !tbos = VU.fromList . nub . sort $ tableBigOrder tt let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt VU.forM_ tbos $ \bo ->- flip SM.mapM_ (streamUp from to) $ \k ->- VU.forM_ tlos $ \lo ->- --traceShow (bo,k,lo) $- mutateCell h bo lo (inline mrph) tt to k+ case (VU.length tlos) of+ 1 -> let lo = VU.head tlos+ in flip SM.mapM_ (streamUp from to) $ \k ->+ mutateCell h bo lo (inline mrph) tt to k+ _ -> flip SM.mapM_ (streamUp from to) $ \k ->+ VU.forM_ tlos $ \lo ->+ mutateCell h bo lo (inline mrph) tt to k return tt {-# INLINE mutateTables #-}--instance- ( Monad om- ) => MutateCell p Z im om i where- mutateCell _ _ _ _ Z _ _ = return ()- {-# INLINE mutateCell #-} -- | Default table filling, assuming that the forward monad is just @IO@. --
ADP/Fusion/SynVar/Indices/Classes.hs view
@@ -6,6 +6,7 @@ module ADP.Fusion.SynVar.Indices.Classes where +import Data.Proxy (Proxy(..)) import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,flatten,Step(..)) import Prelude hiding (map,head,mapM) @@ -19,12 +20,12 @@ -- 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+class AddIndexDense s u c 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)+ => c -> Context i -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i) -instance AddIndexDense a Z Z where+instance AddIndexDense a Z Z Z where addIndexDenseGo _ _ _ _ = id {-# Inline addIndexDenseGo #-} @@ -34,12 +35,10 @@ -- 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+ { sS :: !s -- ^ state coming in from the left+-- , sIx :: !(RunningIndex a) -- @I/C@ index from @sS@+ , tx :: !u -- ^ @I/C@ building up state to index the @table@.+ , iIx :: !(RunningIndex i) -- ^ @I/C@ building up state to hand over to next symbol } @@ -48,13 +47,12 @@ addIndexDense :: ( Monad m- , AddIndexDense a u i- , GetIndex a i- , s ~ Elm x0 a- , Element x0 a+ , AddIndexDense s u c i+ , s ~ Elm x0 i0+ , Element x0 i0 )- => 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))+ => c -> Context i -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)+addIndexDense t c u i = map (\(SvS s z i') -> (s,z,i')) . addIndexDenseGo t c u i . map (\s -> (SvS s Z RiZ)) {-# Inline addIndexDense #-} -- | In case of 1-dim tables, we wrap the index creation in a multi-dim@@ -63,14 +61,36 @@ addIndexDense1 :: ( Monad m- , AddIndexDense (Z:.a) (Z:.u) (Z:.i)+ , AddIndexDense (Elm (SynVar1 (Elm x0 a)) (Z:.i)) (Z:.u) (Z:.c) (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'))+ => c -> Context i -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i)+addIndexDense1 t c u i = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i')) . addIndexDenseGo (Z:.t) (Z:.c) (Z:.u) (Z:.i)- . map (\s -> (SvS s (Z:.getIdx s) (Z:.getOmx s) Z Z Z))+ . map (\s -> (SvS (elmSynVar1 s i) Z RiZ)) {-# Inline addIndexDense1 #-}++newtype SynVar1 s = SynVar1 s++elmSynVar1 :: s -> i -> Elm (SynVar1 s) (Z:.i)+elmSynVar1 s _ = ElmSynVar1 s+{-# Inline elmSynVar1 #-}++instance (s ~ Elm x0 i, Element x0 i) => Element (SynVar1 s) (Z:.i) where+ newtype Elm (SynVar1 s) (Z:.i) = ElmSynVar1 s+ getIdx (ElmSynVar1 s) = RiZ :.: getIdx s+ {-# Inline getIdx #-}+++-- | Instance headers, we typically need.++type IndexHdr s x0 i0 us u cs c is i =+ ( AddIndexDense s us cs is+ , GetIndex (RunningIndex i0) (RunningIndex (is:.i))+ , GetIx (RunningIndex i0) (RunningIndex (is:.i)) ~ (RunningIndex i)+ , Element x0 i0+ , s ~ Elm x0 i0+ )
ADP/Fusion/SynVar/Indices/Point.hs view
@@ -4,6 +4,7 @@ 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.PrimitiveArray hiding (map)@@ -14,60 +15,48 @@ 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+ ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL I)+ , MinSize c+ ) => AddIndexDense s (us:.PointL I) (cs:.c) (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))+ = map (\(SvS s t y') -> SvS s (t:.i) (y' :.: RiPlI (fromPointL i))) . 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))+ where mk svS = let RiPlI k = getIndex (getIdx $ sS svS {- sIx svS -} ) (Proxy :: PRI is (PointL I)) in return $ svS :. k- step (svS@(SvS s a b t y' z') :. k)+ step (svS@(SvS s t y') :. 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)+ | otherwise = return $ Yield (SvS s (t:.PointL k) (y' :.: RiPlI k)) (svS :. k+1)+ where csize = minSize c {-# 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))+ ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL O)+ ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL O) where+ addIndexDenseGo (cs:._) (vs:.OStatic d) (us:.u) (is:.i)+ = map (\(SvS s t y') -> let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+ in SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) ) . 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))+ ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL C)+ ) => AddIndexDense s (us:.PointL I) (cs:.c) (is:.PointL C) where+ addIndexDenseGo (cs:._) (vs:.Complemented) (us:.u) (is:.i)+ = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))+ in SvS s (t:.PointL k) (y :.: RiPlC k) ) . 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))+ ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL C)+ ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL C) where+ addIndexDenseGo (cs:._) (vs:.Complemented) (us:.u) (is:.i)+ = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C))+ in SvS s (t:.PointL k) (y:.:RiPlC k) ) . addIndexDenseGo cs vs us is {-# Inline addIndexDenseGo #-}
ADP/Fusion/SynVar/Indices/Set0.hs view
@@ -27,10 +27,9 @@ -- 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+ ( IndexHdr s x0 i0 us (BitSet I) cs c is (BitSet I)+ , MinSize c+ ) => AddIndexDense s (us:.BitSet I) (cs:.c) (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@@@ -45,11 +44,11 @@ -- 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)+ | otherwise = 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))+ RiBsI l = getIndex (getIdx $ sS svS) (Proxy :: PRI 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@@ -62,15 +61,15 @@ -- -- 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))+ step (Just (svS@(SvS s t y') :. 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))+ RiBsI aa = getIndex (getIdx s) (Proxy :: PRI is (BitSet I))+ in return $ Yield (SvS s (t:.kk) (y' :.: RiBsI (kk.|.aa))) ((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+ !csize = minSize c -- minimal set size via constraints {-# Inline [0] mk #-} {-# Inline [0] step #-} addIndexDenseGo (cs:.c) (vs:.IVariable rb) (us:.u) (is:.i)@@ -80,24 +79,25 @@ -- 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)+ | csize==0 = return $ Just (svS :. mask :. cm :. csize)+ | cm == 0 = return $ Nothing+ | csize==1 = return $ Just (svS :. mask :. cm :. csize) where mask = i `xor` l cm = popCount mask- l = getIndex (sIx svS) (Proxy :: Proxy (is:.BitSet I))- step Nothing = return $ Done+ RiBsI l = getIndex (getIdx $ sS svS) (Proxy :: PRI is (BitSet I))+ csize = BitSet $ minSize c -- 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))+ step Nothing = return $ Done+ step (Just (svS@(SvS s t y') :. 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))+ | otherwise = return $ Yield (SvS s (t:.kk) (y' :.: RiBsI (kk.|.l))) ((svS :. mask :. cm :.) <$> setSucc 0 (2^cm -1) k) where kk = popShiftL mask k- l = getIndex a (Proxy :: Proxy (is:.BitSet I))+ RiBsI l = getIndex (getIdx s) (Proxy :: PRI is (BitSet I)) {-# Inline [0] mk #-} {-# Inline [0] step #-} {-# Inline addIndexDenseGo #-}@@ -107,21 +107,19 @@ -- 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+ ( IndexHdr s x0 i0 us (BitSet O) cs c is (BitSet O)+ , MinSize c+ ) => AddIndexDense s (us:.BitSet O) (cs:.c) (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+ | rb + popCount bso >= 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)+ where RiBsO bsi bso = getIndex (getIdx $ sS svS) (Proxy :: PRI is (BitSet O))+ mask = u `xor` bso -- 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@@ -129,18 +127,17 @@ -- @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))+ step (Just (svS@(SvS s t y') :. 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))+ let RiBsO bsi bso = getIndex (getIdx s) (Proxy :: PRI 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))+ tt = kk .|. bso -- the (smaller, more @1@ bits) lookup index+ in return $ Yield (SvS s (t:.tt) (y' :.: RiBsO bsi tt)) ((svS :. mask :.) <$> setSucc 0 (2^rb -1) k) where pk = popCount k- csize = delay_inline minSize c+ csize = minSize c {-# Inline [0] mk #-} {-# Inline [0] step #-} addIndexDenseGo (cs:.c) (vs:.ORightOf rb) (us:.u) (is:.i)@@ -150,10 +147,10 @@ -- | instance- ( AddIndexDense a us is+ ( AddIndexDense a us cs is , GetIndex a (is:.BitSet O) , GetIx a (is:.BitSet O) ~ (BitSet O)- ) => AddIndexDense a (us:.BitSet I) (is:.BitSet O) where+ ) => AddIndexDense a (us:.BitSet I) (cs:.c) (is:.BitSet O) where -- addIndexDenseGo (cs:.c) (vs:.OFirstLeft rb) (us:.u) (is:.i) -- = error "ping" {-# Inline addIndexDenseGo #-}
ADP/Fusion/SynVar/Indices/Subword.hs view
@@ -33,29 +33,26 @@ -- @ 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+ ( IndexHdr s x0 i0 us (Subword I) cs c is (Subword I)+ , MinSize c+ ) => AddIndexDense s (us:.Subword I) (cs:.c) (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))+ = id -- staticCheck (j<=u)+ . map (\(SvS s t y') -> let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))+ lj = subword l j+ in SvS s (t:.lj) (y' :.: RiSwI j) ) . addIndexDenseGo cs vs us is addIndexDenseGo (cs:.c) (vs:.IVariable ()) (us:.Subword (_:.u)) (is:.Subword (i:.j))- = staticCheck (j<=u)+ = seq csize . id -- 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))+ where mk svS = let RiSwI l = getIndex (getIdx $ sS svS) (Proxy :: PRI 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))+ step (svS@(SvS s t y') :. zz)+ | zz >= 0 = do let RiSwI k = getIndex (getIdx s) (Proxy :: PRI 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)+ return $ Yield (SvS s (t:.kl) (y' :.: RiSwI l)) (svS :. zz-1) | otherwise = return $ Done- csize = delay_inline minSize c+ !csize = minSize c {-# Inline [0] mk #-} {-# Inline [0] step #-} {-# Inline addIndexDenseGo #-}@@ -70,26 +67,21 @@ -- 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+ ( IndexHdr s x0 i0 us (Subword O) cs c is (Subword O)+ ) => AddIndexDense s (us:.Subword O) (cs:.c) (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))+ = map (\(SvS s t y') -> let RiSwO _ _ k _ = getIndex (getIdx s) (Proxy :: PRI is (Subword O))+ kj = subword k (j+dj)+ in SvS s (t:.kj) (y' :.: RiSwO i j k (j+dj)) ) . 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))+ step (svS@(SvS s t y') :. l)+ | l <= h = let RiSwO k _ _ _ = getIndex (getIdx s) (Proxy :: PRI 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)+ jdj = j+dj+ in return $ Yield (SvS s (t:.kl) (y' :.: RiSwO jdj jdj k l)) (svS :. l+1) | otherwise = return Done {-# Inline [0] mk #-} {-# Inline [0] step #-}@@ -106,52 +98,40 @@ -- 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+ ( IndexHdr s x0 i0 us (Subword I) cs c is (Subword O)+ , MinSize c+ ) => AddIndexDense s (us:.Subword I) (cs:.c) (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))+ = map (\(SvS s t y') -> let RiSwO _ k li l = getIndex (getIdx s) (Proxy :: PRI is (Subword O))+ klI = subword (k-dj) (l-dj)+ in SvS s (t:.klI) (y':.:RiSwO (k-dj) (l-dj) li l)) . 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))+ where mk svS = let RiSwO _ l _ _ = getIndex (getIdx $ sS svS) (Proxy :: PRI 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))+ step (svS@(SvS s t y') :. k :. l)+ | l <= oj = return $ Yield (SvS s (t:.klI) (y' :.: RiSwO k l oi oj)) (svS :. k :. l+1) | otherwise = return $ Done- where zo@(Subword (_:.o)) = getIndex b (Proxy :: Proxy (is:.Subword O))+ where RiSwO _ _ oi oj = getIndex (getIdx s) (Proxy :: PRI 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))+ = map (\(SvS s t y') -> let RiSwO _ k l lj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))+ klI = subword k $ i - di+ in SvS s (t:.klI) (y' :.: RiSwO k (i-di) l lj)) . 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))+ where mk svS = let RiSwO _ l _ _ = getIndex (getIdx $ sS svS) (Proxy :: PRI 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))+ step (svS@(SvS s t y') :. l)+ | l <= i = let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI 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))+ in return $ Yield (SvS s (t:.klI) (y' :.: RiSwO k l oi oj)) (svS :. l+1) | otherwise = return $ Done csize = minSize c@@ -169,15 +149,11 @@ -- @ 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+ ( IndexHdr s x0 i0 us (Subword I) cs c is (Subword C)+ ) => AddIndexDense s (us:.Subword I) (cs:.c) (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))+ = map (\(SvS s t y') -> let kk@(RiSwC ki kj) = getIndex (getIdx s) (Proxy :: PRI is (Subword C))+ in SvS s (t:.subword ki kj) (y':.:kk)) . addIndexDenseGo cs vs us is {-# Inline addIndexDenseGo #-} @@ -188,15 +164,11 @@ -- @ 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+ ( IndexHdr s x0 i0 us (Subword O) cs c is (Subword C)+ ) => AddIndexDense s (us:.Subword O) (cs:.c) (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))+ = map (\(SvS s t y') -> let kk@(RiSwC ki kj) = getIndex (getIdx s) (Proxy :: PRI is (Subword C))+ in SvS s (t:.subword ki kj) (y':.:kk)) . addIndexDenseGo cs vs us is {-# Inline addIndexDenseGo #-} @@ -207,14 +179,13 @@ -- @ 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+ ( IndexHdr s x0 i0 us (Subword C) cs c is (Subword C)+ ) => AddIndexDense s (us:.Subword C) (cs:.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))+ = map (\(SvS s t y') -> let k = getIndex (getIdx s) (Proxy :: PRI is (Subword C))+ RiSwC ki kj = k+ in SvS s (t:.subword ki kj) (y':.:k)) . addIndexDenseGo cs vs us is {-# Inline addIndexDenseGo #-}+
ADP/Fusion/SynVar/Indices/Unit.hs view
@@ -17,42 +17,34 @@ 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+ ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit I)+ ) => AddIndexDense s (us:.Unit I) (cs:.c) (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))+ = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) . 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+ ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit O)+ ) => AddIndexDense s (us:.Unit O) (cs:.c) (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))+ = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) . 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+ ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit C)+ ) => AddIndexDense s (us:.Unit I) (cs:.c) (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))+ = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) . 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+ ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit C)+ ) => AddIndexDense s (us:.Unit O) (cs:.c) (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))+ = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) . addIndexDenseGo cs vs us is {-# Inline addIndexDenseGo #-}
ADP/Fusion/SynVar/Recursive/Type.hs view
@@ -1,80 +1,111 @@ module ADP.Fusion.SynVar.Recursive.Type where -import Data.Strict.Tuple ((:!:)(..))-import Data.Vector.Fusion.Stream.Monadic (Stream,head)-import Prelude hiding (head)+import Control.Monad.Morph+import Data.Proxy+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic (Stream,head,map,mapM)+import Prelude hiding (head,map,mapM) import Data.PrimitiveArray hiding (map) import ADP.Fusion.Base-import ADP.Fusion.SynVar.Backtrack import ADP.Fusion.SynVar.Axiom+import ADP.Fusion.SynVar.Backtrack+import ADP.Fusion.SynVar.Indices -data IRec m i x where- IRec :: { iRecConstraint :: !(TblConstraint i)+-- | A syntactic variable that does not memoize but simplify recurses. One+-- needs to be somewhat careful when using this one. @ITbl@ performs+-- memoization to perform DP in polynomial time (roughly speaking). If the+-- rules for an @IRec@ are of a particular type, they will exponential+-- running time. Things like @X -> X X@ are, for example, rather bad. Rules+-- of the type @X -> Y, Y -> Z@ are ok, if @Y@ is an @IRec@ since we just+-- continue on. The same holds for @Y -> a Y@. Basically, things are safe+-- if there is only a (small) constant number of parses of an @IRec@+-- synvar.++data IRec m c i x where+ IRec :: { iRecConstraint :: !c , iRecFrom :: !i , iRecTo :: !i , iRecFun :: !(i -> i -> m x)- } -> IRec m i x-+ } -> IRec m c i x +instance Build (IRec m c i x) -instance Build (IRec m i x)+type instance TermArg (IRec m c i x) = x -instance GenBacktrackTable (IRec mF i x) mF mB r where- data Backtrack (IRec mF i x) mF mB r = BtIRec !(TblConstraint i) !i !i (i -> i -> mB x) (i -> i -> mB [r]) -- (Stream mB r))- type BacktrackIndex (IRec mF i x) = i+instance GenBacktrackTable (IRec mF c i x) mF mB r where+ data Backtrack (IRec mF c i x) mF mB r = BtIRec !c !i !i !(i -> i -> mB x) !(i -> i -> mB [r])+ type BacktrackIndex (IRec mF c i x) = i toBacktrack (IRec c iF iT f) mrph bt = BtIRec c iF iT (\lu i -> mrph $ f lu i) bt- {-# INLINE toBacktrack #-}+ {-# Inline toBacktrack #-} instance ( Monad m , IndexStream i- ) => Axiom (IRec m i x) where- type AxiomStream (IRec m i x) = m x- axiom (IRec c l h fun) = do- k <- (head . uncurry streamDown) (l,h)+ ) => Axiom (IRec m c i x) where+ type AxiomStream (IRec m c i x) = m x+ axiom (IRec _ l h fun) = do+ k <- head $ streamDown l h fun h k {-# Inline axiom #-} instance ( Monad mB , IndexStream i- ) => Axiom (Backtrack (IRec mF i x) mF mB r) where- type AxiomStream (Backtrack (IRec mF i x) mF mB r) = mB [r] -- (Stream mB r)+ ) => Axiom (Backtrack (IRec mF c i x) mF mB r) where+ type AxiomStream (Backtrack (IRec mF c i x) mF mB r) = mB [r] axiom (BtIRec c l h fun btfun) = do- k <- (head . uncurry streamDown) (l,h)+ k <- head $ streamDown l h btfun h k {-# Inline axiom #-} -instance Element ls i => Element (ls :!: IRec m i x) i where- data Elm (ls :!: IRec m i x) i = ElmIRec !x !i !i !(Elm ls i)- type Arg (ls :!: IRec m i x) = Arg ls :. x- getArg (ElmIRec x _ _ ls) = getArg ls :. x- getIdx (ElmIRec _ i _ _ ) = i- getOmx (ElmIRec _ _ o _ ) = o+instance Element ls i => Element (ls :!: IRec m c u x) i where+ data Elm (ls :!: IRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i)+ type Arg (ls :!: IRec m c u x) = Arg ls :. x+ getArg (ElmIRec x _ ls) = getArg ls :. x+ getIdx (ElmIRec _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} -instance Element ls i => Element (ls :!: (Backtrack (IRec mF i x) mF mB r)) i where- data Elm (ls :!: (Backtrack (IRec mF i x) mF mB r)) i = ElmBtIRec !x !(mB (Stream mB r)) !i !i !(Elm ls i)- type Arg (ls :!: (Backtrack (IRec mF i x) mF mB r)) = Arg ls :. (x, mB (Stream mB r))- getArg (ElmBtIRec x s _ _ ls) = getArg ls :. (x,s)- getIdx (ElmBtIRec _ _ i _ _ ) = i- getOmx (ElmBtIRec _ _ _ o _ ) = o+instance Element ls i => Element (ls :!: (Backtrack (IRec mF c u x) mF mB r)) i where+ data Elm (ls :!: (Backtrack (IRec mF c u x) mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i)+ type Arg (ls :!: (Backtrack (IRec mF c u x) mF mB r)) = Arg ls :. (x, [r])+ getArg (ElmBtIRec x s _ ls) = getArg ls :. (x,s)+ getIdx (ElmBtIRec _ _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} -+instance+ ( Monad m+ , Element ls (is:.i)+ , TableStaticVar (us:.u) (cs:.c) (is:.i)+ , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i)+ , MkStream m ls (is:.i)+ ) => MkStream m (ls :!: IRec m (cs:.c) (us:.u) x) (is:.i) where+ mkStream (ls :!: IRec c l h fun) vs us is+ = mapM (\(s,tt,ii) -> (\res -> ElmIRec res ii s) <$> fun h tt)+ . 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 #-} --- TODO write multi-tape instances+instance+ ( Monad mB+ , Element ls (is:.i)+ , TableStaticVar (us:.u) (cs:.c) (is:.i)+ , AddIndexDense (Elm ls (is:.i)) (us:.u) (cs:.c) (is:.i)+ , MkStream mB ls (is:.i)+ ) => MkStream mB (ls :!: Backtrack (IRec mF (cs:.c) (us:.u) x) mF mB r) (is:.i) where+ mkStream (ls :!: BtIRec c l h fun bt) vs us is+ = mapM (\(s,tt,ii) -> (\res bb -> ElmBtIRec res bb ii s) <$> fun h tt <*> bt h tt)+ . 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 #-}
ADP/Fusion/SynVar/Split/Subword.hs view
@@ -32,18 +32,18 @@ ( Monad m , Element ls (Subword I) , MkStream m ls (Subword I)- ) => MkStream m (ls :!: Split uId Fragment (ITbl m arr j x)) (Subword I) where+ ) => MkStream m (ls :!: Split uId Fragment (ITbl m arr c 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)+ = map (\s -> let RiSwI l = getIdx s+ in ElmSplitITbl Proxy () (RiSwI j) 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 $ 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- kl = subword k l- return $ Yield (ElmSplitITbl Proxy () kl (subword 0 0) s) (s:. z-1)+ where mk s = let RiSwI l = getIdx s in return (s :. j - l) -- TODO - minSize c)+ step (s:.z) | z >= 0 = do let RiSwI k = getIdx s+ l = j - z+ kl = subword k l+ return $ Yield (ElmSplitITbl Proxy () (RiSwI l) s) (s:. z-1) | otherwise = return $ Done {-# Inline [0] mk #-} {-# Inline [0] step #-}@@ -56,20 +56,21 @@ , 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+ , MinSize c+ ) => MkStream m (ls :!: Split uId Final (ITbl m arr (cs:.c) mix x)) (Subword I) where mkStream (ls :!: Split (ITbl _ _ (_:.c) t elm)) (IStatic ()) hh (Subword (i:.j))- = map (\s -> let (Subword (_:.l)) = getIdx s+ = map (\s -> let RiSwI 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)+ in ElmSplitITbl Proxy (t ! fmbkm) (RiSwI j) s) $ 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- fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. kl- return $ Yield (ElmSplitITbl Proxy (t ! fmbkm) kl (subword 0 0) s) (s:. z-1)+ where mk s = let RiSwI l = getIdx s in return (s :. (delay_inline id $ j - l - minSize c))+ step (s:.z) | z >= 0 = do let RiSwI k = getIdx s+ l = j - z+ kl = subword k l+ fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. kl+ return $ Yield (ElmSplitITbl Proxy (t ! fmbkm) (RiSwI l) s) (s:. z-1) | otherwise = return $ Done {-# Inline [0] mk #-} {-# Inline [0] step #-}@@ -83,18 +84,18 @@ ( Monad mB , 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 mB (ls :!: Split uId Fragment (Backtrack (ITbl mF arr c 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)+ = map (\s -> let RiSwI l = getIdx s+ in ElmSplitBtITbl Proxy () (RiSwI j) 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 $ 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- kl = subword k l- return $ Yield (ElmSplitBtITbl Proxy () kl (subword 0 0) s) (s:. z-1)+ where mk s = let RiSwI l = getIdx s in return (s :. j - l) -- TODO - minSize c)+ step (s:.z) | z >= 0 = do let RiSwI k = getIdx s+ l = j - z+ kl = subword k l+ return $ Yield (ElmSplitBtITbl Proxy () (RiSwI l) s) (s:. z-1) | otherwise = return $ Done {-# Inline [0] mk #-} {-# Inline [0] step #-}@@ -107,23 +108,24 @@ , 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+ , MinSize c+ ) => MkStream mB (ls :!: Split uId Final (Backtrack (ITbl mF arr (cs:.c) 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)+ = mapM (\s -> let RiSwI 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) (RiSwI j) s) $ 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- fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. kl- (_,hhhh) = bounds t -- same ugly hack- bt hhhh fmbkm >>= \ ~bb -> return $ Yield (ElmSplitBtITbl Proxy (t ! fmbkm,bb) kl (subword 0 0) s) (s:. z-1)+ where mk s = let RiSwI l = getIdx s in return (s :. (delay_inline id $ j - l - minSize c))+ step (s:.z) | z >= 0 = do let RiSwI k = getIdx s+ l = j - z+ kl = subword k l+ fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. kl+ (_,hhhh) = bounds t -- same ugly hack+ bt hhhh fmbkm >>= \ ~bb -> return $ Yield (ElmSplitBtITbl Proxy (t ! fmbkm,bb) (RiSwI l) s) (s:. z-1) | otherwise = return $ Done {-# Inline [0] mk #-} {-# Inline [0] step #-}
ADP/Fusion/SynVar/Split/Type.hs view
@@ -58,9 +58,9 @@ 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 #-}+--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 @@ -68,32 +68,28 @@ instance ( Element ls i- ) => Element (ls :!: Split uId splitType (ITbl m arr j x)) i where- data Elm (ls :!: Split uId splitType (ITbl m arr j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !i !i !(Elm ls i)- type Arg (ls :!: Split uId splitType (ITbl m arr j x)) = Arg ls :. (CalcSplitType splitType x)- type RecElm (ls :!: Split uId splitType (ITbl m arr j x)) i = Elm ls i- getArg (ElmSplitITbl _ x _ _ ls) = getArg ls :. x- getIdx (ElmSplitITbl _ _ i _ _ ) = i- getOmx (ElmSplitITbl _ _ _ o _ ) = o- getElm (ElmSplitITbl _ _ _ _ ls) = ls+ ) => Element (ls :!: Split uId splitType (ITbl m arr c j x)) i where+ data Elm (ls :!: Split uId splitType (ITbl m arr c j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !(RunningIndex i) !(Elm ls i)+ type Arg (ls :!: Split uId splitType (ITbl m arr c j x)) = Arg ls :. (CalcSplitType splitType x)+ type RecElm (ls :!: Split uId splitType (ITbl m arr c j x)) i = Elm ls i+ getArg (ElmSplitITbl _ x _ ls) = getArg ls :. x+ getIdx (ElmSplitITbl _ _ i _ ) = i+ getElm (ElmSplitITbl _ _ _ ls) = ls {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} {-# Inline getElm #-} instance ( Element ls i- ) => Element (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i where- data Elm (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !i !i !(Elm ls i)- type Arg (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) = Arg ls :. (CalcSplitType splitType (x,[r]))- type RecElm (ls :!: Split uId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i = Elm ls i- getArg (ElmSplitBtITbl _ xs _ _ ls) = getArg ls :. xs- getIdx (ElmSplitBtITbl _ _ i _ _ ) = i- getOmx (ElmSplitBtITbl _ _ _ o _ ) = o- getElm (ElmSplitBtITbl _ _ _ _ ls) = ls+ ) => Element (ls :!: Split uId splitType (Backtrack (ITbl mF arr c j x) mF mB r)) i where+ data Elm (ls :!: Split uId splitType (Backtrack (ITbl mF arr c j x) mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !(RunningIndex i) !(Elm ls i)+ type Arg (ls :!: Split uId splitType (Backtrack (ITbl mF arr c j x) mF mB r)) = Arg ls :. (CalcSplitType splitType (x,[r]))+ type RecElm (ls :!: Split uId splitType (Backtrack (ITbl mF arr c j x) mF mB r)) i = Elm ls i+ getArg (ElmSplitBtITbl _ xs _ ls) = getArg ls :. xs+ getIdx (ElmSplitBtITbl _ _ i _ ) = i+ getElm (ElmSplitBtITbl _ _ _ ls) = ls {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} {-# Inline getElm #-} @@ -148,6 +144,12 @@ -- | Actually collect split indices based on if we managed to find the -- right @Split@ synvar (based on the right symbol).+--+-- TODO this is not completely right, or? Since we should consider+-- inside/outside?+--+-- TODO 'splitIxCol' will need the index type @i@ to combine running index+-- and index into the actual lookup part. class SplitIxCol (uId::Symbol) (b::Bool) e where type SplitIxTy uId b e :: *@@ -157,7 +159,7 @@ instance SplitIxCol uId b (Elm S i) where type SplitIxTy uId b (Elm S i) = Z- splitIxCol p b (ElmS _ _) = Z+ splitIxCol p b (ElmS _) = Z {-# Inline splitIxCol #-} @@ -172,16 +174,16 @@ instance ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)- ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (ITbl m arr j x)) i) where- type SplitIxTy uId True (Elm (ls :!: Split sId splitType (ITbl m arr j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i- splitIxCol p b (ElmSplitITbl _ _ i _ e) = collectIx p e :. i+ ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (ITbl m arr c j x)) i) where+ type SplitIxTy uId True (Elm (ls :!: Split sId splitType (ITbl m arr c j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i+ splitIxCol p b (ElmSplitITbl _ _ i e) = collectIx p e :. (error "splitIxCol: RunningIndex i -> i conversion?") -- i {-# Inline splitIxCol #-} instance ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls i)- ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i) where- type SplitIxTy uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr j x) mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i- splitIxCol p b (ElmSplitBtITbl _ _ i _ e) = collectIx p e :. i+ ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr c j x) mF mB r)) i) where+ type SplitIxTy uId True (Elm (ls :!: Split sId splitType (Backtrack (ITbl mF arr c j x) mF mB r)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i+ splitIxCol p b (ElmSplitBtITbl _ _ i e) = collectIx p e :. (error "splitIxCol: RunningIndex i -> i conversion?") -- i {-# Inline splitIxCol #-} instance@@ -189,6 +191,6 @@ , Zconcat (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) ) => SplitIxCol uId True (Elm (ls :!: TermSymbol a b) i) where type SplitIxTy uId True (Elm (ls :!: TermSymbol a b) i) = Zpp (SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i)) (SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))- splitIxCol p b (ElmTS t i _ e) = collectIx p e `zconcat` (undefined p t :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b))+ splitIxCol p b (ElmTS t i e) = collectIx p e `zconcat` (undefined p t :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) {-# Inline splitIxCol #-}
ADP/Fusion/Term/Chr/Point.hs view
@@ -27,7 +27,7 @@ ( 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+ = S.map (\(ss,ee,ii) -> ElmChr ee ii 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 #-}@@ -41,22 +41,21 @@ -- NOTE / TODO a bit faster with @seq xs@ ? instance- ( TstCtx1 m ts a is (PointL I)- ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.PointL I) where+ ( TstCtx m ts s x0 i0 is (PointL I)+ ) => TermStream m (TermSymbol ts (Chr r x)) s (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)))+ -- seq xs . staticCheck (i>0 && i<=u && i<= VG.length xs)+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:. f xs (i-1))) . termStream ts cs us is {-# Inline termStream #-} instance- ( TstCtx1 m ts a is (PointL O)- ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.PointL O) where+ ( TstCtx m ts s x0 i0 is (PointL O)+ ) => TermStream m (TermSymbol ts (Chr r x)) s (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)))+ = S.map (\(TState s ii ee) ->+ let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+ in TState s (ii:.: RiPlO (k+1) o) (ee:.f xs k)) . termStream ts cs us is {-# Inline termStream #-} @@ -69,7 +68,7 @@ {-# Inline [0] termStreamIndex #-} instance TermStaticVar (Chr r x) (PointL O) where- termStaticVar _ (OStatic d) _ = OStatic (d+1) + termStaticVar _ (OStatic d) _ = OStatic (d+1) termStreamIndex _ _ j = j {-# Inline [0] termStaticVar #-} {-# Inline [0] termStreamIndex #-}
ADP/Fusion/Term/Chr/Set0.hs view
@@ -12,7 +12,7 @@ import qualified Data.Vector.Generic as VG import Prelude hiding (map) import Data.Bits-import Data.Bits.Extras (msb)+import Data.Bits.Extras (msb,Ranked) import Data.Bits.Ordered import Data.PrimitiveArray hiding (map)@@ -26,30 +26,31 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmChr ee ii 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+ ( TstCtx m ts s x0 i0 is (BitSet I)+ , Ranked (BitSet I)+ ) => TermStream m (TermSymbol ts (Chr r x)) s (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))+ where mk svS = let RiBsI bs = getIndex (getIdx $ tS svS) (Proxy :: PRI is (BitSet I)) mask = i `xor` bs- in {- traceShow ("Chr",i,bs,mask,lsbZ mask) $ -} return (svS :. mask :. lsbZ mask)+ in 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 )+ step (svS@(TState s ii 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))+ let RiBsI aa = getIndex (getIdx s) (Proxy :: PRI is (BitSet I))+ in return $ Yield (TState s (ii:.: RiBsI (setBit aa k)) (ee:.f xs k)) (svS :. mask :. nextActiveZ k mask) {-# Inline [0] mk #-} {-# Inline [0] step #-}
ADP/Fusion/Term/Chr/Subword.hs view
@@ -20,60 +20,62 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmChr ee ii 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 #-} +-- |+--+-- NOTE We do not run 'staticCheck'. Running @staticCheck@ costs about+-- @10%@ performance and we assume that the frontend will take care of+-- correct indices anyway.+ instance- ( TstCtx1 m ts a is (Subword I)- ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.Subword I) where+ ( TstCtx m ts s x0 i0 is (Subword I)+ ) => TermStream m (TermSymbol ts (Chr r x)) s (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)) )+ = id -- staticCheck (i>=0 && i < j && j <= VG.length xs)+ . map (\(TState s ii ee) ->+ TState s (ii:.: RiSwI j) (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) )+ = map (\(TState s ii ee) ->+ let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))+ in TState s (ii:.:RiSwI (l+1)) (ee:.f xs l) ) . termStream ts cs us is {-# Inline termStream #-} instance- ( TstCtx1 m ts a is (Subword O)- ) => TermStream m (TermSymbol ts (Chr r x)) a (is:.Subword O) where+ ( TstCtx m ts s x0 i0 is (Subword O)+ ) => TermStream m (TermSymbol ts (Chr r x)) s (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))+ = map (\(TState s ii ee) ->+ let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O)) l = k - dj- in TState s a b (ii:.subword k (k+1)) (oo:.o) (ee:.f xs k) )+ in TState s (ii:.: RiSwO k (k+1) oi oj) (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))+ = map (\(TState s ii ee) ->+ let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O)) l = k - dj - 1- in TState s a b (ii:.subword (k-1) k) (oo:.o) (ee:.f xs l) )+ in TState s (ii:.:RiSwO (k-1) k oi oj) (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) )+ = map (\(TState s ii ee) ->+ let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))+ in TState s (ii:.:RiSwO k (k+1) oi oj) (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) )+ = map (\(TState s ii ee) ->+ let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))+ in TState s (ii:.:RiSwO k (k+1) oi oj) (ee:.f xs k) ) . termStream ts cs us is {-# Inline termStream #-}
ADP/Fusion/Term/Chr/Type.hs view
@@ -24,7 +24,7 @@ data Chr r x where Chr :: VG.Vector v x => (v x -> Int -> r)- -> (v x)+ -> !(v x) -> Chr r x -- | smart constructor for regular 1-character parsers@@ -47,16 +47,14 @@ instance ( Element ls i ) => Element (ls :!: Chr r x) i where- data Elm (ls :!: Chr r x) i = ElmChr !r !i !i !(Elm ls i)+ data Elm (ls :!: Chr r x) i = ElmChr !r !(RunningIndex i) !(Elm ls i) type Arg (ls :!: Chr r x) = Arg ls :. r- getArg (ElmChr x _ _ ls) = getArg ls :. x- getIdx (ElmChr _ i _ _ ) = i- getOmx (ElmChr _ _ o _ ) = o+ getArg (ElmChr x _ ls) = getArg ls :. x+ getIdx (ElmChr _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} -deriving instance (Show i, Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)+deriving instance (Show i, Show (RunningIndex i), Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i) type instance TermArg (Chr r x) = r
ADP/Fusion/Term/Deletion/Point.hs view
@@ -16,7 +16,7 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmDeletion ii ss) . addTermStream1 Deletion sv us is $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is) {-# Inline mkStream #-}@@ -24,21 +24,20 @@ instance- ( TstCtx1 m ts a is (PointL I)- ) => TermStream m (TermSymbol ts Deletion) a (is:.PointL I) where+ ( TstCtx m ts s x0 i0 is (PointL I)+ ) => TermStream m (TermSymbol ts Deletion) s (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:.()))+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.())) . termStream ts cs us is {-# Inline termStream #-} instance- ( TstCtx1 m ts a is (PointL O)- ) => TermStream m (TermSymbol ts Deletion) a (is:.PointL O) where+ ( TstCtx m ts s x0 i0 is (PointL O)+ ) => TermStream m (TermSymbol ts Deletion) s (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:.()))+ = S.map (\(TState s ii ee) ->+ let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+ in TState s (ii:.: io) (ee:.())) . termStream ts cs us is {-# Inline termStream #-}
ADP/Fusion/Term/Deletion/Subword.hs view
@@ -17,7 +17,7 @@ ( 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)+ = map (\(ss,ee,ii) -> ElmDeletion ii ss) . addTermStream1 Deletion sv us is $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is) {-# Inline mkStream #-}@@ -25,52 +25,54 @@ instance- ( TstCtx1 m ts a is (Subword I)- ) => TermStream m (TermSymbol ts Deletion) a (is:.Subword I) where+ ( TstCtx m ts s x0 i0 is (Subword I)+ ) => TermStream m (TermSymbol ts Deletion) s (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:.()) )+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiSwI j) (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:.()) )+ = S.map (\(TState s ii ee) ->+ let l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))+ in TState s (ii:.:l) (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+ ( TstCtx m ts s x0 i0 is (Subword O)+ ) => TermStream m (TermSymbol ts Deletion) s (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:._) (us:.u) (is:.Subword (i:.j))+ = S.map (\(TState s ii ee) ->+ let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O))+ in TState s (ii:.:RiSwO k k oi oj) (ee:.()) )+ . termStream ts cs us is+ {- 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:.()) )+ = S.map (\(TState s a ii ee) ->+ let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))+ in TState s a (ii:.:RiSwO k k oi oj) (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:.()) )+ = S.map (\(TState s a ii ee) ->+ let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))+ in TState s a (ii:.:RiSwO k k oi oj) (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:.()) )+ = S.map (\(TState s a ii ee) ->+ let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))+ in TState s a (ii:.:RiSwO k k oi oj) (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:.()) )+ = S.map (\(TState s a ii ee) ->+ let RiSwO _ k oi oj = getIndex a (Proxy :: PRI is (Subword O))+ in TState s a (ii:.: RiSwO k k oi oj) (ee:.()) ) . termStream ts cs us is+ -} {-# Inline termStream #-}
ADP/Fusion/Term/Deletion/Type.hs view
@@ -14,14 +14,12 @@ instance Build Deletion instance (Element ls i) => Element (ls :!: Deletion) i where- data Elm (ls :!: Deletion) i = ElmDeletion !i !i !(Elm ls i)+ data Elm (ls :!: Deletion) i = ElmDeletion !(RunningIndex i) !(Elm ls i) type Arg (ls :!: Deletion) = Arg ls :. ()- getArg (ElmDeletion _ _ l) = getArg l :. ()- getIdx (ElmDeletion i _ _) = i- getOmx (ElmDeletion _ o _) = o+ getArg (ElmDeletion _ l) = getArg l :. ()+ getIdx (ElmDeletion i _) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} type instance TermArg Deletion = ()
ADP/Fusion/Term/Deletion/Unit.hs view
@@ -16,7 +16,7 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmDeletion ii ss) . addTermStream1 Deletion sv us is $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is) {-# Inline mkStream #-}@@ -24,18 +24,18 @@ instance- ( TstCtx1 m ts a is (Unit I)- ) => TermStream m (TermSymbol ts Deletion) a (is:.Unit I) where+ ( TstCtx m ts s x0 i0 is (Unit I)+ ) => TermStream m (TermSymbol ts Deletion) s (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:.()))+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (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+ ( TstCtx m ts s x0 i0 is (Unit O)+ ) => TermStream m (TermSymbol ts Deletion) s (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:.()))+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) . termStream ts cs us is {-# Inline termStream #-}
ADP/Fusion/Term/Edge/Set.hs view
@@ -31,17 +31,17 @@ | 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 (BS2 zs _ zk) = getIdx z+ where RiBs2I (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 (BS2 zs _ zk) = getIdx z+ | otherwise = return $ Yield (ElmEdge (f (getIter zk) (getIter j)) (RiBs2I sij) z) Naught+ where RiBs2I (BS2 zs _ zk) = getIdx z step (That (z,bits,Nothing)) = return $ Done- 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))+ step (That (z,bits,Just j')) = let RiBs2I (BS2 zs _ (Iter zk)) = getIdx z+ tij' = BS2 (zs .|. bit j') (Iter zk) (Iter j')+ in return $ Yield (ElmEdge (f zk j') (RiBs2I tij') z) (That (z,bits,maybeNextActive j' bits)) {-# Inline [0] mk #-} {-# Inline [0] step #-} {-# Inline mkStream #-}
ADP/Fusion/Term/Edge/Type.hs view
@@ -17,16 +17,14 @@ instance ( Element ls i ) => Element (ls :!: Edge e) i where- data Elm (ls :!: Edge e) i = ElmEdge !e !i !i (Elm ls i)+ data Elm (ls :!: Edge e) i = ElmEdge !e !(RunningIndex i) (Elm ls i) type Arg (ls :!: Edge e) = Arg ls :. e- getArg (ElmEdge e _ _ ls) = getArg ls :. e- getIdx (ElmEdge _ i _ _ ) = i- getOmx (ElmEdge _ _ o _ ) = o+ getArg (ElmEdge e _ ls) = getArg ls :. e+ getIdx (ElmEdge _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} -deriving instance (Show i, Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i)+deriving instance (Show i, Show (RunningIndex i), Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i) type instance TermArg (Edge e) = e
ADP/Fusion/Term/Epsilon/Point.hs view
@@ -16,7 +16,7 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss) . addTermStream1 Epsilon sv us is $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) {-# Inline mkStream #-}@@ -24,21 +24,20 @@ instance- ( TstCtx1 m ts a is (PointL I)- ) => TermStream m (TermSymbol ts Epsilon) a (is:.PointL I) where+ ( TstCtx m ts s x0 i0 is (PointL I)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()))+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiPlI i) (ee:.())) . termStream ts cs us is {-# Inline termStream #-} instance- ( TstCtx1 m ts a is (PointL O)- ) => TermStream m (TermSymbol ts Epsilon) a (is:.PointL O) where+ ( TstCtx m ts s x0 i0 is (PointL O)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()))+ = S.map (\(TState s ii ee) ->+ let io = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+ in TState s (ii:.:io) (ee:.())) . termStream ts cs us is {-# Inline termStream #-}
ADP/Fusion/Term/Epsilon/Set.hs view
@@ -20,7 +20,7 @@ ( 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)+ = map (\(ss,ee,ii) -> ElmEpsilon ii ss) . addTermStream1 Epsilon sv us is $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) {-# Inline mkStream #-}@@ -28,22 +28,22 @@ instance- ( TstCtx1 m ts a is (BitSet I)- ) => TermStream m (TermSymbol ts Epsilon) a (is:.BitSet I) where+ ( TstCtx m ts s x0 i0 is (BitSet I)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()) )+ . map (\(TState s ii ee) ->+ TState s (ii:.:RiBsI 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+ ( TstCtx m ts s x0 i0 is (BitSet O)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()) )+ . map (\(TState s ii ee) ->+ TState s (ii:.:RiBsO u u) (ee:.()) ) . termStream ts cs us is {-# Inline termStream #-} @@ -69,30 +69,29 @@ ( 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)+ = map (\(ss,ee,ii) -> ElmEpsilon ii 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+ ( TstCtx m ts s x0 i0 is (BS2 First Last I)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()) )+ . map (\(TState s ii ee) ->+ TState s (ii:.:RiBs2I (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+ ( TstCtx m ts s x0 i0 is (BS2 First Last O)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()) )+ . map (\(TState s ii ee) ->+ let io = getIndex (getIdx s) (Proxy :: PRI is (BS2 First Last O))+ in TState s (ii:.:io) (ee:.()) ) . termStream ts cs us is {-# Inline termStream #-}
ADP/Fusion/Term/Epsilon/Subword.hs view
@@ -17,7 +17,7 @@ ( 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)+ = map (\(ss,ee,ii) -> ElmEpsilon ii ss) . addTermStream1 Epsilon sv us is $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) {-# Inline mkStream #-}@@ -25,24 +25,23 @@ instance- ( TstCtx1 m ts a is (Subword I)- ) => TermStream m (TermSymbol ts Epsilon) a (is:.Subword I) where+ ( TstCtx m ts s x0 i0 is (Subword I)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()) )+ = map (\(TState s ii ee) ->+ TState s (ii:.:RiSwI j) (ee:.()) ) . termStream ts cs us is+ . staticCheck (i==j) {-# Inline termStream #-} instance- ( TstCtx1 m ts a is (Subword O)- ) => TermStream m (TermSymbol ts Epsilon) a (is:.Subword O) where+ ( TstCtx m ts s xi0 i0 is (Subword O)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()) )+ . map (\(TState s ii ee) ->+ let io = getIndex (getIdx s) (Proxy :: PRI is (Subword O))+ in TState s (ii:.:io) (ee:.()) ) . termStream ts cs us is {-# Inline termStream #-}
ADP/Fusion/Term/Epsilon/Type.hs view
@@ -14,14 +14,12 @@ instance Build Epsilon instance (Element ls i) => Element (ls :!: Epsilon) i where- data Elm (ls :!: Epsilon) i = ElmEpsilon !i !i !(Elm ls i)+ data Elm (ls :!: Epsilon) i = ElmEpsilon !(RunningIndex i) !(Elm ls i) type Arg (ls :!: Epsilon) = Arg ls :. ()- getArg (ElmEpsilon _ _ l) = getArg l :. ()- getIdx (ElmEpsilon i _ _) = i- getOmx (ElmEpsilon _ o _) = o+ getArg (ElmEpsilon _ l) = getArg l :. ()+ getIdx (ElmEpsilon i _) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} type instance TermArg Epsilon = ()
ADP/Fusion/Term/Epsilon/Unit.hs view
@@ -16,7 +16,7 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmEpsilon ii ss) . addTermStream1 Epsilon sv us is $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) {-# Inline mkStream #-}@@ -24,18 +24,18 @@ instance- ( TstCtx1 m ts a is (Unit I)- ) => TermStream m (TermSymbol ts Epsilon) a (is:.Unit I) where+ ( TstCtx m ts s x0 i0 is (Unit I)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()))+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (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+ ( TstCtx m ts s x0 i0 is (Unit O)+ ) => TermStream m (TermSymbol ts Epsilon) s (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:.()))+ = S.map (\(TState s ii ee) -> TState s (ii:.:RiU) (ee:.())) . termStream ts cs us is {-# Inline termStream #-}
ADP/Fusion/Term/PeekIndex/Subword.hs view
@@ -18,7 +18,7 @@ , 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)+ = map (\s -> let ri@(RiSwC k l) = getIdx s in ElmPeekIndex (subword k l) ri s) $ mkStream ls Complemented h ij {-# Inline mkStream #-}
ADP/Fusion/Term/PeekIndex/Type.hs view
@@ -16,16 +16,14 @@ instance ( Element ls i ) => Element (ls :!: PeekIndex i) i where- data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !i !(Elm ls i)- type Arg (ls :!: PeekIndex i) = Arg ls :. (i :. i)- getArg (ElmPeekIndex i o ls) = getArg ls :. (i:.o)- getIdx (ElmPeekIndex i _ _ ) = i- getOmx (ElmPeekIndex _ o _ ) = o+ data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !(RunningIndex i) !(Elm ls i)+ type Arg (ls :!: PeekIndex i) = Arg ls :. i+ getArg (ElmPeekIndex x _ ls) = getArg ls :. x+ getIdx (ElmPeekIndex _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} -deriving instance (Show i, Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)+deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i) type instance TermArg (PeekIndex i) = PeekIndex i
ADP/Fusion/Term/Strng/Point.hs view
@@ -18,7 +18,7 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmStrng ee ii ss) . addTermStream1 strng sv us is $ mkStream ls (termStaticVar strng sv is) us (termStreamIndex strng sv is) {-# Inline mkStream #-}@@ -26,52 +26,49 @@ instance- ( TstCtx1 m ts a is (PointL I)- ) => TermStream m (TermSymbol ts (Strng v x)) a (is:.PointL I) where+ ( TstCtx m ts s x0 i0 is (PointL I)+ ) => TermStream m (TermSymbol ts (Strng v x)) s (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))+ = S.map (\(TState s ii ee) ->+ let RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I))+ in TState s (ii:.:RiPlI i) (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))+ where mk (tstate@(TState s ii ee)) =+ let RiPlI k = getIndex (getIdx s) (Proxy :: PRI 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)+ step (tstate@(TState s ii ee), z)+ | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s (ii:.:RiPlI l) (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+ where RiPlI k = getIndex (getIdx s) (Proxy :: PRI is (PointL I)) 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+ ( TstCtx m ts s x0 i0 is (PointL O)+ ) => TermStream m (TermSymbol ts (Strng v x)) s (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@ ?+ = S.map (\(TState s ii ee) ->+ let RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+ in TState s (ii:.:RiPlO (i-d+1) 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))+ where mk (tstate@(TState s ii ee)) =+ let RiPlO k _ = getIndex (getIdx s) (Proxy :: PRI 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)+ step (tstate@(TState s ii ee), z)+ | z >= 0 && (l-k <= maxL) = return $ S.Yield (TState s (ii:.:RiPlO l 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+ where RiPlO k o = getIndex (getIdx s) (Proxy :: PRI is (PointL O))+ l = i - z - d {-# Inline [0] mk #-} {-# Inline [0] step #-} {-# Inline termStream #-}
ADP/Fusion/Term/Strng/Subword.hs view
@@ -20,27 +20,33 @@ ( 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)+ = S.map (\(ss,ee,ii) -> ElmStrng ee ii 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+ ( TstCtx m ts s x0 i0 is (Subword I)+ ) => TermStream m (TermSymbol ts (Strng v x)) s (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) )+ = S.filter (\(TState s _ _) ->+ -- let Subword (k:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))+ let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))+ -- RiSwI k = getIndex (getIdx $ getElm s) (Proxy :: PRI is (Subword I))+ k = undefined+ in l-k <= maxL)+ . S.map (\(TState s ii ee) ->+ --let Subword (_:.l) = getIndex a (Proxy :: Proxy (is:.Subword I))+ -- o = getIndex b (Proxy :: Proxy (is:.Subword I))+ let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I))+ in TState s (ii:.:RiSwI j) (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))+ where mk (tstate@(TState s ii ee)) =+ let RiSwI k = getIndex (getIdx s) (Proxy :: PRI is (Subword I)) in return (tstate, k+minL, min j (k+maxL)) step = undefined {-# Inline [0] mk #-}
ADP/Fusion/Term/Strng/Type.hs view
@@ -41,16 +41,14 @@ instance ( Element ls i ) => Element (ls :!: Strng v x) i where- data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !i !i !(Elm ls i)+ data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !(RunningIndex i) !(Elm ls i) type Arg (ls :!: Strng v x) = Arg ls :. v x- getArg (ElmStrng x _ _ ls) = getArg ls :. x- getIdx (ElmStrng _ i _ _ ) = i- getOmx (ElmStrng _ _ o _ ) = o+ getArg (ElmStrng x _ ls) = getArg ls :. x+ getIdx (ElmStrng _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-}- {-# Inline getOmx #-} -deriving instance (Show i, Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i)+deriving instance (Show i, Show (RunningIndex i), Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i) type instance TermArg (Strng v x) = v x
ADPfusion.cabal view
@@ -1,7 +1,7 @@ name: ADPfusion-version: 0.5.0.0-author: Christian Hoener zu Siederdissen, 2011-2015-copyright: Christian Hoener zu Siederdissen, 2011-2015+version: 0.5.1.0+author: Christian Hoener zu Siederdissen, 2011-2016+copyright: Christian Hoener zu Siederdissen, 2011-2016 homepage: https://github.com/choener/ADPfusion bug-reports: https://github.com/choener/ADPfusion/issues maintainer: choener@bioinf.uni-leipzig.de@@ -11,7 +11,7 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0-tested-with: GHC == 7.8.4, GHC == 7.10.2+tested-with: GHC == 7.8.4, GHC == 7.10.3 synopsis: Efficient, high-level dynamic programming. description: <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>@@ -59,23 +59,26 @@ default: False manual: True +flag spectest+ description: build the spec-ctor test case+ default: False+ manual: True + library build-depends: base >= 4.7 && < 4.9 , bits >= 0.4 && < 0.5 , containers , mmorph >= 1.0 && < 1.1- , monad-primitive >= 0.1 && < 0.2 , mtl >= 2.0 && < 2.3 , OrderedBits >= 0.0.1.0 && < 0.0.2.0 , primitive >= 0.5.4 && < 0.7 , 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+ , th-orphans >= 0.12 && < 0.14 , transformers >= 0.3 && < 0.5 , tuple >= 0.3 && < 0.4 , vector >= 0.11 && < 0.12@@ -531,6 +534,48 @@ , BenchmarkHistory >= 0.0.0 && < 0.0.1 , PrimitiveArray , vector++++-- Very simple two-sequence alignment.++executable spectest++ if flag(spectest)+ buildable:+ True+ build-depends: base+ , ADPfusion+ , PrimitiveArray+ , template-haskell+ , vector+ else+ buildable:+ False+ hs-source-dirs:+ src+ main-is:+ SpecTest.hs+ default-language:+ Haskell2010+ default-extensions: BangPatterns+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , RecordWildCards+ , TemplateHaskell+ , TypeFamilies+ , TypeOperators+ ghc-options:+ -O2+ -funbox-strict-fields+ -funfolding-use-threshold1000+ -funfolding-keeness-factor1000+ if flag(debug)+ ghc-options:+ -ddump-to-file+ -ddump-simpl+ -dsuppress-all
changelog.md view
@@ -1,3 +1,9 @@+0.5.1.0+-------++- improved table filling algorithm performance+- some optimizations to terminal symbols+ 0.5.0.0 -------
src/Durbin.hs view
@@ -31,6 +31,7 @@ import qualified Data.Vector.Unboxed as VU import System.Environment (getArgs) import Text.Printf+import Data.Char (ord) -- Import PrimitiveArray for low-level tables and automatic table -- filling.@@ -61,7 +62,7 @@ { nil = \ () -> 0 , lef = \ _ x -> x , rig = \ x _ -> x- , pai = \ c x d -> if pairs c d then x+1 else -999999+ , pai = \ c x d -> x + pairs' c d -- if pairs c d then x+1 else -999999 , spl = \ x y -> x+y , h = SM.foldl' max 0 }@@ -76,6 +77,16 @@ || c=='U' && d=='G' {-# INLINE pairs #-} +pairs' !c !d = lkup_pairs ! (Z:.ord c:.ord d)+{-# Inline pairs' #-}++lkup_pairs :: Unboxed (Z:.Int:.Int) Int+lkup_pairs = PA.fromAssocs (Z:.0:.0) (Z:.mx:.mx) (-999999) $ Prelude.map (\[p1,p2] -> ((Z:.p1:.p2),1)) ps+ where mx = maximum $ Prelude.map ord "ACGU"+ ps :: [[Int]]+ ps = Prelude.map (Prelude.map ord) [ "AU", "CG", "GC", "GU", "UA", "UG" ]+{-# NoInline lkup_pairs #-}+ pretty :: Monad m => Durbin m Char () String [String] pretty = Durbin { nil = \ () -> ""@@ -100,6 +111,8 @@ in (Z:.t) {-# INLINE grammar #-} +-- TODO need to re-enable epsilon checks!+ runDurbin :: Int -> String -> (Int,[String]) runDurbin k inp = (d, take k . unId $ axiom b) where i = VU.fromList . Prelude.map toUpper $ inp@@ -107,10 +120,9 @@ !(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 I) Int- -- d = let (ITbl _ _ arr _) = t in arr PA.! subword 0 n+ (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) :: Z:.ITbl Id Unboxed EmptyOk (Subword I) Int d = iTblArray t PA.! subword 0 n- !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))+ !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a)) -- :: Z:.Backtrack (ITbl Id Unboxed EmptyOk (Subword I) Int) Id Id String {-# NoInline runDurbin #-} main = do
src/NeedlemanWunsch.hs view
@@ -240,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 I:.PointL I) Int+nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (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) []))@@ -249,7 +249,7 @@ n2 = VU.length i2 {-# NoInline nwInsideForward #-} -nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.PointL I:.PointL I) Int -> [[String]]+nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (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 #-}@@ -274,7 +274,7 @@ -- | 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 (Z:.PointL O:.PointL O) Int+nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $ grammar sScore (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) []))
src/Nussinov.hs view
@@ -108,7 +108,7 @@ bs = runInsideBacktrack i t {-# NOINLINE runNussinov #-} -runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed (Subword I) Int+runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed EmptyOk (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 I) Int -> [String]+runInsideBacktrack :: VU.Vector Char -> ITbl Id Unboxed EmptyOk (Subword I) Int -> [String] runInsideBacktrack i t = unId $ axiom b where !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a)) {-# NoInline runInsideBacktrack #-}
src/OverlappingPalindromes.hs view
@@ -140,8 +140,8 @@ i {-# NoInline opForward #-} -type X = ITbl Id Unboxed (Subword I) Int-type T = ITbl Id Unboxed (Z:.Subword I:.Subword I) Int+type X = ITbl Id Unboxed EmptyOk (Subword I) Int+type T = ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Subword I:.Subword I) Int main :: IO ()
src/PartNussinov.hs view
@@ -134,11 +134,11 @@ -> NussinovEnsemble m (Log Double)- (Subword C:.Subword C)+ (Subword C) (Subword C, Log Double) [(Subword C, Log Double)] ensemble z = NussinovEnsemble- { ens = \ x (Subword k:._) y -> ( Subword k , x * y / z )+ { ens = \ x i y -> ( i , x * y / z ) , hhh = SM.toList } {-# Inline ensemble #-}@@ -202,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 I) (Log Double)-type TblO = ITbl Id Unboxed (Subword O) (Log Double)+type TblI = ITbl Id Unboxed EmptyOk (Subword I) (Log Double)+type TblO = ITbl Id Unboxed EmptyOk (Subword O) (Log Double) runInsideForward :: VU.Vector Char -> Z:.TblI:.TblI runInsideForward i = mutateTablesDefault@@ -229,7 +229,7 @@ where (Z:.g) = ensembleGrammar (ensemble z) i o (IRec EmptyOk (Subword l) (Subword h))- :: Z :. IRec Id (Subword C) [(Subword C, Log Double)]+ :: Z :. IRec Id EmptyOk (Subword C) [(Subword C, Log Double)] (Subword l,Subword h) = let (ITbl _ _ _ arr _) = i in bounds arr {-# NoInline runEnsembleForward #-}
src/Pseudoknot.hs view
@@ -115,8 +115,8 @@ -} {-# NOINLINE runPseudoknot #-} -type X = ITbl Id Unboxed (Subword I) Int-type T = ITbl Id Unboxed (Z:.Subword I:.Subword I) Int+type X = ITbl Id Unboxed EmptyOk (Subword I) Int+type T = ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Subword I:.Subword I) Int runInsideForward :: VU.Vector Char -> Z:.X:.T:.T runInsideForward i = mutateTablesWithHints (Proxy :: Proxy MonotoneMCFG)
+ src/SpecTest.hs view
@@ -0,0 +1,116 @@++-- | Lets try to get a grip on what specconstr does to our code.++module Main (main) where++import Control.Applicative+import Control.Monad+import Data.Vector.Fusion.Stream.Monadic (Stream (..))+import Data.Vector.Fusion.Util+import Debug.Trace+import qualified Control.Arrow as A+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import System.Environment (getArgs)+import System.IO.Unsafe (unsafePerformIO)+import Text.Printf++import Data.PrimitiveArray as PA hiding (map)++import ADP.Fusion+++++data Signature m x r c = Signature+ { step_step :: x -> (Z:.c :.c ) -> x+ , step_loop :: x -> (Z:.c :.()) -> x+ , loop_step :: x -> (Z:.():.c ) -> x+ , nil_nil :: (Z:.():.()) -> x+ , booboo :: x -> (Z:.c:.c) -> (Z:.c:.c) -> (Z:.c:.c) -> (Z:.c:.c) -> x+ , h :: Stream m x -> m r+ }++++grammar Signature{..} a' i1 i2 =+ let a = a' ( --step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_loop <<< a % (M:|chr i1:|Deletion ) |||+-- loop_step <<< a % (M:|Deletion :|chr i2) |||+ step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_step <<< a % (M:|chr i1:|chr i2) |||+-- step_step <<< a % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- booboo <<< a % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) % (M:|chr i1:|chr i2) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+-- nil_nil <<< (M:|Epsilon:|Epsilon) |||+ nil_nil <<< (M:|Epsilon:|Epsilon) ... h+ )+ in Z:.a+{-# INLINE grammar #-}+++sScore :: Monad m => Signature m Int Int Char+sScore = Signature+ { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-2+ , step_loop = \x _ -> x-1+ , loop_step = \x _ -> x-1+ , nil_nil = const 0+ , booboo = \x _ _ _ _ -> x+ , h = SM.foldl' max (-999999)+ }+{-# INLINE sScore #-}+++runNeedlemanWunsch :: Int -> String -> String -> Int+runNeedlemanWunsch k i1' i2' = d where+ i1 = VU.fromList i1'+ i2 = VU.fromList i2'+ n1 = VU.length i1+ n2 = VU.length i2+ !(Z:.t) = nwInsideForward i1 i2+ d = unId $ axiom t+{-# Noinline runNeedlemanWunsch #-}++nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (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) []))+ i1 i2+ where n1 = VU.length i1+ n2 = VU.length i2+{-# NoInline nwInsideForward #-}++main = do+ ls <- lines <$> getContents+ print $ runNeedlemanWunsch 1 (ls!!0) (ls!!1)++
src/SplitTests.hs view
@@ -120,8 +120,8 @@ i {-# NoInline opForward #-} -type X = ITbl Id Unboxed (Subword I) Int-type T = ITbl Id Unboxed (Z:.Subword I:.Subword I) Int+type X = ITbl Id Unboxed EmptyOk (Subword I) Int+type T = ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Subword I:.Subword I) Int main :: IO ()
tests/QuickCheck/Point.hs view
@@ -28,7 +28,7 @@ -- * Epsilon cases -prop_Epsilon ix@(PointL j) = zs == ls where+prop_I_Epsilon ix@(PointL j) = zs == ls where zs = (id <<< Epsilon ... stoList) maxPLi ix ls = [ () | j == 0 ] @@ -52,7 +52,7 @@ -- * Deletion cases -prop_ItNC ix@(PointL j) = zs == ls where+prop_I_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)@@ -85,7 +85,7 @@ , 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+prop_I_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))@@ -99,7 +99,7 @@ -- | A single character terminal -prop_Tt ix@(Z:.PointL j) = zs == ls where+prop_I_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 ] @@ -109,13 +109,13 @@ -- | Two single-character terminals -prop_CC ix@(Z:.PointL i) = zs == ls where+prop_I_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+prop_I_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 ]@@ -125,7 +125,7 @@ zs = (id <<< t ... stoList) maxPLo ix ls = [ unsafeIndex xsPo ix | j>=0, j<=maxI ] -prop_ZIt ix@(Z:.PointL j) = zs == ls where+prop_I_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 ]@@ -137,7 +137,7 @@ -- | Table, then single terminal -prop_ItC ix@(PointL j) = zs == ls where+prop_I_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)@@ -151,7 +151,7 @@ zs = ((,) <<< t % chr xs ... stoList) maxPLo ix ls = [ ( unsafeIndex xsPo (PointL $ j+1) , xs VU.! (j+0)- ) | j >= 0, j < maxI ]+ ) | j >= 0, j <= (maxI-1) ] prop_O_ItCC ix@(PointL j) = zs == ls where t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)@@ -160,8 +160,16 @@ , xs VU.! (j+0) , xs VU.! (j+1) ) | j >= 0, j <= (maxI-2) ]-{-# Noinline prop_O_ItCC #-} +prop_O_ItCCC ix@(PointL j) = zs == ls where+ t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)+ zs = ((,,,) <<< t % chr xs % chr xs % chr xs ... stoList) maxPLo ix+ ls = [ ( unsafeIndex xsPo (PointL $ j+3)+ , xs VU.! (j+0)+ , xs VU.! (j+1)+ , xs VU.! (j+2)+ ) | j >= 0, j <= (maxI-3) ]+ 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@@ -172,7 +180,7 @@ -- | synvar followed by a 2-tape character terminal -prop_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where+prop_I_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))@@ -200,11 +208,11 @@ -- ** Just the 'Strng' terminal -prop_ManyS ix@(PointL j) = zs == ls where+prop_I_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+prop_I_SomeS ix@(PointL j) = zs == ls where zs = (id <<< someS xs ... stoList) maxPLi ix ls = [ (VU.slice 0 j xs) | j>0 ] @@ -218,32 +226,32 @@ -- ** Together with a syntactic variable. -prop_Itbl_ManyS ix@(PointL i) = zs == ls where+prop_I_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+prop_I_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+prop_I_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+prop_I_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+prop_I_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+prop_I_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] ]@@ -254,22 +262,6 @@ 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 ..]
tests/QuickCheck/Subword.hs view
@@ -36,7 +36,7 @@ -- B*_ik -> A*_ij C_kj -- C*_kj -> B_ik A*_ij -prop_sv_OI ox@(Subword (i:.k)) = zs == ls where+prop_O_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@@ -44,7 +44,7 @@ , unsafeIndex xsS (subword k j) ) | j <- [ k .. highest ] ] -prop_sv_IO ox@(Subword (k:.j)) = zs == ls where+prop_O_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@@ -61,7 +61,7 @@ -- 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+prop_O_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))@@ -71,7 +71,7 @@ , unsafeIndex xsS (subword l j) ) | j <- [ k .. highest ], l <- [ k .. j ] ] -prop_sv_IOI ox@(Subword (k:.l)) = zs == ls where+prop_O_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))@@ -81,7 +81,7 @@ , unsafeIndex xsS (subword l j) ) | i <- [ 0 .. k ], j <- [ l .. highest ] ] -prop_sv_IIO ox@(Subword (l:.j)) = zs == ls where+prop_O_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))@@ -97,7 +97,7 @@ -- ** Non-terminal and terminal combinations -prop_cOc ox@(Subword (i:.j)) = zs == ls where+prop_O_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)@@ -105,7 +105,7 @@ , csS VU.! (j ) ) | i > 0 && j < highest ] -prop_ccOcc ox@(Subword (i:.j)) = zs == ls where+prop_O_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)@@ -115,7 +115,7 @@ , csS VU.! (j+1) ) | i > 1 && j < highest -1 ] -prop_cOccc ox@(Subword (i:.j)) = zs == ls where+prop_O_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)@@ -127,7 +127,7 @@ -- ** Terminals, syntactic terminals, and non-terminals -prop_cOcIc ox@(Subword (i:.k)) = zs == ls where+prop_O_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@@ -138,7 +138,7 @@ , csS VU.! (j-1) ) | i > 0, j <- [ k+2 .. highest ] ] -prop_cIcOc ox@(Subword (k:.j)) = zs == ls where+prop_O_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@@ -151,19 +151,19 @@ -- ** Epsilonness -prop_Epsilon ox@(Subword (i:.j)) = zs == ls where+prop_O_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+prop_I_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+prop_I_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)@@ -171,7 +171,7 @@ | 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+prop_I_2dimItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = (j<=highest && l<=highest) ==> 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))@@ -179,7 +179,7 @@ | 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+prop_I_2dimcItc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = (j<=highest && l<=highest) ==> 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)@@ -192,7 +192,7 @@ stoList = unId . SM.toList -highest = 10+highest = 20 maxSWi :: Subword I maxSWi = subword 0 highest
tests/performance.hs view
@@ -66,7 +66,7 @@ d = unId $ axiom t {-# NoInline runLeft #-} -runLeftForward :: VU.Vector Int -> Unboxed (Subword I) Int -> Z:.ITbl Id Unboxed (Subword I) Int+runLeftForward :: VU.Vector Int -> Unboxed (Subword I) Int -> Z:.ITbl Id Unboxed EmptyOk (Subword I) Int runLeftForward !i !arr = mutateTablesDefault $ gLeft algMax i