diff --git a/ADP/Fusion.hs b/ADP/Fusion.hs deleted file mode 100644 --- a/ADP/Fusion.hs +++ /dev/null @@ -1,80 +0,0 @@ - --- | Generalized fusion system for grammars. --- --- NOTE Symbols typically do not check bound data for consistency. If you, say, --- bind a terminal symbol to an input of length 0 and then run your grammar, --- you probably get errors, garbled data or random crashes. Such checks are --- done via asserts in non-production code. - -module ADP.Fusion - ( module ADP.Fusion - , module ADP.Fusion.Apply - , module ADP.Fusion.Base - , module ADP.Fusion.Term - , module ADP.Fusion.SynVar - , module ADP.Fusion.TH - ) where - -import Data.Strict.Tuple -import GHC.Exts (inline) -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import ADP.Fusion.Apply -import ADP.Fusion.Base -import ADP.Fusion.SynVar -import ADP.Fusion.Term -import ADP.Fusion.TH - -import qualified Data.Vector.Unboxed as VU - -import Data.PrimitiveArray - - - --- | Apply a function to symbols on the RHS of a production rule. Builds the --- stack of symbols from 'xs' using 'build', then hands this stack to --- 'mkStream' together with the initial 'iniT' telling 'mkStream' that we are --- in the "outer" position. Once the stream has been created, we 'S.map' --- 'getArg' to get just the arguments in the stack, and finally 'apply' the --- function 'f'. - -infixl 8 <<< -(<<<) f xs = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij -{-# INLINE (<<<) #-} - -infixl 8 <<# -(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij -{-# INLINE (<<#) #-} - --- | Combine two RHSs to give a choice between parses. - -infixl 7 ||| -(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu ij -{-# INLINE (|||) #-} - --- | Applies the objective function 'h' to a stream 's'. The objective function --- reduces the stream to a single optimal value (or some vector of co-optimal --- things). - -infixl 5 ... -(...) s h = \lu ij -> (inline h) $ s lu ij -{-# INLINE (...) #-} - --- -- | Additional outer check with user-given check function --- --- infixl 6 `check` --- check xs f = \ij -> let chk = f ij in chk `seq` outerCheck chk (xs ij) --- {-# INLINE check #-} - --- | Separator between RHS symbols. - -infixl 9 ~~ -(~~) = (:!:) -{-# INLINE (~~) #-} - --- | This separator looks much paper "on paper" and is not widely used otherwise. - -infixl 9 % -(%) = (:!:) -{-# INLINE (%) #-} - diff --git a/ADP/Fusion/Apply.hs b/ADP/Fusion/Apply.hs deleted file mode 100644 --- a/ADP/Fusion/Apply.hs +++ /dev/null @@ -1,89 +0,0 @@ - -module ADP.Fusion.Apply where - ---import Data.Array.Repa.Index -import Data.PrimitiveArray (Z(..), (:.)(..)) - - - --- * Apply function 'f' in '(<<<)' - -class Apply x where - type Fun x :: * - apply :: Fun x -> x - -instance Apply (Z:.a -> res) where - type Fun (Z:.a -> res) = a -> res - apply fun (Z:.a) = fun a - {-# INLINE apply #-} - -instance Apply (Z:.a:.b -> res) where - type Fun (Z:.a:.b -> res) = a->b -> res - apply fun (Z:.a:.b) = fun a b - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c -> res) where - type Fun (Z:.a:.b:.c -> res) = a->b->c -> res - apply fun (Z:.a:.b:.c) = fun a b c - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d -> res) where - type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res - apply fun (Z:.a:.b:.c:.d) = fun a b c d - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e -> res) where - type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res - apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res - apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n - {-# INLINE apply #-} - -instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where - type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res - apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o - {-# INLINE apply #-} - diff --git a/ADP/Fusion/Base.hs b/ADP/Fusion/Base.hs deleted file mode 100644 --- a/ADP/Fusion/Base.hs +++ /dev/null @@ -1,19 +0,0 @@ - -module ADP.Fusion.Base - ( module ADP.Fusion.Base.Classes - , module ADP.Fusion.Base.Multi - , module ADP.Fusion.Base.Point - , module ADP.Fusion.Base.Set - , module ADP.Fusion.Base.Subword - , module ADP.Fusion.Base.TyLvlIx - , module ADP.Fusion.Base.Unit - ) where - -import ADP.Fusion.Base.Classes -import ADP.Fusion.Base.Multi -import ADP.Fusion.Base.Point -import ADP.Fusion.Base.Set -import ADP.Fusion.Base.Subword -import ADP.Fusion.Base.TyLvlIx -import ADP.Fusion.Base.Unit - diff --git a/ADP/Fusion/Base/Classes.hs b/ADP/Fusion/Base/Classes.hs deleted file mode 100644 --- a/ADP/Fusion/Base/Classes.hs +++ /dev/null @@ -1,198 +0,0 @@ - -module ADP.Fusion.Base.Classes where - -import Data.Proxy -import Data.Strict.Tuple -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Data.PrimitiveArray - - - -data OutsideContext s - = OStatic s - | ORightOf s - | OFirstLeft s - | OLeftOf s - deriving (Show) - -data InsideContext s - = IStatic s - | IVariable s - deriving (Show) - -data ComplementContext - = Complemented - deriving (Show) - -class RuleContext i where - type Context i :: * - 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 . 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 --- characters we parse from an input) and the type of indices @i@ we use. --- --- @Elm@ data constructors are all eradicated during fusion and should never --- show up in CORE. - -class Element x i where - data Elm x i :: * - type RecElm x i :: * - type Arg x :: * - getArg :: Elm x i -> Arg x - 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 --- to functions on the left of the @(<<<)@ operator. Streams work over all --- monads and are specialized for each combination of arguments @x@ and indices --- @i@. - -class (Monad m) => MkStream m x i where - mkStream :: x -> Context i -> i -> i -> S.Stream m (Elm x i) - --- | Finally, we need to be able to correctly build together symbols on the --- right-hand side of the @(<<<)@ operator. --- --- The default makes sure that the last (or only) argument left over is --- correctly assigned a @Z@ to terminate the symbol stack. - -class Build x where - type Stack x :: * - type Stack x = S :!: x - build :: x -> Stack x - default build :: (Stack x ~ (S :!: x)) => x -> Stack x - build x = S :!: x - {-# Inline build #-} - -instance Build x => Build (x:!:y) where - type Stack (x:!:y) = Stack x :!: y - build (x:!:y) = build x :!: y - {-# Inline build #-} - --- | Similar to 'Z', but terminates an argument stack. - -data S = S - deriving (Eq,Show) - -instance - ( - ) => Element S i where - data Elm S i = ElmS !(RunningIndex i) - type Arg S = Z - getArg (ElmS _) = Z - getIdx (ElmS i) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -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. - -staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a -staticCheck b (S.Stream step t) = b `seq` S.Stream snew (CheckLeft b t) where - {-# Inline [0] snew #-} - snew (CheckLeft False _) = return $ S.Done - snew (CheckLeft True s) = return $ S.Skip (CheckRight s) - snew (CheckRight s ) = do r <- step s - case r of - S.Yield x s' -> return $ S.Yield x (CheckRight s') - S.Skip s' -> return $ S.Skip (CheckRight s') - S.Done -> return $ S.Done -{-# INLINE staticCheck #-} - -data StaticCheck a b = CheckLeft Bool a | CheckRight b - - --- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if --- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty' --- 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 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 [0] minSize #-} --} - --- | --- --- TODO Rewrite to generalize easily over multi-dim cases. - -class ModifyConstraint t where - type TNE t :: * - type TE t :: * - toNonEmpty :: t -> TNE t - toEmpty :: t -> TE t - --- ---instance ModifyConstraint EmptyOk --- type TNE EmptyOk = NonEmpty --- type TE EmptyOk = - --- | - ---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 - diff --git a/ADP/Fusion/Base/Multi.hs b/ADP/Fusion/Base/Multi.hs deleted file mode 100644 --- a/ADP/Fusion/Base/Multi.hs +++ /dev/null @@ -1,226 +0,0 @@ - -module ADP.Fusion.Base.Multi where - -import qualified Data.Vector.Fusion.Stream.Monadic as S -import Data.Vector.Fusion.Stream.Monadic -import Data.Strict.Tuple -import Data.Proxy -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base.Classes -import ADP.Fusion.Base.TyLvlIx - - - --- * Multi-dimensional extension - --- | Terminates a multi-dimensional terminal symbol stack. - -data M = M - deriving (Eq,Show) - -infixl 2 :| - --- | Terminal symbols are stacked together with @a@ tails and @b@ head. - -data TermSymbol a b = a :| b - deriving (Eq,Show) - -instance Build (TermSymbol a b) - --- | Extracts the type of a multi-dimensional terminal argument. - -type family TermArg x :: * -type instance TermArg M = Z -type instance TermArg (TermSymbol a b) = TermArg a :. TermArg b - -instance (Element ls i) => Element (ls :!: TermSymbol a b) i where - data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !(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 - {-# INLINE getArg #-} - {-# INLINE getIdx #-} - -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 - , TermStaticVar (TermSymbol a b) 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 ee) -> ElmTS ee ii sS) - . termStream ts sv lu i - . 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 #-} - -instance Monad m => MkStream m S Z where - mkStream _ _ _ _ = S.singleton (ElmS RiZ) - {-# INLINE mkStream #-} - --- | For multi-dimensional terminals we need to be able to calculate how the --- static/variable signal changes and if the index for the inner part needs to --- be modified. - -class TermStaticVar t i where - termStaticVar :: t -> Context i -> i -> Context i - termStreamIndex :: t -> Context i -> i -> i - -instance TermStaticVar M Z where - termStaticVar _ _ _ = Z - termStreamIndex _ _ _ = Z - {-# INLINE [0] termStaticVar #-} - {-# INLINE [0] termStreamIndex #-} - -instance - ( TermStaticVar a is - , TermStaticVar b i - ) => 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 [0] termStaticVar #-} - {-# INLINE [0] 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 --- ---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 #-} - ---toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s) ---{-# INLINE toTerminalStream #-} - -instance RuleContext Z where - type Context Z = Z - initialContext _ = Z - {-# INLINE initialContext #-} - -instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where - type Context (is:.i) = Context is:.Context i - initialContext (is:.i) = initialContext is:.initialContext i - {-# INLINE initialContext #-} - -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 c u Z where - tableStaticVar _ _ _ _ = Z - tableStreamIndex _ _ _ _ = Z - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - -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 #-} - {-# INLINE [0] tableStreamIndex #-} - - - -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 - } - ---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 #-} - -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 #-} - --- | --- --- TODO need @t -> ElmType t@ type function --- --- TODO need to actually return an @ElmType t@ can do that instead of --- returning @u@ !!! - -addTermStream1 - :: ( Monad m - , TermStream m (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i) - ) - => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,RunningIndex i) -addTermStream1 t c u i - = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii)) - . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i) - . 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) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i) - , Element ls i - , TermStaticVar t i - ) - --- | @Term TermStream@ context - ---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 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)) - diff --git a/ADP/Fusion/Base/Point.hs b/ADP/Fusion/Base/Point.hs deleted file mode 100644 --- a/ADP/Fusion/Base/Point.hs +++ /dev/null @@ -1,114 +0,0 @@ - -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) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base.Classes -import ADP.Fusion.Base.Multi - - - -instance RuleContext (PointL I) where - type Context (PointL I) = InsideContext Int - initialContext _ = IStatic 0 - {-# Inline initialContext #-} - -instance RuleContext (PointL O) where - type Context (PointL O) = OutsideContext Int - initialContext _ = OStatic 0 - {-# Inline initialContext #-} - -instance RuleContext (PointL C) where - type Context (PointL C) = ComplementContext - initialContext _ = Complemented - {-# Inline initialContext #-} - -newtype instance RunningIndex (PointL I) = RiPlI Int - -data instance RunningIndex (PointL O) = RiPlO !Int !Int - -data instance RunningIndex (PointL C) = RiPlC !Int - - - -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 - ) => MkStream m S (is:.PointL I) where - mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i) - = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0) - . staticCheck (i>=0 && i<=d && i<=u) - $ mkStream S vs lus is - mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i) - = 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 - ) => 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) -> 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) -> ElmS $ zi :.: RiPlO i (i+d)) - $ mkStream S vs us is - {-# Inline mkStream #-} - - - -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) = PointL $ j - minSize c - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - -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 #-} - diff --git a/ADP/Fusion/Base/Set.hs b/ADP/Fusion/Base/Set.hs deleted file mode 100644 --- a/ADP/Fusion/Base/Set.hs +++ /dev/null @@ -1,178 +0,0 @@ - --- | The @Context@ for a @BitSet@ is the number of bits we should reserve --- for the more right-most symbols, which request a number of reserved --- bits. - -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) -import Data.Bits -import Data.Bits.Ordered - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base.Classes -import ADP.Fusion.Base.Multi - - - ---type instance TblConstraint (BitSet t) = TableConstraint ---type instance TblConstraint (BS2 i j t) = TableConstraint - - - -instance RuleContext (BitSet I) where - type Context (BitSet I) = InsideContext Int - initialContext _ = IStatic 0 - {-# Inline initialContext #-} - --- | The @Int@ in an @OutsideContext@ counts how many bits need to be fixed --- statically. I.e. if the bits @{1,2}@ are set in @X -> Y t@, and @t@ has --- size @1@, then @Y@ will have @{1,2,3}@, @{1,2,4}@ and so on, with @t@ --- having @3, 4, ...@ as values. - -instance RuleContext (BitSet O) where - type Context (BitSet O) = OutsideContext Int - initialContext _ = OStatic 0 - {-# Inline initialContext #-} - -instance RuleContext (BitSet C) where - type Context (BitSet C) = ComplementContext - 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 - {-# Inline initialContext #-} - -instance RuleContext (BS2 First Last O) where - type Context (BS2 First Last O) = OutsideContext () - initialContext _ = OStatic () - {-# Inline initialContext #-} - -instance RuleContext (BS2 First Last C) where - type Context (BS2 First Last C) = ComplementContext - 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 - -- | We enumerate all sets that have @popCount s - rb@ bits. Since we are - -- @IStatic@ we only have static objects following. These will fill in - -- the missing bits. Each object will fill a fixed number of bits, until - -- @s@ has been recovered. Otherwise we would have an @IVariable@ - -- context. - mkStream S (IStatic rb) u s - = staticCheck (rb <= ps) . map (\k -> ElmS . RiBsI $ popShiftL s k) $ unfoldr go strt - where strt = Just $ BitSet $ 2^(ps - rb) - 1 - ps = popCount s - go Nothing = Nothing - go (Just k) = Just $ (k, popPermutation ps k) - -- | Once we are variable, we do not reserve any bits, just check that - -- the total reservation (if any) works. - mkStream S (IVariable rb) u s - = staticCheck (rb <= popCount s) . singleton . ElmS $ RiBsI 0 - {-# Inline mkStream #-} - --- | Initial index construction for outside Bitsets. Bits set to @0@ --- indicate hole-space. The last bitset, the one accessed by @axiom@, is --- @BitSet 0@. --- --- We need to be careful with reserved bits! Reserved bits are @0@ bits --- that can be switched to @1@. This means that @rb@ + popCount s <= --- popCount u@. --- --- @OStatic@'s happen when we only have terminals on the r.h.s. That is, --- with @X -> end@. --- --- TODO test all of this via quickcheck! - -instance - ( Monad m - ) => MkStream m S (BitSet O) where - -- | Same argument as above for @BitSet O@ construction. - mkStream S (OStatic rb) u s - = staticCheck (rb + popCount s <= popCount u) . singleton . ElmS $ 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 $ RiBsO s s --- mkStream S (OLeftOf rp) u s --- = staticCheck (popCount s + rp <= popCount u) . singleton $ ElmS s s - {-# Inline mkStream #-} - -instance - ( Monad m - ) => MkStream m S (BitSet C) where - -instance - ( Monad m - ) => MkStream m S (BS2 First Last I) where - mkStream S (IStatic rp) u sij@(BS2 s (Iter i) _) - = 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 . RiBs2I $ BS2 0 (Iter i) (Iter i) - {-# Inline mkStream #-} - -instance - ( Monad m - ) => MkStream m S (BS2 First Last O) where - -instance - ( Monad m - ) => MkStream m S (BS2 First Last C) where - - - --- | An undefined bitset with 2 interfaces. - -undefbs2i :: BS2 f l t -undefbs2i = BS2 (-1) (-1) (-1) -{-# Inline undefbs2i #-} - -undefi :: Interface i -undefi = (-1) -{-# Inline undefi #-} - -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 c (u I) (BitSet O) 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 TableStaticVar c u (BS2 i j I) where - --- | We sometimes need - -data ThisThatNaught a b = This a | That b | Naught - diff --git a/ADP/Fusion/Base/Subword.hs b/ADP/Fusion/Base/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/Base/Subword.hs +++ /dev/null @@ -1,162 +0,0 @@ - --- | Instances to allow 'Subword's to be used as index structures in --- @ADPfusion@. - -module ADP.Fusion.Base.Subword where - -import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr) -import Debug.Trace -import Prelude hiding (map,filter) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base.Classes -import ADP.Fusion.Base.Multi - - - -instance RuleContext (Subword I) where - type Context (Subword I) = InsideContext () - initialContext _ = IStatic () - {-# Inline initialContext #-} - -instance RuleContext (Subword O) where - type Context (Subword O) = OutsideContext (Int:.Int) - initialContext _ = OStatic (0:.0) - {-# Inline initialContext #-} - -instance RuleContext (Subword C) where - type Context (Subword C) = ComplementContext - 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 --- conditional checks. @filter@ on the other hand, does work. --- --- TODO test with and without filter using quickcheck --- --- TODO shouldn't the new @staticCheck@ impl handle this? - -instance (Monad m) => MkStream m S (Subword I) where - mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j)) - -- = staticCheck (0<=i && i<=j) - = filter (const $ 0<=i && i<=j) - . singleton - . ElmS $ RiSwI i - mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j)) - -- = 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 $ 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 $ 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 $ 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 #-} - --- | --- --- TODO The @go@ here needs an explanation. - -instance (Monad m) => MkStream m S (Subword C) where - mkStream S Complemented (Subword (_:.h)) (Subword (i:.j)) - = map (\(k,l) -> ElmS $ RiSwC k l) - $ unfoldr go (i,i) - where go (k,l) - | k >h || k >j = Nothing - | l==h || l==j = Just ( (k,l) , (k+1,k+1) ) - | otherwise = Just ( (k,l) , (k ,l+1) ) - {-# Inline [0] go #-} - {-# Inline mkStream #-} - - - -instance - ( Monad m - , MkStream m S is --- , 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 (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) -> 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 (MinSize c) => TableStaticVar u c (Subword I) where - tableStaticVar _ _ (IStatic d) _ = IVariable d - tableStaticVar _ _ (IVariable d) _ = IVariable d - tableStreamIndex _ c _ (Subword (i:.j)) = subword i (j - minSize c) - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - --- | This instance is chosen if we consider an outside table (i.e. --- a syntactic variable) in an outside index. --- --- TODO @tableStreamIndex@ needs to be fixed - -instance TableStaticVar (u O) c (Subword O) where - tableStaticVar _ _ (OStatic d) _ = OFirstLeft d - tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d - tableStreamIndex _ c _ (Subword (i:.j)) = subword i j - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - --- | This instance is chosen if we consider an inside table (i.e. --- a terminal symbol!) in an outside index. --- --- TODO @tableStreamIndex@ needs to be fixed - -instance TableStaticVar (u I) c (Subword O) where - tableStaticVar _ _ (OStatic d) _ = ORightOf d - tableStaticVar _ _ (ORightOf d) _ = ORightOf d - tableStaticVar _ _ (OFirstLeft d) _ = OLeftOf d - tableStaticVar _ _ (OLeftOf d) _ = OLeftOf d - tableStreamIndex _ c _ (Subword (i:.j)) = subword i j - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - -instance TableStaticVar (u I) c (Subword C) where - tableStaticVar _ _ _ _ = Complemented - tableStreamIndex _ c _ (Subword (i:.j)) = subword i j - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - -instance TableStaticVar (u O) c (Subword C) where - tableStaticVar _ _ _ _ = Complemented - tableStreamIndex _ c _ (Subword (i:.j)) = subword i j - {-# INLINE [0] tableStaticVar #-} - {-# INLINE [0] tableStreamIndex #-} - diff --git a/ADP/Fusion/Base/Term.hs b/ADP/Fusion/Base/Term.hs deleted file mode 100644 --- a/ADP/Fusion/Base/Term.hs +++ /dev/null @@ -1,55 +0,0 @@ - -module ADP.Fusion.Base.Term where - -{- - -import Data.Vector.Fusion.Stream.Monadic -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base.Classes -import ADP.Fusion.Base.Multi - - - -data TermState s a i e = TState - { sS :: !s -- | state coming in from the left - , sIx :: !a -- | @I/C@ index from @sS@ - , sOx :: !a -- | @O@ index from @sS@ --- , tt :: !u -- | @I/C@ building up state to index the @table@. - , iIx :: !i -- | @I/C@ building up state to hand over to next symbol - , iOx :: !i -- | @O@ building up state to hand over to next symbol - , eTS :: !e -- | element data - } - -class TermStream m t a i where - termStream :: t -> Context i -> i -> i -> Stream m (TermState s a Z Z) -> Stream m (TermState s a i (TermArg t)) - -instance TermStream m M a Z where - termStream _ _ _ _ = id - {-# Inline termStream #-} - --- | --- --- TODO need @t -> ElmType t@ type function --- --- TODO need to actually return an @ElmType t@ can do that instead of --- returning @u@ !!! - -addTermStream1 - :: ( Monad m - , TermStream m (TermSymbol M t) (Z:.a) (Z:.i) - , s ~ Elm x0 a - , Element x0 a - ) - => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,i,i) -addTermStream1 t c u i - = map (\(TState sS _ _ (Z:.ii) (Z:.oo) (Z:.ee)) -> (sS,ee,ii,oo)) - . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i) - . map (\s -> TState s (Z:.getIdx s) (Z:.getOmx s) Z Z Z) -{-# Inline addTermStream1 #-} - - --} - diff --git a/ADP/Fusion/Base/TyLvlIx.hs b/ADP/Fusion/Base/TyLvlIx.hs deleted file mode 100644 --- a/ADP/Fusion/Base/TyLvlIx.hs +++ /dev/null @@ -1,109 +0,0 @@ - --- | Type-level indexing functionality - -module ADP.Fusion.Base.TyLvlIx where - -import Data.Proxy -import GHC.TypeLits - -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@. - -class GetIndexGo ixTy myTy (cmp :: Ordering) where - type ResolvedIx ixTy myTy cmp :: * - getIndexGo :: ixTy -> (Proxy myTy) -> (Proxy cmp) -> ResolvedIx ixTy myTy cmp - -instance GetIndexGo (ix:.i) (my:.m) EQ where - type ResolvedIx (ix:.i) (my:.m) EQ = i - getIndexGo (ix:.i) _ _ = i - {-# Inline getIndexGo #-} - -instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where - type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m))) - getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m)))) - {-# Inline getIndexGo #-} - -instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where - type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z)) - getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z))) - {-# Inline getIndexGo #-} - -instance GetIndexGo Z Z EQ where - type ResolvedIx Z Z EQ = Z - getIndexGo _ _ _ = Z - {-# Inline getIndexGo #-} - - - -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)) - -type GetIx l r = ResolvedIx l r (CmpNat (ToNat l) (ToNat r)) - --- | Simplifying wrapper around @getIndexGo@. - -getIndex - :: forall ixTy myTy - . GetIndex ixTy myTy - => ixTy - -> Proxy myTy - -> GetIx ixTy myTy -getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy))) -{-# Inline getIndex #-} - - - --- | Given some index structure @x@, return the dimensional number in --- @Nat@s. - -type family ToNat x :: Nat - -type instance ToNat Z = 0 -type instance ToNat (is:.i) = ToNat is + 1 -type instance ToNat (RunningIndex Z) = 0 -type instance ToNat (RunningIndex (is:.i)) = ToNat (RunningIndex is) + 1 - - - -{- - -testggg :: (Z:.Int:.Char) -> Int -testggg ab = getIndex ab (Proxy :: Proxy (Z:.Int)) -- (Z:.(3::Int)) -{-# NoInline testggg #-} - --} - diff --git a/ADP/Fusion/Base/Unit.hs b/ADP/Fusion/Base/Unit.hs deleted file mode 100644 --- a/ADP/Fusion/Base/Unit.hs +++ /dev/null @@ -1,98 +0,0 @@ - --- | --- --- TODO the 'mkStream' instances here are probably wonky for everything --- that is non-static. - -module ADP.Fusion.Base.Unit where - -import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) -import Debug.Trace -import Prelude hiding (map,filter) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base.Classes -import ADP.Fusion.Base.Multi - - - -instance RuleContext (Unit I) where - type Context (Unit I) = InsideContext () - initialContext _ = IStatic () - {-# Inline initialContext #-} - -instance RuleContext (Unit O) where - type Context (Unit O) = OutsideContext () - initialContext _ = OStatic () - {-# Inline initialContext #-} - -instance RuleContext (Unit C) where - type Context (Unit C) = ComplementContext - initialContext _ = Complemented - {-# Inline initialContext #-} - -data instance RunningIndex (Unit t) = RiU - - - -instance (Monad m) => MkStream m S (Unit I) where - mkStream S _ Unit Unit = singleton $ ElmS RiU - {-# Inline mkStream #-} - -instance (Monad m) => MkStream m S (Unit O) where - mkStream S _ Unit Unit = singleton $ ElmS RiU - {-# Inline mkStream #-} - -instance (Monad m) => MkStream m S (Unit C) where - mkStream S _ Unit Unit = singleton $ ElmS RiU - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.Unit I) where - mkStream S (vs:._) (us:._) (is:._) - = map (\(ElmS zi) -> ElmS $ zi :.: RiU) - $ mkStream S vs us is - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.Unit O) where - mkStream S (vs:._) (us:._) (is:._) - = map (\(ElmS zi) -> ElmS $ zi :.: RiU) - $ mkStream S vs us is - {-# Inline mkStream #-} - -instance - ( Monad m - , MkStream m S is - ) => MkStream m S (is:.Unit C) where - mkStream S (vs:._) (us:._) (is:._) - = map (\(ElmS zi) -> ElmS $ zi :.: RiU) - $ mkStream S vs us is - {-# Inline mkStream #-} - - - -instance TableStaticVar c u (Unit I) where - tableStaticVar _ _ _ _ = IStatic () - tableStreamIndex _ _ _ _ = Unit - {-# Inline [0] tableStaticVar #-} - {-# Inline [0] tableStreamIndex #-} - -instance TableStaticVar c u (Unit O) where - tableStaticVar _ _ _ _ = OStatic () - tableStreamIndex _ _ _ _ = Unit - {-# Inline [0] tableStaticVar #-} - {-# Inline [0] tableStreamIndex #-} - -instance TableStaticVar c u (Unit C) where - tableStaticVar _ _ _ _ = Complemented - tableStreamIndex _ _ _ _ = Unit - {-# Inline [0] tableStaticVar #-} - {-# Inline [0] tableStreamIndex #-} - - diff --git a/ADP/Fusion/Core.hs b/ADP/Fusion/Core.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core.hs @@ -0,0 +1,112 @@ + +-- | Generalized fusion system for grammars. +-- +-- This module re-exports only the core functionality. +-- +-- NOTE Symbols typically do not check bound data for consistency. If you, say, +-- bind a terminal symbol to an input of length 0 and then run your grammar, +-- you probably get errors, garbled data or random crashes. Such checks are +-- done via asserts in non-production code. + +module ADP.Fusion.Core + ( module ADP.Fusion.Core + , module ADP.Fusion.Core.Apply + , module ADP.Fusion.Core.Classes + , module ADP.Fusion.Core.Multi + , module ADP.Fusion.Core.TH + , module ADP.Fusion.Core.TyLvlIx + , module ADP.Fusion.SynVar.Array.Type + , module ADP.Fusion.SynVar.Axiom + , module ADP.Fusion.SynVar.Backtrack + , module ADP.Fusion.SynVar.Fill + , module ADP.Fusion.SynVar.Indices.Classes + , module ADP.Fusion.SynVar.Recursive.Type + , module ADP.Fusion.SynVar.Split.Type + , module ADP.Fusion.SynVar.TableWrap + , module ADP.Fusion.Term.Chr.Type + , module ADP.Fusion.Term.Deletion.Type + , module ADP.Fusion.Term.Edge.Type + , module ADP.Fusion.Term.Epsilon.Type + , module ADP.Fusion.Term.PeekIndex.Type + , module ADP.Fusion.Term.Strng.Type + , module Data.Vector.Fusion.Stream.Monadic + , module Data.Vector.Fusion.Util + ) where + +import Data.Vector.Fusion.Stream.Monadic (Stream (..)) +import Data.Strict.Tuple +import GHC.Exts (inline) +import qualified Data.Vector.Fusion.Stream.Monadic as S +import Data.Vector.Fusion.Util (Id(..)) + +import Data.PrimitiveArray + +import ADP.Fusion.Core.Apply +import ADP.Fusion.Core.Classes hiding (iIx) +import ADP.Fusion.Core.Multi hiding (iIx) +import ADP.Fusion.Core.TH +import ADP.Fusion.Core.TyLvlIx +import ADP.Fusion.SynVar.Array.Type +import ADP.Fusion.SynVar.Axiom +import ADP.Fusion.SynVar.Backtrack +import ADP.Fusion.SynVar.Fill +import ADP.Fusion.SynVar.Indices.Classes +import ADP.Fusion.SynVar.Recursive.Type +import ADP.Fusion.SynVar.Split.Type +import ADP.Fusion.SynVar.TableWrap +import ADP.Fusion.Term.Chr.Type +import ADP.Fusion.Term.Deletion.Type +import ADP.Fusion.Term.Edge.Type +import ADP.Fusion.Term.Epsilon.Type +import ADP.Fusion.Term.PeekIndex.Type +import ADP.Fusion.Term.Strng.Type + + + +-- | Apply a function to symbols on the RHS of a production rule. Builds the +-- stack of symbols from 'xs' using 'build', then hands this stack to +-- 'mkStream' together with the initial 'iniT' telling 'mkStream' that we are +-- in the "outer" position. Once the stream has been created, we 'S.map' +-- 'getArg' to get just the arguments in the stack, and finally 'apply' the +-- function 'f'. + +infixl 8 <<< +(<<<) f xs = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij +{-# INLINE (<<<) #-} + +infixl 8 <<# +(<<#) f xs = \lu ij -> S.mapM (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij +{-# INLINE (<<#) #-} + +-- | Combine two RHSs to give a choice between parses. + +infixl 7 ||| +(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu ij +{-# INLINE (|||) #-} + +-- | Applies the objective function 'h' to a stream 's'. The objective function +-- reduces the stream to a single optimal value (or some vector of co-optimal +-- things). + +infixl 5 ... +(...) s h = \lu ij -> (inline h) $ s lu ij +{-# INLINE (...) #-} + +-- -- | Additional outer check with user-given check function +-- +-- infixl 6 `check` +-- check xs f = \ij -> let chk = f ij in chk `seq` outerCheck chk (xs ij) +-- {-# INLINE check #-} + +-- | Separator between RHS symbols. + +infixl 9 ~~ +(~~) = (:!:) +{-# INLINE (~~) #-} + +-- | This separator looks much paper "on paper" and is not widely used otherwise. + +infixl 9 % +(%) = (:!:) +{-# INLINE (%) #-} + diff --git a/ADP/Fusion/Core/Apply.hs b/ADP/Fusion/Core/Apply.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Apply.hs @@ -0,0 +1,89 @@ + +module ADP.Fusion.Core.Apply where + +--import Data.Array.Repa.Index +import Data.PrimitiveArray (Z(..), (:.)(..)) + + + +-- * Apply function 'f' in '(<<<)' + +class Apply x where + type Fun x :: * + apply :: Fun x -> x + +instance Apply (Z:.a -> res) where + type Fun (Z:.a -> res) = a -> res + apply fun (Z:.a) = fun a + {-# INLINE apply #-} + +instance Apply (Z:.a:.b -> res) where + type Fun (Z:.a:.b -> res) = a->b -> res + apply fun (Z:.a:.b) = fun a b + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c -> res) where + type Fun (Z:.a:.b:.c -> res) = a->b->c -> res + apply fun (Z:.a:.b:.c) = fun a b c + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d -> res) where + type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res + apply fun (Z:.a:.b:.c:.d) = fun a b c d + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e -> res) where + type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res + apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res + apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o + {-# INLINE apply #-} + diff --git a/ADP/Fusion/Core/Classes.hs b/ADP/Fusion/Core/Classes.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Classes.hs @@ -0,0 +1,216 @@ + +{-# Language MagicHash #-} + +module ADP.Fusion.Core.Classes where + +import Data.Proxy +import Data.Strict.Tuple +import GHC.Exts hiding (build) +import qualified Data.Vector.Fusion.Stream.Monadic as S + +import Data.PrimitiveArray + + + +data OutsideContext s + = OStatic s + | ORightOf s + | OFirstLeft s + | OLeftOf s + deriving (Show) + +data InsideContext s + = IStatic s + | IVariable s + deriving (Show) + +data ComplementContext + = Complemented + deriving (Show) + +class RuleContext i where + type Context i :: * + 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 . 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 +-- characters we parse from an input) and the type of indices @i@ we use. +-- +-- @Elm@ data constructors are all eradicated during fusion and should never +-- show up in CORE. + +class Element x i where + data Elm x i :: * + type RecElm x i :: * + type Arg x :: * + getArg :: Elm x i -> Arg x + 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 +-- to functions on the left of the @(<<<)@ operator. Streams work over all +-- monads and are specialized for each combination of arguments @x@ and indices +-- @i@. + +class (Monad m) => MkStream m x i where + mkStream :: x -> Context i -> i -> i -> S.Stream m (Elm x i) + +-- | Finally, we need to be able to correctly build together symbols on the +-- right-hand side of the @(<<<)@ operator. +-- +-- The default makes sure that the last (or only) argument left over is +-- correctly assigned a @Z@ to terminate the symbol stack. + +class Build x where + type Stack x :: * + type Stack x = S :!: x + build :: x -> Stack x + default build :: (Stack x ~ (S :!: x)) => x -> Stack x + build x = S :!: x + {-# Inline build #-} + +instance Build x => Build (x:!:y) where + type Stack (x:!:y) = Stack x :!: y + build (x:!:y) = build x :!: y + {-# Inline build #-} + +-- | Similar to 'Z', but terminates an argument stack. + +data S = S + deriving (Eq,Show) + +instance + ( + ) => Element S i where + data Elm S i = ElmS !(RunningIndex i) + type Arg S = Z + getArg (ElmS _) = Z + getIdx (ElmS i) = i + {-# Inline getArg #-} + {-# Inline getIdx #-} + +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. + +staticCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a +staticCheck b (S.Stream step t) = b `seq` S.Stream snew (CheckLeft b t) where + {-# Inline [0] snew #-} + snew (CheckLeft False _) = return $ S.Done + snew (CheckLeft True s) = return $ S.Skip (CheckRight s) + snew (CheckRight s ) = do r <- step s + case r of + S.Yield x s' -> return $ S.Yield x (CheckRight s') + S.Skip s' -> return $ S.Skip (CheckRight s') + S.Done -> return $ S.Done +{-# INLINE staticCheck #-} + +data StaticCheck a b = CheckLeft Bool a | CheckRight b + +staticCheck# :: Monad m => Int# -> S.Stream m a -> S.Stream m a +staticCheck# !b (S.Stream step t) = S.Stream snew (SL t b) where + {-# Inline [0] snew #-} + snew (SL s k) + | 1# <- k = return $ S.Skip (SR s) + | otherwise = return $ S.Done + snew (SR s ) = do r <- step s + case r of + S.Yield x s' -> return $ S.Yield x (SR s') + S.Skip s' -> return $ S.Skip (SR s') + S.Done -> return $ S.Done +{-# Inline staticCheck# #-} + + +data SLR z = SL !z !Int# | SR !z + +-- | Constrains the behaviour of the memoizing tables. They may be 'EmptyOk' if +-- @i==j@ is allowed (empty subwords or similar); or they may need 'NonEmpty' +-- 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 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 [0] minSize #-} +-} + +-- | +-- +-- TODO Rewrite to generalize easily over multi-dim cases. + +class ModifyConstraint t where + type TNE t :: * + type TE t :: * + toNonEmpty :: t -> TNE t + toEmpty :: t -> TE t + +-- +--instance ModifyConstraint EmptyOk +-- type TNE EmptyOk = NonEmpty +-- type TE EmptyOk = + +-- | + +--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 + diff --git a/ADP/Fusion/Core/Multi.hs b/ADP/Fusion/Core/Multi.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Multi.hs @@ -0,0 +1,226 @@ + +module ADP.Fusion.Core.Multi where + +import qualified Data.Vector.Fusion.Stream.Monadic as S +import Data.Vector.Fusion.Stream.Monadic +import Data.Strict.Tuple +import Data.Proxy +import Prelude hiding (map) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.TyLvlIx + + + +-- * Multi-dimensional extension + +-- | Terminates a multi-dimensional terminal symbol stack. + +data M = M + deriving (Eq,Show) + +infixl 2 :| + +-- | Terminal symbols are stacked together with @a@ tails and @b@ head. + +data TermSymbol a b = a :| b + deriving (Eq,Show) + +instance Build (TermSymbol a b) + +-- | Extracts the type of a multi-dimensional terminal argument. + +type family TermArg x :: * +type instance TermArg M = Z +type instance TermArg (TermSymbol a b) = TermArg a :. TermArg b + +instance (Element ls i) => Element (ls :!: TermSymbol a b) i where + data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !(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 + {-# INLINE getArg #-} + {-# INLINE getIdx #-} + +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 + , TermStaticVar (TermSymbol a b) 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 ee) -> ElmTS ee ii sS) + . termStream ts sv lu i + . 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 #-} + +instance Monad m => MkStream m S Z where + mkStream _ _ _ _ = S.singleton (ElmS RiZ) + {-# INLINE mkStream #-} + +-- | For multi-dimensional terminals we need to be able to calculate how the +-- static/variable signal changes and if the index for the inner part needs to +-- be modified. + +class TermStaticVar t i where + termStaticVar :: t -> Context i -> i -> Context i + termStreamIndex :: t -> Context i -> i -> i + +instance TermStaticVar M Z where + termStaticVar _ _ _ = Z + termStreamIndex _ _ _ = Z + {-# INLINE [0] termStaticVar #-} + {-# INLINE [0] termStreamIndex #-} + +instance + ( TermStaticVar a is + , TermStaticVar b i + ) => 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 [0] termStaticVar #-} + {-# INLINE [0] 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 +-- +--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 #-} + +--toTerminalStream s = S5 s Z Z (getIdx s) (getOmx s) +--{-# INLINE toTerminalStream #-} + +instance RuleContext Z where + type Context Z = Z + initialContext _ = Z + {-# INLINE initialContext #-} + +instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where + type Context (is:.i) = Context is:.Context i + initialContext (is:.i) = initialContext is:.initialContext i + {-# INLINE initialContext #-} + +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 c u Z where + tableStaticVar _ _ _ _ = Z + tableStreamIndex _ _ _ _ = Z + {-# INLINE [0] tableStaticVar #-} + {-# INLINE [0] tableStreamIndex #-} + +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 #-} + {-# INLINE [0] tableStreamIndex #-} + + + +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 + } + +--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 #-} + +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 #-} + +-- | +-- +-- TODO need @t -> ElmType t@ type function +-- +-- TODO need to actually return an @ElmType t@ can do that instead of +-- returning @u@ !!! + +addTermStream1 + :: ( Monad m + , TermStream m (TermSymbol M t) (Elm (Term1 s) (Z:.i)) (Z:.i) + ) + => t -> Context i -> i -> i -> Stream m s -> Stream m (s,TermArg t,RunningIndex i) +addTermStream1 t c u i + = map (\(TState (ElmTerm1 sS) (RiZ:.:ii) (Z:.ee)) -> (sS,ee,ii)) + . termStream (M:|t) (Z:.c) (Z:.u) (Z:.i) + . 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) (Elm (Term1 (Elm ls i)) (Z:.i)) (Z:.i) + , Element ls i + , TermStaticVar t i + ) + +-- | @Term TermStream@ context + +--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 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)) + diff --git a/ADP/Fusion/Core/Point.hs b/ADP/Fusion/Core/Point.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Point.hs @@ -0,0 +1,121 @@ + +{-# Language MagicHash #-} + +module ADP.Fusion.Core.Point where + +import Data.Proxy +import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) +import Debug.Trace +import Prelude hiding (map,filter) +import GHC.Exts + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +instance RuleContext (PointL I) where + type Context (PointL I) = InsideContext Int + initialContext _ = IStatic 0 + {-# Inline initialContext #-} + +instance RuleContext (PointL O) where + type Context (PointL O) = OutsideContext Int + initialContext _ = OStatic 0 + {-# Inline initialContext #-} + +instance RuleContext (PointL C) where + type Context (PointL C) = ComplementContext + initialContext _ = Complemented + {-# Inline initialContext #-} + +newtype instance RunningIndex (PointL I) = RiPlI Int + +data instance RunningIndex (PointL O) = RiPlO !Int !Int + +data instance RunningIndex (PointL C) = RiPlC !Int + + + +instance (Monad m) => MkStream m S (PointL I) where + mkStream S (IStatic (I# d)) (PointL (I# u)) (PointL (I# i)) +-- = staticCheck (isTrue# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) ) -- (i>=0 && i<=d && i<=u) + = staticCheck# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) +-- = filter (const (isTrue# ( (i >=# 0#) `andI#` (i <=# d) `andI#` (i <=# d) ) )) + . singleton . ElmS $ RiPlI 0 + mkStream S (IVariable _) (PointL (I# u)) (PointL (I# i)) +-- = staticCheck (isTrue# ( (i >=# 0#) `andI#` (i <=# u) ) ) -- (i>=0 && i<=u) + = staticCheck# ( (i >=# 0#) `andI#` (i <=# u) ) +-- = filter (const (isTrue# ( (i >=# 0#) `andI#` (i <=# u) ) )) + . singleton . ElmS $ RiPlI 0 + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m S is + ) => MkStream m S (is:.PointL I) where + mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i) + = map (\(ElmS zi) -> ElmS $ zi :.: RiPlI 0) + . staticCheck (i>=0 && i<=d && i<=u) + $ mkStream S vs lus is + mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i) + = 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 + ) => 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) -> 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) -> ElmS $ zi :.: RiPlO i (i+d)) + $ mkStream S vs us is + {-# Inline mkStream #-} + + + +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) = PointL $ j - minSize c + {-# INLINE [0] tableStaticVar #-} + {-# INLINE [0] tableStreamIndex #-} + +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 #-} + diff --git a/ADP/Fusion/Core/TH.hs b/ADP/Fusion/Core/TH.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/TH.hs @@ -0,0 +1,77 @@ + +-- | The functions in here auto-create suitable algebra product functions from +-- a signature. Currently, functions @<**@ are supported which have scalar +-- results in the first variable. +-- +-- TODO If we want to support classified DP, we shall also need @**<@ +-- generating vector-results given a vector result, followed by a scalar +-- result. +-- +-- TODO Then we also need @***@ handling the case of vector-to-vector results. +-- +-- TODO note the comments in @buildBacktrackingChoice@ + +module ADP.Fusion.Core.TH + ( makeAlgebraProduct + , (<||) + , (**>) + ) where + +import Data.List +import Data.Tuple.Select +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import qualified Data.Vector.Fusion.Stream.Monadic as SM + +import ADP.Fusion.Core.TH.Backtrack -- (makeBacktrackingProductInstance,(<||)) +import ADP.Fusion.Core.TH.Common (getRuleResultType) + + + +makeAlgebraProduct = makeProductInstances + +{- +-- | Create the algebra product function from a signature type constructor. +-- +-- TODO make the resulting function INLINE +-- +-- TODO compare @synTypes@ with the stream argument types of all @hs@ (via their +-- @hns@ names). If there is a mismatch, then either not all non-terminal types +-- have a corresponding choice function or vice versa. + +makeAlgebraProductH :: [Name] -> Name -> Q [Dec] +makeAlgebraProductH hns nm = do + rnm <- reify nm + case rnm of + TyConI (DataD ctx tyConName args cs d) -> case cs of + -- we analyze the accessor functions and look for the objective function + -- accessor. It's stream parameter is the type of the non-terminal. + -- Everything else in accessors are terminal parameters. + [RecC dataConName fs'] -> do + -- split @fs@ into functions applied to rule RHSs and choice functions (@hs@) + let (fs,hs) = partition ((`notElem` hns) . sel1) fs' + -- the result types of the @fs@ are the types of the non-terminal symbols + let synTypes = nub . map getRuleResultType $ fs +-- funStream <- funD (mkName "<**") [genClauseStream dataConName fs' fs hs] + funList <- funD (mkName "<||") [genClauseBacktrack dataConName fs' fs hs] + return +-- [ funStream + [ funList + , PragmaD $ InlineP (mkName "<||") Inline FunLike AllPhases + ] + _ -> fail "more than one data ctor" + _ -> fail "unsupported data type" + +-- | Creates a class for each type of product and instances for each +-- signature. + +makeClassyProducts :: Name -> Q [Dec] +makeClassyProducts conName = do + c <- lookupValueName "BacktrackingProduct" + case c of + Nothing -> error "need to create class now and add instance" + Just cl -> error "add instance" + return [] +-} + + diff --git a/ADP/Fusion/Core/TH/Backtrack.hs b/ADP/Fusion/Core/TH/Backtrack.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/TH/Backtrack.hs @@ -0,0 +1,498 @@ + +-- | Backtracking which uses lists internally. The basic idea is to convert +-- each @Stream@ into a list. The consumer consumes the stream lazily, but +-- allows for fusion to happen. The hope is that this improves total +-- performance in those cases, where backtracking has significant costs. + +module ADP.Fusion.Core.TH.Backtrack where + +import Control.Applicative ( (<$>) ) +import Control.Monad +import Control.Monad.Primitive (PrimState, PrimMonad) +import Data.List +import Data.Tuple.Select +import Data.Vector.Fusion.Stream.Monadic (Stream(..)) +import Debug.Trace +import Language.Haskell.TH +import Language.Haskell.TH.Instances +import Language.Haskell.TH.Syntax +import qualified Data.Map.Strict as M +import qualified Data.Vector as V +import qualified Data.Vector.Fusion.Stream.Monadic as SM +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Mutable as VM +import qualified Data.Set as S + +import Data.PrimitiveArray ( (:.)(..) , Z(..) ) + +import ADP.Fusion.Core.TH.Common + +import Control.Monad.Reader + + + +-- | @Backtracking@ products of @f@ and @b@. Choice in @f@ needs to be +-- reduced to a scalar value. It is then compared to the @fst@ values +-- in @b@. From those, @choice b@ selects. + +class ProductBacktracking sigF sigB where + type SigBacktracking sigF sigB :: * + (<||) :: sigF -> sigB -> SigBacktracking sigF sigB + +-- | The ADP-established product operation. Returns a vector of results, +-- along the lines of what the ADP @f *** b@ provides. +-- +-- @f **> g@ assumes a vector-to-vector function @f@, and +-- a vector-to-scalar function @g@. + +class ProductCombining sigF sigB where + type SigCombining sigF sigB :: * + (**>) :: sigF -> sigB -> SigCombining sigF sigB + +-- | Creates instances for all products given a signature data type. + +makeProductInstances :: Name -> Q [Dec] +makeProductInstances tyconName = do + t <- reify tyconName + case t of +#if MIN_VERSION_template_haskell(2,11,0) + TyConI (DataD ctx tyConName args maybeKind cs d) -> do +#else + TyConI (DataD ctx tyConName args cs d) -> do +#endif + let m = getMonadName args + case cs of + [RecC dataconName funs] -> do + let Just (h,m',x,r) = getObjectiveNames funs + mL <- newName "mL" + xL <- newName "xL" + rL <- newName "rL" + mR <- newName "mR" + xR <- newName "xR" + rR <- newName "rR" + let lType = buildRightType tyconName (m', x, r) (mL, xL, rL) args + let rType = buildRightType tyconName (m', x, r) (mR, xR, rR) args + let (fs,hs) = partition ((`notElem` [h]) . sel1) funs + sigBType <- buildSigBacktrackingType tyconName (m', x, r) xL (mR, xR, rR) args + Clause psB (NormalB bB) dsB <- genAlgProdFunctions buildBacktrackingChoice dataconName funs fs hs + iB <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR), $(varT xL) ~ $(varT rL)) + => ProductBacktracking $(return lType) $(return rType) where + type SigBacktracking $(return lType) $(return rType) = $(return sigBType) + (<||) = $(return $ LamE psB $ LetE dsB bB) + {-# Inline (<||) #-} + |] + -- TODO might well be that this doesn't work because we re-use + -- type names ... + vG <- newName "vG" + sigPType <- buildSigCombiningType tyconName vG (m', x, r) (mL, xL, rL) (mR, xR, rR) args + Clause psC (NormalB bC) dsC <- genAlgProdFunctions buildCombiningChoice dataconName funs fs hs + iC <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), Ord $(varT xL), Ord $(varT xR), $(varT mL) ~ $(varT mR) ) -- , VG.Vector $(varT vG) ($(varT rL),$(varT rR)) ) + => ProductCombining $(return lType) $(return rType) where + type SigCombining $(return lType) $(return rType) = $(return sigPType) + (**>) = $(return $ LamE psC $ LetE dsC bC) + {-# Inline (**>) #-} + |] + return $ iB ++ iC + +-- | Returns the 'Name' of the monad variable. + +getMonadName :: [TyVarBndr] -> Maybe Name +getMonadName = go + where go [] = Nothing + go (KindedTV m (AppT (AppT ArrowT StarT) StarT) : _) = Just m + go (_ : xs) = go xs + +-- | Returns the 'Name's of the objective function variables, as well as +-- the name of the objective function itself. + +getObjectiveNames :: [VarStrictType] -> Maybe (Name,Name,Name,Name) +getObjectiveNames = go + where go [] = Nothing + go ( (hName , _ , (AppT (AppT ArrowT (AppT (AppT (ConT streamName) (VarT mS)) (VarT x))) (AppT (VarT mR) (VarT r)))) : xs) + | streamName == ''Stream && mS == mR = Just (hName,mS,x,r) + | otherwise = go xs + go ( _ : xs) = go xs + + + +-- * Constructions for the different algebra types. + +-- | The left algebra type. Assumes that in @choice :: Stream m x -> m r@ +-- we have that @x ~ r@. + +buildLeftType :: Name -> (Name, Name, Name) -> (Name, Name) -> [TyVarBndr] -> Type +buildLeftType tycon (m, x, r) (mL, xL) = foldl AppT (ConT tycon) . map (VarT . go) + where go (PlainTV z) + | z == m = mL -- correct monad name + | z == x = xL -- point to new x type + | z == r = xL -- stream and return type are the same + | otherwise = z -- everything else can stay as is + go (KindedTV z _) = go (PlainTV z) + +-- | Here, we do not set any restrictions on the types @m@ and @r@. + +buildRightType :: Name -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type +buildRightType tycon (m, x, r) (mR, xR, rR) = foldl AppT (ConT tycon) . map (VarT . go) + where go (PlainTV z) + | z == m = mR -- have discovered a monadic type + | z == x = xR -- have discovered a type that is equal to the stream type (and hence we have a synvar type) + | z == r = rR -- have discovered a type that is equal to the result type (for @<||@) equal to the stream type, hence synvar + | otherwise = z -- this is a terminal or a terminal stack (we don't care) + go (KindedTV z _) = go (PlainTV z) + +-- | Build up the type for backtracking. We want laziness in the right +-- return type. Hence, we have @AppT ListT (VarT xR)@ ; i.e. we want to +-- return results in a list. + +buildSigBacktrackingType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ +buildSigBacktrackingType tycon (m, x, r) (xL) (mR, xR, rR) = foldl appT (conT tycon) . map go + where go (PlainTV z) + | z == m = varT mR + | z == x = [t| ($(varT xL) , [ $(varT xR) ] ) |] + | z == r = varT rR + | otherwise = varT z + go (KindedTV z _) = go (PlainTV z) + +-- | +-- +-- [1] we want a list for @[xR]@ because this will make it lazy here. At +-- least that was the reason for backtracking. For forward mode, we may not +-- want this. We will have to change the function combination then? + +buildSigCombiningType :: Name -> Name -> (Name, Name, Name) -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ +buildSigCombiningType tycon vG (m, x, r) (mL, xL, rL) (mR, xR, rR) = foldl appT (conT tycon) . map go + where go (PlainTV z) + | z == m = varT mR + | z == x = [t| ($(varT xL) , [ $(varT xR) ] ) |] -- [1] + | z == r = [t| V.Vector ($(varT rL) , $(varT rR)) |] + | otherwise = varT z + go (KindedTV z _) = go (PlainTV z) + + + +-- * + +-- | Build up attribute and choice function. Here, we actually bind the +-- left and right algebra to @l@ and @r@. + +genAlgProdFunctions + :: Choice + -> Name + -> [VarStrictType] + -> [VarStrictType] + -> [VarStrictType] + -> Q Clause +genAlgProdFunctions choice conName allFunNames evalFunNames choiceFunNames = do + let nonTermNames = nub . map getRuleResultType $ evalFunNames + -- bind the l'eft and r'ight variable of the two algebras we want to join, + -- also create unique names for the function names we shall bind later. + nameL <- newName "l" + varL <- varP nameL + fnmsL <- sequence $ replicate (length allFunNames) (newName "fnamL") + nameR <- newName "r" + varR <- varP nameR + fnmsR <- sequence $ replicate (length allFunNames) (newName "fnamR") + -- bind the individual variables in the where part + whereL <- valD (conP conName (map varP fnmsL)) (normalB $ varE nameL) [] + whereR <- valD (conP conName (map varP fnmsR)) (normalB $ varE nameR) [] + rce <- recConE conName + $ zipWith3 (genChoiceFunction choice) (drop (length evalFunNames) fnmsL) (drop (length evalFunNames) fnmsR) choiceFunNames + ++ zipWith3 (genAttributeFunction nonTermNames) fnmsL fnmsR evalFunNames + -- build the function pairs + -- to keep our sanity, lets print this stuff + let cls = Clause [varL, varR] (NormalB rce) [whereL,whereR] + return cls + +-- | Simple wrapper for creating the choice fun expression. + +genChoiceFunction + :: Choice + -> Name + -> Name + -> VarStrictType + -> Q (Name,Exp) +genChoiceFunction choice hL hR (name,_,t) = do + exp <- choice hL hR + return (name,exp) + + +-- | We take the left and right function name for one attribute and build +-- up the combined attribute function. Mostly a wrapper around +-- 'recBuildLampat' which does the main work. +-- +-- TODO need fun names from @l@ and @r@ + +genAttributeFunction + :: [Name] + -> Name + -> Name + -> VarStrictType + -> Q (Name,Exp) +genAttributeFunction nts fL fR (name,_,t) = do + (lamPat,funL,funR) <-recBuildLamPat nts fL fR (init $ getRuleSynVarNames nts t) -- @init@ since we don't want the result as a parameter + let exp = LamE lamPat $ TupE [funL,funR] + return (name,exp) + +-- | Now things become trickly. We are given all non-terminal names (to +-- differentiate between a terminal (stack) and a syntactic variable; the +-- left and right function; and the arguments to this attribute function +-- (except the result parameter). We are given the latter as a result to an +-- earlier call to 'getRuleSynVarNames'. +-- +-- We now look at each argument and determine wether it is a syntactic +-- variable. If so, then we actually have a tuple arguments @(x,ys)@ where +-- @x@ has to optimized value and @ys@ the backtracking list. The left +-- function receives just @x@ in this case. For the right function, things +-- are more complicated, since we have to flatten lists. See 'buildRns'. +-- +-- Terminals are always given "as is" since we do not have a need for +-- tupled-up information as we have for syntactic variables. + +recBuildLamPat + :: [Name] -- ^ all non-terminal names + -> Name -- ^ left attribute function + -> Name -- ^ right attribute function + -> [ArgTy Name] -- ^ all arguments to the attribute function + -> Q ([Pat], Exp, Exp) +recBuildLamPat nts fL' fR' ts = do + -- here we just run through all arguments, either creating an @x@ and + -- a @ys@ for a non-term or a @t@ for a term. + ps <- mapM argTyArgs ts + lamPat <- buildLamPat ps + lfun <- buildLns (VarE fL') ps -- foldl buildLfun (varE fL') ps + rfun <- buildRns (VarE fR') ps + return (lamPat, lfun, rfun) + +buildLamPat :: [ArgTy Pat] -> Q [Pat] +buildLamPat = mapM go where + go (SynVar p ) = return p + go (Term p ) = return p + go (StackedVars ps) = build ps + build :: [ArgTy Pat] -> Q Pat + build = foldl (\s v -> [p| $(s) :. $(return v) |]) [p|Z|] . map get + get :: ArgTy Pat -> Pat + get (SynVar p) = p + get (Term p) = p + +-- | Look at the argument type and build the capturing variables. In +-- particular captures synvar arguments with a 2-tuple @(x,ys)@. + +argTyArgs :: ArgTy Name -> Q (ArgTy Pat) +argTyArgs (SynVar n) = SynVar <$> tupP [newName "x" >>= varP , newName "ys" >>= varP] +argTyArgs (Term n) = Term <$> (newName "t" >>= varP) +argTyArgs (StackedTerms _) = Term <$> (newName "t" >>= varP) -- !!! +argTyArgs (StackedVars vs) = StackedVars <$> mapM argTyArgs vs +argTyArgs NilVar = Term <$> (newName "t" >>= varP) +argTyArgs (Result _) = error "argTyArgs: should not receive @Result@" + +buildLns + :: Exp + -> [ArgTy Pat] + -> ExpQ +buildLns f' ps = foldl go (return f') ps + where go :: ExpQ -> ArgTy Pat -> ExpQ + go f (SynVar (TupP [VarP v,_])) = appE f (varE v) + go f (Term (VarP v )) = appE f (varE v) + go f (StackedVars vs ) = appE f (build vs) + build :: [ArgTy Pat] -> ExpQ + build = foldl (\s v -> [| $(s) :. $(varE v) |]) [|Z|] . map get + get (SynVar (TupP [VarP v,_])) = v + get (Term (VarP t) ) = t + +-- | Build the right-hand side of a function combined in @f <|| g@. This +-- splits the paired synvars @(x,xs)@ such that we calculate @f x@ and @g +-- xs@. +-- +-- NOTE If we want to write +-- +-- @ +-- [ f x | x <- xs ] +-- @ +-- +-- then in template haskell, this looks like this: +-- +-- @ +-- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))] +-- @ +-- +-- The @NoBindS@ is the final binding of @f@ to the individual @x@'s, while +-- the prior @x <- xs@ comes from @BindS (VarP x) (VarE xs)@. +-- +-- TODO This is where we might be able to improve performance if we can +-- optimize @[f x y | x <- xs, y <- ys]@ for @concatMap@ in @vector@. + +buildRns + :: Exp +-- -> [Name] + -> [ArgTy Pat] + -> ExpQ +buildRns f' ps = do + -- get all synvars, shallow or deep and create a new name to bind + -- individual parts to. + sy :: M.Map Pat Name <- M.fromList <$> (mapM (\s -> newName "y" >>= \y -> return (s,y)) $ concatMap flattenSynVars ps) + -- bind them for the right part of the list expression (even though they + -- are left in @CompE@. We don't use @sy@ directly to keep the order in + -- which the comprehensions run. + let rs = map (\k@(TupP [_,VarP v]) -> BindS (VarP $ sy M.! k) (VarE v)) $ concatMap flattenSynVars ps + let go :: ExpQ -> ArgTy Pat -> ExpQ + go f (SynVar k ) = appE f (varE $ sy M.! k) -- needed like this, because we need the @y@ in @y <- ys@ + go f (Term (VarP v)) = appE f (varE v) + go f (StackedVars vs ) = appE f (foldl build [|Z|] vs) + build :: ExpQ -> ArgTy Pat -> ExpQ + build s (SynVar k ) = [| $(s) :. $(varE $ sy M.! k) |] + build s (Term (VarP v)) = [| $(s) :. $(varE v) |] + funApp <- foldl go (return f') ps + return . CompE $ rs ++ [NoBindS funApp] + + +-- | Type for backtracking functions. +-- +-- Not too interesting, mostly to keep track of @choice@. + +type Choice = Name -> Name -> Q Exp + +-- | Build up the backtracking choice function. This choice function will +-- backtrack based on the first result, then return only the second. +-- +-- TODO it should be (only?) this function we will need to modify to build +-- all algebra products. +-- +-- @ysM@ can't be unboxed, as @snd@ of each element is a list, lazily +-- consumed. We build up @ysM@ as this makes fusion happen. Of course, this +-- is a boxed vector and not as efficient, but we gain the ability to have +-- lazily created backtracking from this! +-- +-- This means strict optimization AND lazy backtracking +-- +-- TODO in principle, we do more work than necessary. The line +-- @hFres <- ...@ evaluates the optimal choice from the @fst@ elements +-- again. As long as the cost is small compared to the evaluation of @snd@ +-- (or the list-comprehension based creation of all parses), this won't +-- matter much. + +buildBacktrackingChoice :: Choice +buildBacktrackingChoice hL' hR' = + [| \xs -> do + -- turn the stream into a list + ysM <- SM.toList xs + -- based only on the @fst@ elements, select optimal value + hFres <- $(varE hL') $ SM.map fst $ SM.fromList ysM + -- filter accordingly + $(varE hR') $ SM.fromList $ concatMap snd $ filter ((hFres==) . fst) $ ysM + |] + +-- | We assume parses of type @(x,y)@ in a vector @<(x,y)>@. the function +-- acting on @x@ will produce a subset @@ (in vector form). the function +-- acting on @y@ produces scalars @y@. We have @actFst :: -> @ and +-- @actSnd :: -> y@. This in total should yield @<(x,y)> -> <(x,y)>@. +-- +-- TODO This should create @generic@ vectors, that are specialized by the +-- table they are stored into. + +buildCombiningChoice :: Choice +buildCombiningChoice hL' hR' = + [| \xs -> do + -- -- lets begin with the list of parses + -- ys <- SM.toList xs + -- -- but now, we actually get a list of co-optimals to keep. Yes, + -- -- a @[fst]@ list. + -- cooptFsts <- S.fromList <$> ( ( $(varE hL') $ SM.map fst $ SM.fromList ys ) >>= SM.toList ) + -- -- now we create a map with all the coopts, where we collect in the + -- -- value parts the list of parses for each co-optimal @snd@ for + -- -- a @fst@. + -- let cooptMap = M.fromListWith (++) [ y | y <- ys, y `S.member` cooptFsts ] + -- -- We now need to map @actSnd@ over the resulting intermediates + -- actSnd <- mapM (\y -> $(varE hR') (SM.fromList y)) cooptMap + -- -- a vector with co-optimals, each one associated with its optimal + -- -- @snd@. + -- return . VG.fromList . M.toList $ actSnd + return undefined + |] + +-- | Turn a stream into a vector. +-- +-- TODO need to be improved in terms of performance. + +streamToVectorM :: (Monad m, VG.Vector v a) => SM.Stream m a -> m (v a) +streamToVectorM s = SM.toList s >>= return . VG.fromList +{-# Inline streamToVectorM #-} + +-- | Gets the names used in the evaluation function. This returns one +-- 'Name' for each variable. +-- +-- In case of @TupleT 0@ the type is @()@ and there isn't a name to go with +-- it. We just @mkName "()"@ a name, but this might be slightly dangerous? +-- (Not really sure if it indeed is) +-- +-- With @AppT _ _@ we have a multidim terminal and produce another hackish +-- name to be consumed above. +-- +-- @ +-- AppT (AppT ArrowT (AppT (AppT (ConT Data.Array.Repa.Index.:.) (AppT (AppT (ConT Data.Array.Repa.Index.:.) (ConT Data.Array.Repa.Index.Z)) (VarT c_1627675270))) (VarT c_1627675270))) (VarT x_1627675265) +-- @ + +getRuleSynVarNames :: [Name]-> Type -> [ArgTy Name] -- [Name] +getRuleSynVarNames nts t' = go t' where + go t + | VarT x <- t = [Result x] + | AppT (AppT ArrowT (VarT x) ) y <- t = (if x `elem` nts then SynVar x else Term x) : go y + | AppT (AppT ArrowT (TupleT 0)) y <- t = NilVar : go y + | AppT (AppT ArrowT s ) y <- t = stacked s : go y + | otherwise = error $ "getRuleSynVarNames error: " ++ show t ++ " in: " ++ show t' + stacked s = if null [ () | SynVar _ <- xs ] then StackedTerms xs else StackedVars xs + where xs = reverse $ stckd s + stckd (ConT z) | z == ''Z = [] + stckd (AppT a (TupleT 0)) = NilVar : stckd a + stckd (AppT a (VarT x) ) = (if x `elem` nts then SynVar x else Term x) : stckd a + stckd (AppT (ConT c) a ) | c == ''(:.) = stckd a + stckd err = error $ "stckd" ++ show err + +{- +(AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.) + (AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.) + (ConT Data.PrimitiveArray.Index.Class.Z) + ) + (VarT x_1627774371) + ) + ) + (TupleT 0) +) +-} + + +data ArgTy x + -- | This @SynVar@ spans the full column of tapes; i.e. it is a normal + -- syntactic variable. + = SynVar { synVarName :: x } + -- | We have just a single-tape grammar and as such just + -- a single-dimensional terminal. We call this term, because + -- @StackedTerms@ will be rewritten to just @Term@! + | Term { termName :: x } + -- | We have a multi-tape grammar with a stack of just terminals. We + -- normally can ignore the contents in the functions above, but keep them + -- anyway. + | StackedTerms { stackedTerms :: [ArgTy x] } + -- | We have a multi-tape grammar, but the stack contains a mixture of + -- @ArgTy@s. + | StackedVars { stackedVars :: [ArgTy x] } + -- | A single-dim @()@ case + | NilVar + -- | The result type name + | Result { result :: x } + deriving (Show,Eq) + +unpackArgTy :: Show x => ArgTy x -> x +unpackArgTy = go + where go (SynVar x) = x + go (Term x) = x + go (Result x) = x + go err = error $ "unpackArgTy " ++ show err + +-- | Get all synvars, even if deep in a stack + +flattenSynVars :: ArgTy x -> [x] +flattenSynVars (SynVar x) = [x] +flattenSynVars (StackedVars xs) = concatMap flattenSynVars xs +flattenSynVars _ = [] + diff --git a/ADP/Fusion/Core/TH/Common.hs b/ADP/Fusion/Core/TH/Common.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/TH/Common.hs @@ -0,0 +1,19 @@ + +module ADP.Fusion.Core.TH.Common where + +import Data.Tuple.Select +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + + + +-- | The last @Name@ of a rule is the name of the syntactic type of the +-- result. + +getRuleResultType :: VarStrictType -> Name +getRuleResultType vst = go $ sel3 vst where + go t + | AppT _ (VarT x) <- t = x + | AppT _ x <- t = go x + | otherwise = error $ "undetermined error:" ++ show vst + diff --git a/ADP/Fusion/Core/TyLvlIx.hs b/ADP/Fusion/Core/TyLvlIx.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/TyLvlIx.hs @@ -0,0 +1,109 @@ + +-- | Type-level indexing functionality + +module ADP.Fusion.Core.TyLvlIx where + +import Data.Proxy +import GHC.TypeLits + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.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@. + +class GetIndexGo ixTy myTy (cmp :: Ordering) where + type ResolvedIx ixTy myTy cmp :: * + getIndexGo :: ixTy -> (Proxy myTy) -> (Proxy cmp) -> ResolvedIx ixTy myTy cmp + +instance GetIndexGo (ix:.i) (my:.m) EQ where + type ResolvedIx (ix:.i) (my:.m) EQ = i + getIndexGo (ix:.i) _ _ = i + {-# Inline getIndexGo #-} + +instance (GetIndexGo ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m)))) => GetIndexGo (ix:.i) (my:.m) GT where + type ResolvedIx (ix:.i) (my:.m) GT = ResolvedIx ix (my:.m) (CmpNat (ToNat ix) (ToNat (my:.m))) + getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat (my:.m)))) + {-# Inline getIndexGo #-} + +instance (GetIndexGo ix Z (CmpNat (ToNat ix) (ToNat Z))) => GetIndexGo (ix:.i) Z GT where + type ResolvedIx (ix:.i) Z GT = ResolvedIx ix Z (CmpNat (ToNat ix) (ToNat Z)) + getIndexGo (ix:._) p _ = getIndexGo ix p (Proxy :: Proxy (CmpNat (ToNat ix) (ToNat Z))) + {-# Inline getIndexGo #-} + +instance GetIndexGo Z Z EQ where + type ResolvedIx Z Z EQ = Z + getIndexGo _ _ _ = Z + {-# Inline getIndexGo #-} + + + +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)) + +type GetIx l r = ResolvedIx l r (CmpNat (ToNat l) (ToNat r)) + +-- | Simplifying wrapper around @getIndexGo@. + +getIndex + :: forall ixTy myTy + . GetIndex ixTy myTy + => ixTy + -> Proxy myTy + -> GetIx ixTy myTy +getIndex ixTy myTy = getIndexGo ixTy (Proxy :: Proxy myTy) (Proxy :: Proxy (CmpNat (ToNat ixTy) (ToNat myTy))) +{-# Inline getIndex #-} + + + +-- | Given some index structure @x@, return the dimensional number in +-- @Nat@s. + +type family ToNat x :: Nat + +type instance ToNat Z = 0 +type instance ToNat (is:.i) = ToNat is + 1 +type instance ToNat (RunningIndex Z) = 0 +type instance ToNat (RunningIndex (is:.i)) = ToNat (RunningIndex is) + 1 + + + +{- + +testggg :: (Z:.Int:.Char) -> Int +testggg ab = getIndex ab (Proxy :: Proxy (Z:.Int)) -- (Z:.(3::Int)) +{-# NoInline testggg #-} + +-} + diff --git a/ADP/Fusion/Core/Unit.hs b/ADP/Fusion/Core/Unit.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Unit.hs @@ -0,0 +1,98 @@ + +-- | +-- +-- TODO the 'mkStream' instances here are probably wonky for everything +-- that is non-static. + +module ADP.Fusion.Core.Unit where + +import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..)) +import Debug.Trace +import Prelude hiding (map,filter) + +import Data.PrimitiveArray hiding (map) + +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + + + +instance RuleContext (Unit I) where + type Context (Unit I) = InsideContext () + initialContext _ = IStatic () + {-# Inline initialContext #-} + +instance RuleContext (Unit O) where + type Context (Unit O) = OutsideContext () + initialContext _ = OStatic () + {-# Inline initialContext #-} + +instance RuleContext (Unit C) where + type Context (Unit C) = ComplementContext + initialContext _ = Complemented + {-# Inline initialContext #-} + +data instance RunningIndex (Unit t) = RiU + + + +instance (Monad m) => MkStream m S (Unit I) where + mkStream S _ Unit Unit = singleton $ ElmS RiU + {-# Inline mkStream #-} + +instance (Monad m) => MkStream m S (Unit O) where + mkStream S _ Unit Unit = singleton $ ElmS RiU + {-# Inline mkStream #-} + +instance (Monad m) => MkStream m S (Unit C) where + mkStream S _ Unit Unit = singleton $ ElmS RiU + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m S is + ) => MkStream m S (is:.Unit I) where + mkStream S (vs:._) (us:._) (is:._) + = map (\(ElmS zi) -> ElmS $ zi :.: RiU) + $ mkStream S vs us is + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m S is + ) => MkStream m S (is:.Unit O) where + mkStream S (vs:._) (us:._) (is:._) + = map (\(ElmS zi) -> ElmS $ zi :.: RiU) + $ mkStream S vs us is + {-# Inline mkStream #-} + +instance + ( Monad m + , MkStream m S is + ) => MkStream m S (is:.Unit C) where + mkStream S (vs:._) (us:._) (is:._) + = map (\(ElmS zi) -> ElmS $ zi :.: RiU) + $ mkStream S vs us is + {-# Inline mkStream #-} + + + +instance TableStaticVar c u (Unit I) where + tableStaticVar _ _ _ _ = IStatic () + tableStreamIndex _ _ _ _ = Unit + {-# Inline [0] tableStaticVar #-} + {-# Inline [0] tableStreamIndex #-} + +instance TableStaticVar c u (Unit O) where + tableStaticVar _ _ _ _ = OStatic () + tableStreamIndex _ _ _ _ = Unit + {-# Inline [0] tableStaticVar #-} + {-# Inline [0] tableStreamIndex #-} + +instance TableStaticVar c u (Unit C) where + tableStaticVar _ _ _ _ = Complemented + tableStreamIndex _ _ _ _ = Unit + {-# Inline [0] tableStaticVar #-} + {-# Inline [0] tableStreamIndex #-} + + diff --git a/ADP/Fusion/Point.hs b/ADP/Fusion/Point.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Point.hs @@ -0,0 +1,25 @@ + +-- | This exports everything needed for sequence-based alignment style +-- algorithms. + +module ADP.Fusion.Point + ( module ADP.Fusion.Core + , module ADP.Fusion.Core.Point + , module ADP.Fusion.SynVar.Indices.Point + , module ADP.Fusion.SynVar.Recursive.Point + , module ADP.Fusion.Term.Chr.Point + , module ADP.Fusion.Term.Deletion.Point + , module ADP.Fusion.Term.Strng.Point + , module ADP.Fusion.Term.Epsilon.Point + ) where + +import ADP.Fusion.Core + +import ADP.Fusion.Core.Point +import ADP.Fusion.SynVar.Recursive.Point +import ADP.Fusion.Term.Chr.Point +import ADP.Fusion.Term.Deletion.Point +import ADP.Fusion.Term.Epsilon.Point +import ADP.Fusion.Term.Strng.Point +import ADP.Fusion.SynVar.Indices.Point + diff --git a/ADP/Fusion/SynVar.hs b/ADP/Fusion/SynVar.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar.hs +++ /dev/null @@ -1,19 +0,0 @@ - --- | This module re-exports all table types. - -module ADP.Fusion.SynVar - ( module ADP.Fusion.SynVar.Array - , module ADP.Fusion.SynVar.Axiom - , module ADP.Fusion.SynVar.Backtrack - , module ADP.Fusion.SynVar.Fill - , module ADP.Fusion.SynVar.Recursive - , module ADP.Fusion.SynVar.Split - ) where - -import ADP.Fusion.SynVar.Array -import ADP.Fusion.SynVar.Axiom -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Fill -import ADP.Fusion.SynVar.Recursive -import ADP.Fusion.SynVar.Split - diff --git a/ADP/Fusion/SynVar/Array.hs b/ADP/Fusion/SynVar/Array.hs --- a/ADP/Fusion/SynVar/Array.hs +++ b/ADP/Fusion/SynVar/Array.hs @@ -12,12 +12,12 @@ import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Indices - -import ADP.Fusion.SynVar.Array.TermSymbol +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Array.Type +import ADP.Fusion.SynVar.Backtrack +import ADP.Fusion.SynVar.Indices.Classes +import ADP.Fusion.SynVar.TableWrap @@ -35,12 +35,12 @@ iTblStream :: forall m ls arr x u c i . ITblCx m ls arr x u c i - => Pair ls (ITbl m arr c u x) + => Pair ls (TwITbl m arr c u x) -> Context i -> i -> i - -> Stream m (Elm (ls :!: ITbl m arr c u x) i) -iTblStream (ls :!: ITbl _ _ c t _) vs us is + -> Stream m (Elm (ls :!: TwITbl m arr c u x) i) +iTblStream (ls :!: TW (ITbl _ _ c t) _) vs us is = 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) @@ -50,12 +50,12 @@ btITblStream :: 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) + => Pair ls (TwITblBt arr c u x mF mB r) -> Context i -> i -> 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 + -> Stream mB (Elm (ls :!: TwITblBt arr c u x mF mB r) i) +btITblStream (ls :!: TW (BtITbl c t) bt) vs us is = 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) @@ -69,54 +69,54 @@ instance ( Monad m , ITblCx m ls arr x u c (i I) - ) => MkStream m (ls :!: ITbl m arr c u x) (i I) where + ) => MkStream m (ls :!: TwITbl m arr c u x) (i I) where mkStream = iTblStream {-# Inline mkStream #-} instance ( Monad m , ITblCx m ls arr x u c (i O) - ) => MkStream m (ls :!: ITbl m arr c u x) (i O) where + ) => MkStream m (ls :!: TwITbl m arr c u x) (i O) where mkStream = iTblStream {-# Inline mkStream #-} instance ( Monad m , ITblCx m ls arr x u c (i C) - ) => MkStream m (ls :!: ITbl m arr c u x) (i C) where + ) => MkStream m (ls :!: TwITbl m arr c u x) (i C) where mkStream = iTblStream {-# Inline mkStream #-} instance ( Monad mB , 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 mB (ls :!: TwITblBt arr c u x mF mB r) (i I) where mkStream = btITblStream {-# Inline mkStream #-} instance ( Monad mB , 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 mB (ls :!: TwITblBt arr c u x mF mB r) (i O) where mkStream = btITblStream {-# Inline mkStream #-} instance ( Monad mB , 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 mB (ls :!: TwITblBt arr c u x mF mB r) (i C) where mkStream = btITblStream {-# Inline mkStream #-} -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 +instance ModifyConstraint (TwITbl m arr EmptyOk i x) where + type TNE (TwITbl m arr EmptyOk i x) = TwITbl m arr NonEmpty i x + type TE (TwITbl m arr EmptyOk i x) = TwITbl m arr EmptyOk i x + toNonEmpty (TW (ITbl b l _ arr) f) = TW (ITbl b l NonEmpty arr) f {-# Inline toNonEmpty #-} -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 +instance ModifyConstraint (TwITblBt arr EmptyOk i x mF mB r) where + type TNE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr NonEmpty i x mF mB r + type TE (TwITblBt arr EmptyOk i x mF mB r) = TwITblBt arr EmptyOk i x mF mB r + toNonEmpty (TW (BtITbl _ arr) bt) = TW (BtITbl NonEmpty arr) bt {-# Inline toNonEmpty #-} diff --git a/ADP/Fusion/SynVar/Array/TermSymbol.hs b/ADP/Fusion/SynVar/Array/TermSymbol.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Array/TermSymbol.hs +++ /dev/null @@ -1,172 +0,0 @@ - --- | TODO migrate instances to correct modules --- --- TODO need to find out if we can reduce the total number of instances --- required here. Probably not trivial since there are, in principle, @n*m@ --- instances that we need to handle. - -module ADP.Fusion.SynVar.Array.TermSymbol where - -import Data.Proxy -import Data.Strict.Tuple hiding (snd) -import Data.Vector.Fusion.Util (delay_inline) -import Data.Vector.Fusion.Stream.Monadic hiding (flatten) -import Debug.Trace -import Prelude hiding (map,mapM) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Backtrack - - - --- | --- --- TODO need to handle @minSize@ conditions! - -instance - ( TstCtx m ts s x0 i0 is (Subword I) - , PrimArrayOps arr (Subword I) x - ) => 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 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 ii ee) = - let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I)) - in return (tstate, l, j - l) - step (tstate@(TState s ii ee), k, z) - | z >= 0 = do let l = j - z - kl = subword k l - return $ Yield (TState s (ii:.:RiSwI l) (ee:.t!kl)) (tstate, k, z-1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline termStream #-} - --- | --- --- TODO can we combine the @ITbl@ and @BtITbl@ code again? - -instance - ( TstCtx mB ts s x0 i0 is (Subword I) - , PrimArrayOps arr (Subword I) x - ) => 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 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 ii ee) = - let RiSwI l = getIndex (getIdx s) (Proxy :: PRI is (Subword I)) - in return (tstate, l, j - l) - 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 (ii:.:RiSwI l) (ee:.(t!kl,bb))) (tstate, k, z-1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline termStream #-} - --- | TODO need to deal with @minSize@ - ---instance --- ( Monad m --- , TerminalStream m a is --- , PrimArrayOps arr (Subword I) x --- , Show x --- ) => TerminalStream m (TermSymbol a (ITbl m arr (Subword I) x)) (is:.Subword I) where --- terminalStream (a :| ITbl _ _ c t _) (sv:.IStatic _) (is:.ix@(Subword (i:.j))) --- = map (\ (S6 s (zi:.(Subword (a:.l))) (zo:._) is os e) -> --- let lj = subword l j --- in {- traceShow (i,a,' ',l,j,t!lj) $ -} S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj)) ) --- . iPackTerminalStream a sv (is:.ix) --- terminalStream (a :| ITbl _ _ c t _) (sv:.IVariable _) (is:.ix@(Subword (i:.j))) --- = flatten mk step . iPackTerminalStream a sv (is:.ix) --- where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c ! --- step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6 --- l = j - z --- kl = subword k l --- return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1) --- | otherwise = return $ Done --- {-# Inline [0] mk #-} --- {-# Inline [0] step #-} --- {-# Inline terminalStream #-} - ---instance --- ( Monad mB --- , TerminalStream mB a is --- , PrimArrayOps arr (Subword I) x --- ) => TerminalStream mB (TermSymbol a (Backtrack (ITbl mF arr (Subword I) x) mF mB r)) (is:.Subword I) where --- terminalStream (a :| BtITbl c t bt) (sv:.IStatic _) (is:.ix@(Subword (i:.j))) --- = mapM (\ (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) -> --- let lj = subword l j --- hh = snd $ bounds t --- in bt hh lj >>= \ ~bb -> return $ S6 s zi zo (is:.lj) (os:.subword 0 0) (e:.(t!lj, bb)) ) --- . iPackTerminalStream a sv (is:.ix) --- terminalStream (a :| BtITbl c t bt) (sv:.IVariable _) (is:.ix@(Subword (i:.j))) --- = flatten mk step . iPackTerminalStream a sv (is:.ix) --- where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c ! --- step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6 --- l = j - z --- kl = subword k l --- hh = snd $ bounds t --- bt hh kl >>= \ ~bb -> return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl,bb))) (s6 :. k :. z-1) --- | otherwise = return $ Done --- {-# Inline [0] mk #-} --- {-# Inline [0] step #-} --- {-# Inline terminalStream #-} - - -instance TermStaticVar (ITbl m arr 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 ! - termStreamIndex (ITbl _ _ _ _ _) (IVariable d) (Subword (i:.j)) = subword i j -- TODO minsize handling - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -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 ! - termStreamIndex (BtITbl _ _ _) (IVariable d) (Subword (i:.j)) = subword i j -- TODO minsize handling - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - - -{- - mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j)) - = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c)) - where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c) - step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s - l = j - z - kl = subword k l - return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1) - | otherwise = return $ Done - - terminalStream (a:|Chr f v) (sv:.IVariable _) (is:.ix@(Subword (i:.j))) - = S.map (\(S6 s (zi:.Subword (_:.l)) (zo:._) is os e) -> S6 s zi zo (is:.subword l (l+1)) (os:.subword 0 0) (e:.f v l)) - . iPackTerminalStream a sv (is:.ix) - {-# Inline terminalStream #-} - -instance TermStaticVar (Chr r x) Subword where - termStaticVar _ sv _ = sv - termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1) - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - --} - diff --git a/ADP/Fusion/SynVar/Array/Type.hs b/ADP/Fusion/SynVar/Array/Type.hs --- a/ADP/Fusion/SynVar/Array/Type.hs +++ b/ADP/Fusion/SynVar/Array/Type.hs @@ -12,34 +12,41 @@ import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Axiom import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Indices +import ADP.Fusion.SynVar.Indices.Classes +import ADP.Fusion.SynVar.TableWrap -- | Immutable table. -data ITbl m arr c i x where - ITbl :: { iTblBigOrder :: !Int - , iTblLittleOrder :: !Int +data ITbl arr c i x where + ITbl :: { iTblBigOrder :: {-# Unpack #-} !Int + , iTblLittleOrder :: {-# Unpack #-} !Int , iTblConstraint :: !c , iTblArray :: !(arr i x) - , iTblFun :: !(i -> i -> m x) - } -> ITbl m arr c i x + } -> ITbl arr c i x -instance Build (ITbl m arr c i x) +type TwITbl m arr c i x = TW (ITbl arr c i x) (i -> i -> m x) -type instance TermArg (ITbl m arr c i x) = x +type TwITblBt arr c i x mF mB r = TW (Backtrack (TwITbl mF arr c i x) mF mB) (i -> i -> mB [r]) -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 +instance Build (TwITbl m arr c i x) + +instance Build (TwITblBt arr c i x mF mB r) + +type instance TermArg (TwITbl m arr c i x) = x + +instance GenBacktrackTable (TwITbl mF arr c i x) mF mB where + data Backtrack (TwITbl mF arr c i x) mF mB = BtITbl !c !(arr i x) -- !(i -> i -> mB [r]) + type BacktrackIndex (TwITbl mF arr c i x) = i + toBacktrack (TW (ITbl _ _ c arr) _) _ = BtITbl c arr {-# Inline toBacktrack #-} -type instance TermArg (Backtrack (ITbl mF arr c i x) mF mB r) = (x,[r]) +type instance TermArg (TwITblBt arr c i x mF mB r) = (x,[r]) @@ -49,20 +56,25 @@ ( Monad m , PrimArrayOps arr i x , IndexStream i - ) => Axiom (ITbl m arr c i x) where - type AxiomStream (ITbl m arr c i x) = m x - axiom (ITbl _ _ c arr _) = do + ) => Axiom (TwITbl m arr c i x) where + type AxiomStream (TwITbl m arr c i x) = m x + axiom (TW (ITbl _ _ c arr) _) = do k <- (head . uncurry streamDown) $ bounds arr return $ arr ! k {-# Inline axiom #-} +-- | We need this somewhat annoying instance construction (@i ~ j@ and @m +-- ~ mB@) in order to force selection of this instance. + instance ( Monad mB , PrimArrayOps arr i x , IndexStream i - ) => 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 + , j ~ i + , m ~ mB + ) => Axiom (TW (Backtrack (TwITbl mF arr c i x) mF mB) (j -> j -> m [r])) where + type AxiomStream (TW (Backtrack (TwITbl mF arr c i x) mF mB) (j -> j -> m [r])) = mB [r] + axiom (TW (BtITbl c arr) bt) = do h <- (head . uncurry streamDown) $ bounds arr bt (snd $ bounds arr) h {-# Inline axiom #-} @@ -71,10 +83,10 @@ -- * 'Element' -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 +instance Element ls i => Element (ls :!: TwITbl m arr c j x) i where + data Elm (ls :!: TwITbl m arr c j x) i = ElmITbl !x !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: TwITbl m arr c j x) = Arg ls :. x + type RecElm (ls :!: TwITbl m arr c j x) i = Elm ls i getArg (ElmITbl x _ ls) = getArg ls :. x getIdx (ElmITbl _ i _ ) = i getElm (ElmITbl _ _ ls) = ls @@ -82,12 +94,12 @@ {-# Inline getIdx #-} {-# Inline getElm #-} -deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr c j x) i) +deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i), Show x) => Show (Elm (ls :!: TwITbl m arr c j x) i) -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 +instance Element ls i => Element (ls :!: TwITblBt arr c j x mF mB r) i where + data Elm (ls :!: TwITblBt arr c j x mF mB r) i = ElmBtITbl !x [r] !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: TwITblBt arr c j x mF mB r) = Arg ls :. (x, [r]) + type RecElm (ls :!: TwITblBt 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 @@ -95,7 +107,7 @@ {-# Inline getIdx #-} {-# Inline getElm #-} -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 +instance (Show x, Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: TwITblBt arr c i x mF mB r) i) where show (ElmBtITbl x _ i s) = show (x,i) ++ " " ++ show s @@ -109,8 +121,8 @@ , 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 (cs:.c) (us:.u) x) (is:.i) where - mkStream (ls :!: ITbl _ _ c t _) vs us is + ) => MkStream m (ls :!: TwITbl m arr (cs:.c) (us:.u) x) (is:.i) where + mkStream (ls :!: TW (ITbl _ _ c t) _) vs us is = 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) @@ -123,8 +135,8 @@ , 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 (cs:.c) (us:.u) x) mF mB r) (is:.i) where - mkStream (ls :!: BtITbl c t bt) vs us is + ) => MkStream mB (ls :!: TwITblBt arr (cs:.c) (us:.u) x mF mB r) (is:.i) where + mkStream (ls :!: TW (BtITbl c t) bt) vs us is = 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) diff --git a/ADP/Fusion/SynVar/Backtrack.hs b/ADP/Fusion/SynVar/Backtrack.hs --- a/ADP/Fusion/SynVar/Backtrack.hs +++ b/ADP/Fusion/SynVar/Backtrack.hs @@ -6,7 +6,7 @@ import Data.Vector.Fusion.Stream.Monadic (Stream) -import ADP.Fusion.Base +import ADP.Fusion.SynVar.TableWrap @@ -19,10 +19,10 @@ -- @mB@ so as to be able to extract forward results in the backtracking -- phase. -class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) r where - data Backtrack t (mF :: * -> *) (mB :: * -> *) r :: * +class GenBacktrackTable t (mF :: * -> *) (mB :: * -> *) where + data Backtrack t (mF :: * -> *) (mB :: * -> *) :: * type BacktrackIndex t :: * - toBacktrack :: t -> (forall a . mF a -> mB a) -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -> Backtrack t mF mB r + toBacktrack :: t -> (forall a . mF a -> mB a) {- -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -} -> Backtrack t mF mB -instance Build (Backtrack t mF mB r) +-- instance Build (TW (Backtrack t mF mB) f) diff --git a/ADP/Fusion/SynVar/Fill.hs b/ADP/Fusion/SynVar/Fill.hs --- a/ADP/Fusion/SynVar/Fill.hs +++ b/ADP/Fusion/SynVar/Fill.hs @@ -17,7 +17,8 @@ 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 ADP.Fusion.SynVar.Recursive.Type +import ADP.Fusion.SynVar.TableWrap import Debug.Trace @@ -95,15 +96,15 @@ {-# Inline tableLittleOrder #-} {-# Inline tableBigOrder #-} -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 +instance (TableOrder ts) => TableOrder (ts:.TwITbl im arr c i x) where + tableLittleOrder (ts:.TW (ITbl _ tlo _ _) _) = tlo : tableLittleOrder ts + tableBigOrder (ts:.TW (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 +instance (TableOrder ts) => TableOrder (ts:.TwIRec im c i x) where tableLittleOrder (ts:._) = tableLittleOrder ts tableBigOrder (ts:._) = tableBigOrder ts {-# Inline tableLittleOrder #-} @@ -120,7 +121,7 @@ instance ( MutateCell CFG ts im om i , PrimMonad om - ) => MutateCell CFG (ts:.IRec im c i x) im om i where + ) => MutateCell CFG (ts:.TwIRec 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 #-} @@ -130,8 +131,8 @@ , MPrimArrayOps arr i x , MutateCell CFG ts im om i , PrimMonad om - ) => 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 CFG (ts:.TwITbl im arr c i x) im om i where + mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu i = do mutateCell h bo lo mrph ts lu i when (bo==tbo && lo==tlo) $ do marr <- unsafeThaw arr @@ -146,8 +147,8 @@ , MPrimArrayOps arr ZS2 x , MutateCell MonotoneMCFG ts im om ZS2 , PrimMonad om - ) => 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 MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im om ZS2 where + mutateCell h bo lo mrph (ts:.TW (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 marr <- unsafeThaw arr @@ -160,8 +161,8 @@ , MPrimArrayOps arr (Subword I) x , MutateCell h ts im om (Z:.Subword I:.Subword I) , PrimMonad om - ) => 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 (ts:.TwITbl im arr c (Subword I) x) im om (Z:.Subword I:.Subword I) where + mutateCell h bo lo mrph (ts:.TW (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 let i = i1 @@ -178,13 +179,13 @@ instance ( Monad om - , MutateCell h (ts:.ITbl im arr c i x) im om i + , MutateCell h (ts:.TwITbl im arr c i x) im om i , PrimArrayOps arr i x , Show i , IndexStream i - , 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 + , TableOrder (ts:.TwITbl im arr c i x) + ) => MutateTables h (ts:.TwITbl im arr c i x) im om where + mutateTables h mrph tt@(_:.TW (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 diff --git a/ADP/Fusion/SynVar/Indices.hs b/ADP/Fusion/SynVar/Indices.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Indices.hs +++ /dev/null @@ -1,164 +0,0 @@ - --- | With 'tableIndices' we create a stream of legal indices for this table. We --- need 'tableIndices' in multi-dimensional tables as the type of the --- multi-dimensional indices is generic. - -module ADP.Fusion.SynVar.Indices - ( module ADP.Fusion.SynVar.Indices.Classes - , module ADP.Fusion.SynVar.Indices.Point - , module ADP.Fusion.SynVar.Indices.Set0 - , module ADP.Fusion.SynVar.Indices.Subword - , module ADP.Fusion.SynVar.Indices.Unit - ) where - -import ADP.Fusion.SynVar.Indices.Classes -import ADP.Fusion.SynVar.Indices.Point -import ADP.Fusion.SynVar.Indices.Set0 -import ADP.Fusion.SynVar.Indices.Subword -import ADP.Fusion.SynVar.Indices.Unit - - -{- -import Data.Vector.Fusion.Stream.Size (Size(Unknown)) -import Data.Vector.Fusion.Stream.Monadic (flatten,map,Stream, Step(..)) -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base - - - - - -class TableIndices i where - tableIndices :: (Monad m) => TblConstraint i -> Context i -> i -> Stream m (S5 z j j i i) -> Stream m (S5 z j j i i) - -instance TableIndices Z where - tableIndices _ _ _ = id - {-# INLINE tableIndices #-} - -instance TableIndices (Outside Z) where - tableIndices _ _ _ = id - {-# INLINE tableIndices #-} - -instance TableIndices is => TableIndices (is:.Subword) where - tableIndices (cs:._) (vs:.IStatic _) (ixs:.Subword (i:.j)) - = map (\(S5 s (zi:.Subword (_:.l)) (zo:._) is os) -> S5 s zi zo (is:.subword l j) (os:.subword 0 0)) - . tableIndices cs vs ixs - . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os) - -- TODO ? using the defns in TermSymbol.hs for Array syns? - {- - tableIndices (cs:._) (vs:.IVariable _) (ixs:.Subword (i:.j)) - = map (\(S5 s (zi:.Subword (_:.l)) (zo:._) is os) -> S5 s zi zo (is:.subword l j) (os:.subword 0 0)) - . tableIndices cs vs ixs - . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os) - -} - -- TODO minsize handling ? constraint handling? - tableIndices (cs:._) (vs:.IVariable _) (ixs:.Subword (i:.j)) - = flatten mk step Unknown - . tableIndices cs vs ixs - . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os) - where mk (S5 s (zi:.Subword (_:.l)) (zo:._) is os) = return (S5 s zi zo is os :. l :. j - l) - step (s5:.k:.z) | z >= 0 = do let S5 s zi zo is os = s5 - l = j - z - kl = subword k l - return $ Yield (S5 s zi zo (is:.kl) (os:.subword 0 0)) (s5 :. k :. z-1) - | otherwise = return $ Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline tableIndices #-} - -{- - where mk (S6 s (zi:.(Subword (_:.l))) (zo:._) is os e) = return (S6 s zi zo is os e :. l :. j - l) -- TODO minsize c ! - step (s6:.k:.z) | z >= 0 = do let S6 s zi zo is os e = s6 - l = j - z - kl = subword k l - return $ Yield (S6 s zi zo (is:.kl) (os:.subword 0 0) (e:.(t!kl))) (s6 :. k :. z-1) - | otherwise = return $ Done --} - -{- - tableIndices (cs:.c) (vs:.Static) (is:.Subword (i:.j)) - = S.map (\(Tr s (x:.Subword (_:.l)) ys) -> Tr s x (is:.subword l j)) -- constraint handled: tableStreamIndex - . tableIndices cs vs is - . S.map moveIdxTr - tableIndices (cs:.OnlyZero) _ _ = error "write me" - tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.Subword (i:.j)) - = S.flatten mk step Unknown - . tableIndices cs vs is - . S.map moveIdxTr - where mk (Tr s (y:.Subword (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c) - step (Pn s y xs k z) - | z>= 0 = return $ S.Yield (Tr s y (xs:.subword k (j-z))) (Pn s y xs k (z-1)) - | otherwise = return $ S.Done - {-# INLINE [1] mk #-} - {-# INLINE [1] step #-} - {-# INLINE tableIndices #-} --} - --- | TODO I think we need to check @cs:.c@ here --- --- TODO yes, handle @Empty@ / @NonEmpty@ !!! - -instance TableIndices is => TableIndices (is:.PointL) where - tableIndices (cs:._) (vs:.IStatic _) (is:.PointL j) - = map (\(S5 s (zi:.PointL _) (zo:.PointL _) is os) -> S5 s zi zo (is:.PointL j) (os:.PointL 0)) -- constraint handled: tableStreamIndex - . tableIndices cs vs is - . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os) - tableIndices (cs:._) (vs:.IVariable d) (is:.PointL j) - = flatten mk step Unknown - . tableIndices cs vs is - . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os) - where mk s@(S5 _ (_:.PointL k) _ _ _) = return (s :. k) - step (ss@(S5 s (zi:._) (zo:._) is os) :. k) - | k > j = return $ Done - | otherwise = return $ Yield (S5 s zi zo (is:.PointL k) (os:.PointL 0)) (ss :. k+1) - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {- TODO re-add later - tableIndices (cs:.OnlyZero) _ _ = error "write me" - tableIndices (cs:.c) (vs:.IVariable) (is:.PointL j) - = flatten mk step Unknown - . tableIndices cs vs is - . map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os) - where mk (S5 s (zi:.PointL l) (zo:._) is os) = return $ S6 s zi zo is os (j-l-minSize c) - step (S6 s zi zo is os x) - | x >= 0 = return $ Yield (S5 s zi zo (is:.PointL (j-x)) (os:.PointL 0)) (S6 s zi zo is os (x-1)) - | otherwise = return $ Done - {-# Inline [1] mk #-} - {-# Inline [1] step #-} - -} - {-# Inline tableIndices #-} - -instance TableIndices (Outside is) => TableIndices (Outside (is:.PointL)) where - tableIndices (cs:.c) (vs:.OStatic d) (O (is:.PointL j)) - = map (\(S5 s (zi:.PointL i) (zo:.PointL o) (O is) (O os)) -> S5 s zi zo (O (is:.PointL i)) (O (os:.PointL o))) -- constraint handled: tableStreamIndex - . tableIndices cs vs (O is) - . map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os)) - {-# Inline tableIndices #-} - -{- -instance TableIndices is => TableIndices (is:.PointR) where - tableIndices (cs:.c) (vs:.Static) (is:.PointR (i:.j)) - = S.map (\(Tr s (x:.PointR (_:.l)) ys) -> Tr s x (is:.pointR l j)) -- constraint handled: tableStreamIndex - . tableIndices cs vs is - . S.map moveIdxTr - tableIndices (cs:.OnlyZero) _ _ = error "write me" - tableIndices (cs:.c) (vs:.Variable _ Nothing) (is:.PointR (i:.j)) - = S.flatten mk step Unknown - . tableIndices cs vs is - . S.map moveIdxTr - where mk (Tr s (y:.PointR (_:.l)) xs) = return $ Pn s y xs l (j-l-minSize c) - step (Pn s y xs k z) - | z>= 0 = return $ S.Yield (Tr s y (xs:.pointR k (j-z))) (Pn s y xs k (z-1)) - | otherwise = return $ S.Done - {-# INLINE [1] mk #-} - {-# INLINE [1] step #-} - {-# INLINE tableIndices #-} --} - - - --} - diff --git a/ADP/Fusion/SynVar/Indices/Classes.hs b/ADP/Fusion/SynVar/Indices/Classes.hs --- a/ADP/Fusion/SynVar/Indices/Classes.hs +++ b/ADP/Fusion/SynVar/Indices/Classes.hs @@ -12,7 +12,9 @@ import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi +import ADP.Fusion.Core.TyLvlIx diff --git a/ADP/Fusion/SynVar/Indices/Point.hs b/ADP/Fusion/SynVar/Indices/Point.hs --- a/ADP/Fusion/SynVar/Indices/Point.hs +++ b/ADP/Fusion/SynVar/Indices/Point.hs @@ -9,7 +9,8 @@ import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base +import ADP.Fusion.Core +import ADP.Fusion.Core.Point import ADP.Fusion.SynVar.Indices.Classes diff --git a/ADP/Fusion/SynVar/Indices/Set0.hs b/ADP/Fusion/SynVar/Indices/Set0.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Indices/Set0.hs +++ /dev/null @@ -1,157 +0,0 @@ - --- | @Set0@ provides index movement for sets with no interfaces. --- --- TODO Sets with 1 and 2 interfaces will go into @Set1@ and @Set2@ --- modules. - -module ADP.Fusion.SynVar.Indices.Set0 where - -import Data.Proxy -import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..)) -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Prelude hiding (map,head,mapM) -import Data.Bits.Extras -import Data.Bits - -import Data.PrimitiveArray hiding (map) -import Data.Bits.Ordered - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Indices.Classes - - - --- * Bitsets without any boundaries --- --- TODO outside and complement code - -instance - ( 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@ - -- for the index from the previous symbol. Then we calculate the - -- @mask@, the bits we can still set. This is @i@ minus the @l@ - -- bits. Then we calculate the population count. For this we ask - -- for the @popCount mask@ and lower it by the constraint @rb@ - -- (why?). Finally, we set exactly popCount bits in @k@. These - -- @k@ bits are *not* the bits from the @mask@ but rather the - -- lowest bits. - -- @rb@ should be set by more-right symbols in case they need to - -- reserve some bits but otherwise are static. - where mk svS - | cm < csize = return $ Nothing - | otherwise = return $ Just (svS :. mask :. k) - where k = (BitSet $ 2^cm-1) - cm = popCount mask - rb - mask = i `xor` l - 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 - -- @pk@. This will terminate once the popcount is higher than the - -- index @i@ minus the reserved count @rb@. - -- In case we don't terminate, we calculate the actual index @kk@ - -- by shifting the key @k@ around with our @mask@. The local - -- index is given by @kk@, while the set of all active bits is - -- @kk .|. aa@. - -- - -- TODO is the stopping criterion actually right? Should'nd we - -- look at all set bits? Also consider the comment above on @rb@. - step (Just (svS@(SvS s t y') :. mask :. k)) - | pk > popCount i - rb = return $ Done - | otherwise = let kk = popShiftL mask k - 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 = minSize c -- minimal set size via constraints - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - addIndexDenseGo (cs:.c) (vs:.IVariable rb) (us:.u) (is:.i) - = flatten mk step . addIndexDenseGo cs vs us is - -- @mk@ builds up the initially set population. In case of - -- @EmptyOk@ no bits are set. Otherwise we check first if we have - -- bits left. If @cm==0@ then we immediately quit. If not, we - -- activate one bit. - where mk svS - | 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 - 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 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 (t:.kk) (y' :.: RiBsI (kk.|.l))) - ((svS :. mask :. cm :.) <$> setSucc 0 (2^cm -1) k) - where kk = popShiftL mask k - RiBsI l = getIndex (getIdx s) (Proxy :: PRI is (BitSet I)) - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline addIndexDenseGo #-} - --- | Outside / Outside synvar indices are either @OStatic@ or @ORightOf@. --- Of course, the single outside synvar is not to the right of itself, but --- it is the final @RightOf@ object before we have the @FirstLeft@ object. - -instance - ( 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 bso >= popCount u = return $ Nothing - | otherwise = return $ Just (svS :. mask :. k) - 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 - -- bits, while the inside index wont have those. The idea is that - -- @outside@ provides the mask we can now plug additional - -- @inside@ objects in -- but only in those plug-ports where @i@ - -- is zero. - step (Just (svS@(SvS s t y') :. mask :. k)) - -- drawing the next bitset ends up over the limit - | pk > rb = return $ Done - | otherwise = - let RiBsO bsi bso = getIndex (getIdx s) (Proxy :: PRI is (BitSet O)) - kk = popShiftL mask k - 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 = minSize c - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - addIndexDenseGo (cs:.c) (vs:.ORightOf rb) (us:.u) (is:.i) - = undefined - {-# Inline addIndexDenseGo #-} - --- | - -instance - ( AddIndexDense a us cs is - , GetIndex a (is:.BitSet O) - , GetIx a (is:.BitSet O) ~ (BitSet O) - ) => 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 #-} - diff --git a/ADP/Fusion/SynVar/Indices/Subword.hs b/ADP/Fusion/SynVar/Indices/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Indices/Subword.hs +++ /dev/null @@ -1,191 +0,0 @@ - --- | Instance code for @Inside@, @Outside@, and @Complement@ indices. --- --- TODO actual @Outside@ and @Complement@ code ... --- --- TODO we have quite a lot of @subword i j@ code where only the @type@ --- is different; check if @coerce@ yields improved performance or if the --- compiler optimizes this out! - -module ADP.Fusion.SynVar.Indices.Subword where - -import Data.Proxy -import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..),filter) -import Data.Vector.Fusion.Util (delay_inline) -import Prelude hiding (map,head,mapM,filter) -import Debug.Trace - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Indices.Classes - - - --- | --- @ --- Table: Inside --- Grammar: Inside --- --- The minSize condition for @IStatic@ is guaranteed via the use of --- @tableStreamIndex@ (not here, in individual synvars), where @j@ is set --- to @j-1@ for the next-left symbol! --- @ - -instance - ( 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)) - = 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)) - = seq csize . id -- staticCheck (j<=u) - . flatten mk step . addIndexDenseGo cs vs us is - 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 t y') :. zz) - | zz >= 0 = do let RiSwI k = getIndex (getIdx s) (Proxy :: PRI is (Subword I)) - l = j - zz ; kl = subword k l - return $ Yield (SvS s (t:.kl) (y' :.: RiSwI l)) (svS :. zz-1) - | otherwise = return $ Done - !csize = minSize c - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline addIndexDenseGo #-} - --- | --- @ --- Table: Outside --- Grammar: Outside --- @ --- --- TODO Take care of @c@ in all cases to correctly handle @NonEmpty@ tables --- and the like. - -instance - ( 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 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 t y') :. l) - | l <= h = let RiSwO k _ _ _ = getIndex (getIdx s) (Proxy :: PRI is (Subword O)) - kl = subword k l - 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 #-} - addIndexDenseGo _ (_:.OFirstLeft _) _ _ = error "SynVar.Indices.Subword : OFirstLeft" - addIndexDenseGo _ (_:.OLeftOf _) _ _ = error "SynVar.Indices.Subword : LeftOf" - {-# Inline addIndexDenseGo #-} - --- | --- @ --- Table: Inside --- Grammar: Outside --- @ --- --- TODO take care of @c@ - -instance - ( 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 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 RiSwO _ l _ _ = getIndex (getIdx $ sS svS) (Proxy :: PRI is (Subword O)) - in return (svS :. l :. l + csize) - 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 RiSwO _ _ oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O)) - klI = subword k l - 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 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 RiSwO _ l _ _ = getIndex (getIdx $ sS svS) (Proxy :: PRI is (Subword O)) - in return $ svS :. l - 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 - in return $ Yield (SvS s (t:.klI) (y' :.: RiSwO k l oi oj)) - (svS :. l+1) - | otherwise = return $ Done - csize = minSize c - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline addIndexDenseGo #-} - - - - --- TODO --- @ --- Table: Inside --- Grammar: Complement --- @ - -instance - ( 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 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 #-} - --- TODO --- @ --- Table: Outside --- Grammar: Complement --- @ - -instance - ( 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 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 #-} - --- | --- @ --- Table: Complement --- Grammar: Complement --- @ - -instance - ( 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 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 #-} - - diff --git a/ADP/Fusion/SynVar/Indices/Unit.hs b/ADP/Fusion/SynVar/Indices/Unit.hs --- a/ADP/Fusion/SynVar/Indices/Unit.hs +++ b/ADP/Fusion/SynVar/Indices/Unit.hs @@ -11,8 +11,8 @@ import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Indices.Classes +import ADP.Fusion.Core +import ADP.Fusion.Core.Unit diff --git a/ADP/Fusion/SynVar/Recursive.hs b/ADP/Fusion/SynVar/Recursive.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Recursive.hs +++ /dev/null @@ -1,74 +0,0 @@ - -module ADP.Fusion.SynVar.Recursive - ( module ADP.Fusion.SynVar.Recursive.Type - , module ADP.Fusion.SynVar.Recursive.Point - , module ADP.Fusion.SynVar.Recursive.Subword - ) where - -import ADP.Fusion.SynVar.Recursive.Point -import ADP.Fusion.SynVar.Recursive.Subword -import ADP.Fusion.SynVar.Recursive.Type - - -{- - - --- * Instances - -{- -instance ModifyConstraint (IRec m Subword x) where - toNonEmpty (IRec _ iF iT f) = IRec NonEmpty iF iT f - toEmpty (IRec _ iF iT f) = IRec EmptyOk iF iT f - {-# INLINE toNonEmpty #-} - {-# INLINE toEmpty #-} - -instance - ( Monad m - , Element ls Subword - , MkStream m ls Subword - ) => MkStream m (ls :!: IRec m Subword x) Subword where - mkStream (ls :!: IRec c _ _ f) Static lu (Subword (i:.j)) - = let ms = minSize c in ms `seq` - S.mapM (\s -> let Subword (_:.l) = getIdx s - in f lu (subword l j) >>= \z -> return $ ElmIRec z (subword l j) s) - $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms) - mkStream (ls :!: IRec c _ _ f) (Variable _ Nothing) lu (Subword (i:.j)) - = let ms = minSize c - mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms) - step (s:.z) - | z>=0 = do let (Subword (_:.k)) = getIdx s - y <- f lu (subword k (j-z)) - return $ S.Yield (ElmIRec y (subword k $ j-z) s) (s:.z-1) - | otherwise = return $ S.Done - {-# INLINE [1] mk #-} - {-# INLINE [1] step #-} - in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j) - {-# INLINE mkStream #-} - -instance - ( Monad mB - , Element ls Subword - , MkStream mB ls Subword - ) => MkStream mB (ls :!: BT (IRec mF Subword x) mF mB r) Subword where - mkStream (ls :!: BtIRec c _ _ f bt) Static lu (Subword (i:.j)) - = let ms = minSize c in ms `seq` - S.mapM (\s -> let (Subword (_:.l)) = getIdx s - ix = subword l j - in f lu ix >>= \fx -> return $ ElmBtIRec fx (bt lu ix) ix s) - $ mkStream ls (Variable Check Nothing) lu (subword i $ j-ms) - mkStream (ls :!: BtIRec c _ _ f bt) (Variable _ Nothing) lu (Subword (i:.j)) - = let ms = minSize c - mk s = let Subword (_:.l) = getIdx s in return (s:.j-l-ms) - step (s:.z) - | z>=0 = do let Subword (_:.k) = getIdx s - ix = subword k (j-z) - f lu ix >>= \fx -> return $ S.Yield (ElmBtIRec fx (bt lu ix) ix s) (s:.z-1) - | otherwise = return $ S.Done - {-# INLINE [1] mk #-} - {-# INLINE [1] step #-} - in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j) - {-# INLINE mkStream #-} --} - --} - diff --git a/ADP/Fusion/SynVar/Recursive/Subword.hs b/ADP/Fusion/SynVar/Recursive/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Recursive/Subword.hs +++ /dev/null @@ -1,12 +0,0 @@ - -module ADP.Fusion.SynVar.Recursive.Subword where - -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Prelude hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Recursive.Type -import ADP.Fusion.SynVar.Backtrack diff --git a/ADP/Fusion/SynVar/Recursive/Type.hs b/ADP/Fusion/SynVar/Recursive/Type.hs --- a/ADP/Fusion/SynVar/Recursive/Type.hs +++ b/ADP/Fusion/SynVar/Recursive/Type.hs @@ -1,6 +1,7 @@ module ADP.Fusion.SynVar.Recursive.Type where +import Control.Applicative (Applicative,(<$>),(<*>)) import Control.Monad.Morph import Data.Proxy import Data.Strict.Tuple @@ -9,10 +10,12 @@ import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Axiom import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Indices +import ADP.Fusion.SynVar.Indices.Classes +import ADP.Fusion.SynVar.TableWrap @@ -26,21 +29,26 @@ -- if there is only a (small) constant number of parses of an @IRec@ -- synvar. -data IRec m c i x where +data IRec c i x where IRec :: { iRecConstraint :: !c , iRecFrom :: !i , iRecTo :: !i - , iRecFun :: !(i -> i -> m x) - } -> IRec m c i x + } -> IRec c i x -instance Build (IRec m c i x) +type TwIRec m c i x = TW (IRec c i x) (i -> i -> m x) -type instance TermArg (IRec m c i x) = x +type TwIRecBt c i x mF mB r = TW (Backtrack (TwIRec mF c i x) mF mB) (i -> i -> mB [r]) -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 +instance Build (TwIRec m c i x) + +instance Build (TwIRecBt c i x mF mB r) + +type instance TermArg (TwIRec m c i x) = x + +instance GenBacktrackTable (TwIRec mF c i x) mF mB where + data Backtrack (TwIRec mF c i x) mF mB = BtIRec !c !i !i !(i -> i -> mB x) -- !(i -> i -> mB [r]) + type BacktrackIndex (TwIRec mF c i x) = i + toBacktrack (TW (IRec c iF iT) f) mrph = BtIRec c iF iT (\lu i -> mrph $ f lu i) {-# Inline toBacktrack #-} @@ -48,9 +56,9 @@ instance ( Monad m , IndexStream i - ) => Axiom (IRec m c i x) where - type AxiomStream (IRec m c i x) = m x - axiom (IRec _ l h fun) = do + ) => Axiom (TwIRec m c i x) where + type AxiomStream (TwIRec m c i x) = m x + axiom (TW (IRec _ l h) fun) = do k <- head $ streamDown l h fun h k {-# Inline axiom #-} @@ -58,52 +66,56 @@ instance ( Monad mB , IndexStream i - ) => 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 + , i ~ j + , m ~ mB + ) => Axiom (TW (Backtrack (TwIRec mF c i x) mF mB) (j -> j -> m [r])) where + type AxiomStream (TW (Backtrack (TwIRec mF c i x) mF mB) (j -> j -> m [r])) = mB [r] + axiom (TW (BtIRec c l h fun) btfun) = do k <- head $ streamDown l h btfun h k {-# Inline axiom #-} -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 +instance Element ls i => Element (ls :!: TwIRec m c u x) i where + data Elm (ls :!: TwIRec m c u x) i = ElmIRec !x !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: TwIRec m c u x) = Arg ls :. x getArg (ElmIRec x _ ls) = getArg ls :. x getIdx (ElmIRec _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-} -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]) +instance Element ls i => Element (ls :!: TwIRecBt c u x mF mB r) i where + data Elm (ls :!: (TwIRecBt c u x mF mB r)) i = ElmBtIRec !x [r] !(RunningIndex i) !(Elm ls i) + type Arg (ls :!: (TwIRecBt 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 #-} instance - ( Monad m + ( Functor m + , 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 + ) => MkStream m (ls :!: TwIRec m (cs:.c) (us:.u) x) (is:.i) where + mkStream (ls :!: TW (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 #-} instance - ( Monad mB + ( Applicative mB + , 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 + ) => MkStream mB (ls :!: TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) where + mkStream (ls :!: TW (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) diff --git a/ADP/Fusion/SynVar/Split.hs b/ADP/Fusion/SynVar/Split.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Split.hs +++ /dev/null @@ -1,11 +0,0 @@ - --- | Split syntactic variables for multi-cfg dynamic programs. - -module ADP.Fusion.SynVar.Split - ( module ADP.Fusion.SynVar.Split.Type - , module ADP.Fusion.SynVar.Split.Subword - ) where - -import ADP.Fusion.SynVar.Split.Subword -import ADP.Fusion.SynVar.Split.Type - diff --git a/ADP/Fusion/SynVar/Split/Subword.hs b/ADP/Fusion/SynVar/Split/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/SynVar/Split/Subword.hs +++ /dev/null @@ -1,133 +0,0 @@ - --- | --- --- TODO Rewrite to use the new index-generating system. --- --- TODO Take care of minsize constraints! These are somewhat tricky. We --- have one constraint for dimension in the table. - -module ADP.Fusion.SynVar.Split.Subword where - -import Data.Strict.Tuple -import Data.Proxy -import Data.Vector.Fusion.Stream.Monadic hiding (flatten) -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import GHC.TypeLits -import Prelude hiding (map,mapM) -import Data.Type.Equality - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.SynVar.Array.Type -import ADP.Fusion.SynVar.Backtrack -import ADP.Fusion.SynVar.Split.Type - - - --- * 'Fragment' and 'Final' instances for 'Split' / 'ITbl'. - -instance - ( Monad m - , Element ls (Subword I) - , MkStream m ls (Subword I) - ) => 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 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 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 #-} - {-# Inline mkStream #-} - -instance - ( Monad m - , Element ls (Subword I) - , MkStream m ls (Subword I) - , SplitIxCol uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) - , (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) ~ mix - , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) x) - , 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 RiSwI l = getIdx s - fmbkm :: mix = collectIx (Proxy :: Proxy uId) s :. subword l j - 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 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 #-} - {-# Inline mkStream #-} - - - --- * 'Fragment' and 'Final' instances for 'Split' / @Backtrack@ 'ITbl'. - -instance - ( Monad mB - , Element ls (Subword I) - , MkStream mB ls (Subword I) - ) => 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 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 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 #-} - {-# Inline mkStream #-} - -instance - ( Monad mB - , Element ls (Subword I) - , MkStream mB ls (Subword I) - , SplitIxCol uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) - , (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) ~ mix - , (PrimArrayOps arr (SplitIxTy uId (SameSid uId (Elm ls (Subword I))) (Elm ls (Subword I)) :. Subword I) x) - , 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 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 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 #-} - {-# Inline mkStream #-} - diff --git a/ADP/Fusion/SynVar/Split/Type.hs b/ADP/Fusion/SynVar/Split/Type.hs --- a/ADP/Fusion/SynVar/Split/Type.hs +++ b/ADP/Fusion/SynVar/Split/Type.hs @@ -19,9 +19,11 @@ import Data.PrimitiveArray hiding (map) -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi import ADP.Fusion.SynVar.Array.Type import ADP.Fusion.SynVar.Backtrack +import ADP.Fusion.SynVar.TableWrap @@ -68,26 +70,28 @@ instance ( Element ls i - ) => 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 + ) => Element (ls :!: Split uId splitType (TwITbl m arr c j x)) i where + -- | @ElmSplitITbl@ carry one additional element of type @i@. We need + -- those to be able to extract the full index via @collectIx@. + data Elm (ls :!: Split uId splitType (TwITbl m arr c j x)) i = ElmSplitITbl !(Proxy uId) !(CalcSplitType splitType x) !(RunningIndex i) !(Elm ls i) !i + type Arg (ls :!: Split uId splitType (TwITbl m arr c j x)) = Arg ls :. (CalcSplitType splitType x) + type RecElm (ls :!: Split uId splitType (TwITbl 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 getElm #-} instance ( Element ls i - ) => 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 + ) => Element (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) i where + data Elm (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) i = ElmSplitBtITbl !(Proxy uId) !(CalcSplitType splitType (x, [r])) !(RunningIndex i) !(Elm ls i) !i + type Arg (ls :!: Split uId splitType (TwITblBt arr c j x mF mB r)) = Arg ls :. (CalcSplitType splitType (x,[r])) + type RecElm (ls :!: Split uId splitType (TwITblBt 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 getElm #-} @@ -174,16 +178,16 @@ instance ( SplitIxCol uId (SameSid uId (Elm ls i)) (Elm ls 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 + ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (TwITbl m arr c j x)) i) where + type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITbl m arr c j x)) i) = SplitIxTy uId (SameSid uId (Elm ls i)) (Elm ls i) :. i + splitIxCol p b (ElmSplitITbl _ _ i e ix) = collectIx p e :. ix {-# 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 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 + ) => SplitIxCol uId True (Elm (ls :!: Split sId splitType (TwITblBt arr c j x mF mB r)) i) where + type SplitIxTy uId True (Elm (ls :!: Split sId splitType (TwITblBt 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 ix) = collectIx p e :. ix {-# Inline splitIxCol #-} instance @@ -191,6 +195,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` ((error "ElmTS / splitIxCol") {- p t -} :: SplitIxTy uId (SameSid uId (TermSymbol a b)) (TermSymbol a b)) {-# Inline splitIxCol #-} diff --git a/ADP/Fusion/SynVar/TableWrap.hs b/ADP/Fusion/SynVar/TableWrap.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/SynVar/TableWrap.hs @@ -0,0 +1,11 @@ + +-- | Wrap the underlying table and the rules. Isomorphic to @(,)@. + +module ADP.Fusion.SynVar.TableWrap where + + + +-- | Wrap tables of type @t@. The tables are strict, the functions @f@ can +-- not be strict, because we need to build grammars recursively. + +data TW t f = TW !t f diff --git a/ADP/Fusion/TH.hs b/ADP/Fusion/TH.hs deleted file mode 100644 --- a/ADP/Fusion/TH.hs +++ /dev/null @@ -1,77 +0,0 @@ - --- | The functions in here auto-create suitable algebra product functions from --- a signature. Currently, functions @<**@ are supported which have scalar --- results in the first variable. --- --- TODO If we want to support classified DP, we shall also need @**<@ --- generating vector-results given a vector result, followed by a scalar --- result. --- --- TODO Then we also need @***@ handling the case of vector-to-vector results. --- --- TODO note the comments in @buildBacktrackingChoice@ - -module ADP.Fusion.TH - ( makeAlgebraProduct - , (<||) - , (***) - ) where - -import Data.List -import Data.Tuple.Select -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import qualified Data.Vector.Fusion.Stream.Monadic as SM - -import ADP.Fusion.TH.Backtrack -- (makeBacktrackingProductInstance,(<||)) -import ADP.Fusion.TH.Common (getRuleResultType) - - - -makeAlgebraProduct = makeProductInstances - -{- --- | Create the algebra product function from a signature type constructor. --- --- TODO make the resulting function INLINE --- --- TODO compare @synTypes@ with the stream argument types of all @hs@ (via their --- @hns@ names). If there is a mismatch, then either not all non-terminal types --- have a corresponding choice function or vice versa. - -makeAlgebraProductH :: [Name] -> Name -> Q [Dec] -makeAlgebraProductH hns nm = do - rnm <- reify nm - case rnm of - TyConI (DataD ctx tyConName args cs d) -> case cs of - -- we analyze the accessor functions and look for the objective function - -- accessor. It's stream parameter is the type of the non-terminal. - -- Everything else in accessors are terminal parameters. - [RecC dataConName fs'] -> do - -- split @fs@ into functions applied to rule RHSs and choice functions (@hs@) - let (fs,hs) = partition ((`notElem` hns) . sel1) fs' - -- the result types of the @fs@ are the types of the non-terminal symbols - let synTypes = nub . map getRuleResultType $ fs --- funStream <- funD (mkName "<**") [genClauseStream dataConName fs' fs hs] - funList <- funD (mkName "<||") [genClauseBacktrack dataConName fs' fs hs] - return --- [ funStream - [ funList - , PragmaD $ InlineP (mkName "<||") Inline FunLike AllPhases - ] - _ -> fail "more than one data ctor" - _ -> fail "unsupported data type" - --- | Creates a class for each type of product and instances for each --- signature. - -makeClassyProducts :: Name -> Q [Dec] -makeClassyProducts conName = do - c <- lookupValueName "BacktrackingProduct" - case c of - Nothing -> error "need to create class now and add instance" - Just cl -> error "add instance" - return [] --} - - diff --git a/ADP/Fusion/TH/Backtrack.hs b/ADP/Fusion/TH/Backtrack.hs deleted file mode 100644 --- a/ADP/Fusion/TH/Backtrack.hs +++ /dev/null @@ -1,524 +0,0 @@ - --- | Backtracking which uses lists internally. The basic idea is to convert --- each @Stream@ into a list. The consumer consumes the stream lazily, but --- allows for fusion to happen. The hope is that this improves total --- performance in those cases, where backtracking has significant costs. - -module ADP.Fusion.TH.Backtrack where - -import Control.Applicative ( (<$>) ) -import Control.Monad -import Control.Monad.Primitive (PrimState, PrimMonad) -import Data.List -import Data.Tuple.Select -import Data.Vector.Fusion.Stream.Monadic (Stream(..)) -import Debug.Trace -import Language.Haskell.TH -import Language.Haskell.TH.Instances -import Language.Haskell.TH.Syntax -import qualified Data.Map.Strict as M -import qualified Data.Vector as V -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM -import qualified Data.Vector.Mutable as VM - -import Data.PrimitiveArray ( (:.)(..) , Z(..) ) - -import ADP.Fusion.TH.Common - - - --- | @Backtracking@ products of @f@ and @b@. Choice in @f@ needs to be --- reduced to a scalar value. It is then compared to the @fst@ values --- in @b@. From those, @choice b@ selects. - -class ProductBacktracking sigF sigB where - type SigBacktracking sigF sigB :: * - (<||) :: sigF -> sigB -> SigBacktracking sigF sigB - --- | The ADP-established product operation. Returns a vector of results, --- along the lines of what the ADP @f *** b@ provides. - -class ProductCombining sigF sigB where - type SigCombining sigF sigB :: * - (***) :: sigF -> sigB -> SigCombining sigF sigB - --- | Creates instances for all products given a signature data type. - -makeProductInstances :: Name -> Q [Dec] -makeProductInstances tyconName = do - t <- reify tyconName - case t of - TyConI (DataD ctx tyConName args cs d) -> do - let m = getMonadName args - case cs of - [RecC dataconName funs] -> do - let Just (h,m',x,r) = getObjectiveNames funs - mL <- newName "mL" - xL <- newName "xL" - rL <- newName "rL" - mR <- newName "mR" - xR <- newName "xR" - rR <- newName "rR" --- let lType = buildLeftType tyconName (m', x, r) (mL, xL) args - let lType = buildRightType tyconName (m', x, r) (mL, xL, rL) args - let rType = buildRightType tyconName (m', x, r) (mR, xR, rR) args - let (fs,hs) = partition ((`notElem` [h]) . sel1) funs - let sigBType = buildSigBacktrackingType tyconName (m', x, r) xL (mR, xR, rR) args - Clause psB (NormalB bB) dsB <- genAlgProdFunctions buildBacktrackingChoice dataconName funs fs hs - iB <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR), $(varT xL) ~ $(varT rL)) - => ProductBacktracking $(return lType) $(return rType) where - type SigBacktracking $(return lType) $(return rType) = $(return sigBType) - (<||) = $(return $ LamE psB $ LetE dsB bB) - {-# Inline (<||) #-} - |] - -- TODO might well be that this doesn't work because we re-use - -- type names ... - vG <- newName "vG" - sigPType <- buildSigCombiningType tyconName vG (m', x, r) (mL, xL, rL) (mR, xR, rR) args - Clause psC (NormalB bC) dsC <- genAlgProdFunctions buildCombiningChoice dataconName funs fs hs - iC <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR) {- , VG.Vector $(varT vG) ($(varT rL),$(varT rR)) -} ) - => ProductCombining $(return lType) $(return rType) where - type SigCombining $(return lType) $(return rType) = $(return sigPType) - (***) = undefined - {- - - (***) = $(return $ LamE psC $ LetE dsC bC) - - -} - {-# Inline (***) #-} - |] - return $ iB -- ++ iC - --- | Returns the 'Name' of the monad variable. - -getMonadName :: [TyVarBndr] -> Maybe Name -getMonadName = go - where go [] = Nothing - go (KindedTV m (AppT (AppT ArrowT StarT) StarT) : _) = Just m - go (_ : xs) = go xs - --- | Returns the 'Name's of the objective function variables, as well as --- the name of the objective function itself. - -getObjectiveNames :: [VarStrictType] -> Maybe (Name,Name,Name,Name) -getObjectiveNames = go - where go [] = Nothing - go ( (hName , _ , (AppT (AppT ArrowT (AppT (AppT (ConT streamName) (VarT mS)) (VarT x))) (AppT (VarT mR) (VarT r)))) : xs) - | streamName == ''Stream && mS == mR = Just (hName,mS,x,r) - | otherwise = go xs - go ( _ : xs) = go xs - - - --- * Constructions for the different algebra types. - --- | The left algebra type. Assumes that in @choice :: Stream m x -> m r@ --- we have that @x ~ r@. - -buildLeftType :: Name -> (Name, Name, Name) -> (Name, Name) -> [TyVarBndr] -> Type -buildLeftType tycon (m, x, r) (mL, xL) = foldl AppT (ConT tycon) . map (VarT . go) - where go (PlainTV z) - | z == m = mL -- correct monad name - | z == x = xL -- point to new x type - | z == r = xL -- stream and return type are the same - | otherwise = z -- everything else can stay as is - go (KindedTV z _) = go (PlainTV z) - --- | Here, we do not set any restrictions on the types @m@ and @r@. - -buildRightType :: Name -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type -buildRightType tycon (m, x, r) (mR, xR, rR) = foldl AppT (ConT tycon) . map (VarT . go) - where go (PlainTV z) - | z == m = mR -- have discovered a monadic type - | z == x = xR -- have discovered a type that is equal to the stream type (and hence we have a synvar type) - | z == r = rR -- have discovered a type that is equal to the result type (for @<||@) equal to the stream type, hence synvar - | otherwise = z -- this is a terminal or a terminal stack (we don't care) - go (KindedTV z _) = go (PlainTV z) - --- | Build up the type for backtracking. We want laziness in the right --- return type. Hence, we have @AppT ListT (VarT xR)@ ; i.e. we want to --- return results in a list. - -buildSigBacktrackingType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type -buildSigBacktrackingType tycon (m, x, r) (xL) (mR, xR, rR) = foldl AppT (ConT tycon) . map go - where go (PlainTV z) - | z == m = VarT mR - | z == x = (AppT (AppT (TupleT 2) (VarT xL)) (AppT ListT (VarT xR))) - | z == r = VarT rR - | otherwise = VarT z - go (KindedTV z _) = go (PlainTV z) - --- | Build up the type for backtracking. We want laziness in the right --- return type. Hence, we have @AppT ListT (VarT xR)@. - -buildSigCombiningType :: Name -> Name -> (Name, Name, Name) -> (Name, Name, Name) -> (Name, Name, Name) -> [TyVarBndr] -> TypeQ -buildSigCombiningType tycon vG (m, x, r) (mL, xL, rL) (mR, xR, rR) = foldl appT (conT tycon) . map go - where go (PlainTV z) - | z == m = varT mR - | z == x = [t| ($(varT xL) , $(varT xR)) |] - | z == r = [t| V.Vector ($(varT rL) , $(varT rR)) |] - | otherwise = varT z - go (KindedTV z _) = go (PlainTV z) - - - --- * - --- | Build up attribute and choice function. Here, we actually bind the --- left and right algebra to @l@ and @r@. - -genAlgProdFunctions - :: Choice - -> Name - -> [VarStrictType] - -> [VarStrictType] - -> [VarStrictType] - -> Q Clause -genAlgProdFunctions choice conName allFunNames evalFunNames choiceFunNames = do - let nonTermNames = nub . map getRuleResultType $ evalFunNames - -- bind the l'eft and r'ight variable of the two algebras we want to join, - -- also create unique names for the function names we shall bind later. - nameL <- newName "l" - varL <- varP nameL - fnmsL <- sequence $ replicate (length allFunNames) (newName "fnamL") - nameR <- newName "r" - varR <- varP nameR - fnmsR <- sequence $ replicate (length allFunNames) (newName "fnamR") - -- bind the individual variables in the where part - whereL <- valD (conP conName (map varP fnmsL)) (normalB $ varE nameL) [] - whereR <- valD (conP conName (map varP fnmsR)) (normalB $ varE nameR) [] - rce <- recConE conName - $ zipWith3 (genChoiceFunction choice) (drop (length evalFunNames) fnmsL) (drop (length evalFunNames) fnmsR) choiceFunNames - ++ zipWith3 (genAttributeFunction nonTermNames) fnmsL fnmsR evalFunNames - -- build the function pairs - -- to keep our sanity, lets print this stuff - let cls = Clause [varL, varR] (NormalB rce) [whereL,whereR] - return cls - --- | Simple wrapper for creating the choice fun expression. - -genChoiceFunction - :: Choice - -> Name - -> Name - -> VarStrictType - -> Q (Name,Exp) -genChoiceFunction choice hL hR (name,_,t) = do - exp <- choice hL hR - return (name,exp) - - --- | We take the left and right function name for one attribute and build --- up the combined attribute function. Mostly a wrapper around --- 'recBuildLampat' which does the main work. --- --- TODO need fun names from @l@ and @r@ - -genAttributeFunction - :: [Name] - -> Name - -> Name - -> VarStrictType - -> Q (Name,Exp) -genAttributeFunction nts fL fR (name,_,t) = do - (lamPat,funL,funR) <-recBuildLamPat nts fL fR (init $ getRuleSynVarNames nts t) -- @init@ since we don't want the result as a parameter - let exp = LamE lamPat $ TupE [funL,funR] - return (name,exp) - --- | Now things become trickly. We are given all non-terminal names (to --- differentiate between a terminal (stack) and a syntactic variable; the --- left and right function; and the arguments to this attribute function --- (except the result parameter). We are given the latter as a result to an --- earlier call to 'getRuleSynVarNames'. --- --- We now look at each argument and determine wether it is a syntactic --- variable. If so, then we actually have a tuple arguments @(x,ys)@ where --- @x@ has to optimized value and @ys@ the backtracking list. The left --- function receives just @x@ in this case. For the right function, things --- are more complicated, since we have to flatten lists. See 'buildRns'. --- --- Terminals are always given "as is" since we do not have a need for --- tupled-up information as we have for syntactic variables. - -recBuildLamPat - :: [Name] -- ^ all non-terminal names - -> Name -- ^ left attribute function - -> Name -- ^ right attribute function - -> [ArgTy Name] -- ^ all arguments to the attribute function - -> Q ([Pat], Exp, Exp) -recBuildLamPat nts fL' fR' ts = do - -- here we just run through all arguments, either creating an @x@ and - -- a @ys@ for a non-term or a @t@ for a term. - -- ps <- sequence [ if t `elem` nts then tupP [newName "x" >>= varP, newName "ys" >>= varP] else (newName "t" >>= varP) | t<-ts] - ps <- mapM argTyArgs ts - {- - let buildLfun f (SynVar (TupP [VarP v,_])) = appE f (varE v) - buildLfun f (Term (VarP v )) = appE f (varE v) - buildLfun f (StackedVars vs) = - let - in error "buildLfun: WRITE ME" -- appE f (varE $ mkName "foo") - -} - lamPat <- buildLamPat ps - lfun <- buildLns (VarE fL') ps -- foldl buildLfun (varE fL') ps - rfun <- buildRns (VarE fR') ps - return (lamPat, lfun, rfun) - -buildLamPat :: [ArgTy Pat] -> Q [Pat] -buildLamPat = mapM go where - go (SynVar p ) = return p - go (Term p ) = return p - go (StackedVars ps) = build ps - build :: [ArgTy Pat] -> Q Pat - build = foldl (\s v -> [p| $(s) :. $(return v) |]) [p|Z|] . map get - get :: ArgTy Pat -> Pat - get (SynVar p) = p - get (Term p) = p - --- | Look at the argument type and build the capturing variables. In --- particular captures synvar arguments with a 2-tuple @(x,ys)@. - -argTyArgs :: ArgTy Name -> Q (ArgTy Pat) -argTyArgs (SynVar n) = SynVar <$> tupP [newName "x" >>= varP , newName "ys" >>= varP] -argTyArgs (Term n) = Term <$> (newName "t" >>= varP) -argTyArgs (StackedTerms _) = Term <$> (newName "t" >>= varP) -- !!! -argTyArgs (StackedVars vs) = StackedVars <$> mapM argTyArgs vs -argTyArgs NilVar = Term <$> (newName "t" >>= varP) -argTyArgs (Result _) = error "argTyArgs: should not receive @Result@" - -buildLns - :: Exp - -> [ArgTy Pat] - -> ExpQ -buildLns f' ps = foldl go (return f') ps - where go :: ExpQ -> ArgTy Pat -> ExpQ - go f (SynVar (TupP [VarP v,_])) = appE f (varE v) - go f (Term (VarP v )) = appE f (varE v) - go f (StackedVars vs ) = appE f (build vs) - build :: [ArgTy Pat] -> ExpQ - build = foldl (\s v -> [| $(s) :. $(varE v) |]) [|Z|] . map get - get (SynVar (TupP [VarP v,_])) = v - get (Term (VarP t) ) = t - --- | --- --- NOTE --- --- @ --- [ f x | x <- xs ] --- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))] --- @ - -buildRns - :: Exp --- -> [Name] - -> [ArgTy Pat] - -> ExpQ -buildRns f' ps = do - -- get all synvars, shallow or deep and create a new name to bind - -- individual parts to. - sy :: M.Map Pat Name <- M.fromList <$> (mapM (\s -> newName "y" >>= \y -> return (s,y)) $ concatMap flattenSynVars ps) - -- bind them for the right part of the list expression (even though they - -- are left in @CompE@. We don't use @sy@ directly to keep the order in - -- which the comprehensions run. - let rs = map (\k@(TupP [_,VarP v]) -> BindS (VarP $ sy M.! k) (VarE v)) $ concatMap flattenSynVars ps - let go :: ExpQ -> ArgTy Pat -> ExpQ - go f (SynVar k ) = appE f (varE $ sy M.! k) -- needed like this, because we need the @y@ in @y <- ys@ - go f (Term (VarP v)) = appE f (varE v) - go f (StackedVars vs ) = appE f (foldl build [|Z|] vs) - build :: ExpQ -> ArgTy Pat -> ExpQ - build s (SynVar k ) = [| $(s) :. $(varE $ sy M.! k) |] - build s (Term (VarP v)) = [| $(s) :. $(varE v) |] - funApp <- foldl go (return f') ps - return . CompE $ rs ++ [NoBindS funApp] - -{- - -- helper function for the argument build-up - let go :: [ArgTy Pat] -> [Name] - go [] = [] - go ((SynVar k ):ks) = sy M.! k : go ks - go ((Term (VarP v)):ks) = v : go ks -- should also cover StackedTerms, NilVar ! (because we build this earlier in @argTypArgs@) - go ((StackedVars ls ):ks) = (error "here") : go ks -- need to work more - -- more verbose build-up of the arguments for @funApp@. - let xs = go ps - -- function application - funApp <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs - return . CompE $ rs ++ [funApp] --} -{- -buildRns f ps = do - ys <- sequence [ newName "y" | TupP [_,VarP v] <- ps ] - let vs = zipWith (\y v -> (BindS (VarP y) (VarE v))) ys [ v | TupP [_,VarP v] <- ps ] - let xs = go ps ys - ff <- noBindS $ foldl (\g z -> appE g (varE z)) (return f) xs - return $ CompE $ vs ++ [ff] - where go [] [] = [] - go (VarP v : gs) ys = v : go gs ys -- keep terminal binders - go (TupP _ : gs) (v:ys) = v : go gs ys -- insert new binders - go as bs = error $ show ("not done?", as, bs) --} - --- | Type for backtracking functions. --- --- Not too interesting, mostly to keep track of @choice@. - -type Choice = Name -> Name -> Q Exp - --- | Build up the backtracking choice function. This choice function will --- backtrack based on the first result, then return only the second. --- --- TODO it should be (only?) this function we will need to modify to build --- all algebra products. --- --- @ysM@ can't be unboxed, as @snd@ of each element is a list, lazily --- consumed. We build up @ysM@ as this makes fusion happen. Of course, this --- is a boxed vector and not as efficient, but we gain the ability to have --- lazily created backtracking from this! --- --- This means strict optimization AND lazy backtracking - -buildBacktrackingChoice :: Choice -buildBacktrackingChoice hL' hR' = - [| \xs -> do -- first, create a boxed, mutable vector from the results - ysM <- streamToVector xs -- VGM.unstream xs :: m (VM.MVector s (t1,[t2])) - -- apply first choice - hFres <- $(varE hL') $ SM.map fst $ vectorToStream ysM - -- second choice on snd elements, then concat'ed up - -- TODO good candidate for rewriting into flatten - -- operation! - {- - - $(varE hR') $ SM.concatMap (SM.fromList . snd) $ SM.filter ((hFres==) . fst) $ vectorToStream ysM - -} - $(varE hR') $ SM.fromList $ concatMap snd $ filter ((hFres==) . fst) $ V.toList ysM - |] - -buildCombiningChoice :: Choice -buildCombiningChoice hL' hR' = - [| \xs -> do -- first, create a boxed, mutable vector from the results - --ys <- streamToVector xs - -- -- apply first choice - --fs <- $(varE hL') $ SM.map fst $ vectorToStream ys - -- -- generate a vector of vectors, one for each - -- -- surviving @f@ - --vs <- V.forM fs $ \f -> do - -- -- keep only those @ys@ that have @f@ - -- let as = V.filter ((f==) . fst) ys - -- -- apply @hR'@ to those, but only to the @snd@ - -- -- elements - -- bs <- streamToVector =<< $(varE hR') $ SM.map snd $ vectorToStream $ as - -- -- return the combined result, with @f@ attached. - -- return $ V.map (\z -> (f,z)) bs - undefined - {- - - $ V.concat $ V.toList vs - -} - -- TODO we should return a @newtype Many x = forall (G.Vector v x) => Many { v x } - -- Together with a closed type family, this gives us a good - -- way to encode that we have classified DP - |] - --- | Transform a monadic stream monadically into a vector. --- --- TODO Improve code! - -streamToVector :: (Monad m) => SM.Stream m x -> m (V.Vector x) -streamToVector xs = do - l <- SM.toList xs - let v = V.fromList l - return v -{-# Inline streamToVector #-} - --- | Transform a vector into a monadic stream. --- --- TODO improve code! - -vectorToStream :: (Monad m) => V.Vector x -> SM.Stream m x -vectorToStream = SM.fromList . V.toList -{-# Inline vectorToStream #-} - --- | Gets the names used in the evaluation function. This returns one --- 'Name' for each variable. --- --- In case of @TupleT 0@ the type is @()@ and there isn't a name to go with --- it. We just @mkName "()"@ a name, but this might be slightly dangerous? --- (Not really sure if it indeed is) --- --- With @AppT _ _@ we have a multidim terminal and produce another hackish --- name to be consumed above. --- --- @ --- AppT (AppT ArrowT (AppT (AppT (ConT Data.Array.Repa.Index.:.) (AppT (AppT (ConT Data.Array.Repa.Index.:.) (ConT Data.Array.Repa.Index.Z)) (VarT c_1627675270))) (VarT c_1627675270))) (VarT x_1627675265) --- @ - -getRuleSynVarNames :: [Name]-> Type -> [ArgTy Name] -- [Name] -getRuleSynVarNames nts t' = go t' where - go t - | VarT x <- t = [Result x] - | AppT (AppT ArrowT (VarT x) ) y <- t = (if x `elem` nts then SynVar x else Term x) : go y - | AppT (AppT ArrowT (TupleT 0)) y <- t = NilVar : go y - | AppT (AppT ArrowT s ) y <- t = stacked s : go y - | otherwise = error $ "getRuleSynVarNames error: " ++ show t ++ " in: " ++ show t' - stacked s = if null [ () | SynVar _ <- xs ] then StackedTerms xs else StackedVars xs - where xs = reverse $ stckd s - stckd (ConT z) | z == ''Z = [] - stckd (AppT a (TupleT 0)) = NilVar : stckd a - stckd (AppT a (VarT x) ) = (if x `elem` nts then SynVar x else Term x) : stckd a - stckd (AppT (ConT c) a ) | c == ''(:.) = stckd a - stckd err = error $ "stckd" ++ show err - -{- -(AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.) - (AppT (AppT (ConT Data.PrimitiveArray.Index.Class.:.) - (ConT Data.PrimitiveArray.Index.Class.Z) - ) - (VarT x_1627774371) - ) - ) - (TupleT 0) -) --} - -{- -getRuleSynVarNames nts t' = undefined where -- go t' where - go t - | VarT x <- t = [x] - | AppT (AppT ArrowT (VarT x )) y <- t = x : go y -- this is a single-dim variable, return the name that the incoming data is bound to (not necessarily syntactic) - | AppT (AppT ArrowT (AppT _ _)) y <- t = mkName "[]" : go y -- this captures that we have a multi-dim terminal. - | AppT (AppT ArrowT (TupleT 0)) y <- t = mkName "()" : go y -- this case captures things like @nil :: () -> x@ for rules like @nil <<< Epsilon@. - | otherwise = error $ "getRuleSynVarNames error: " ++ show t ++ " in: " ++ show t' --} - -data ArgTy x - -- | This @SynVar@ spans the full column of tapes; i.e. it is a normal - -- syntactic variable. - = SynVar { synVarName :: x } - -- | We have just a single-tape grammar and as such just - -- a single-dimensional terminal. We call this term, because - -- @StackedTerms@ will be rewritten to just @Term@! - | Term { termName :: x } - -- | We have a multi-tape grammar with a stack of just terminals. We - -- normally can ignore the contents in the functions above, but keep them - -- anyway. - | StackedTerms { stackedTerms :: [ArgTy x] } - -- | We have a multi-tape grammar, but the stack contains a mixture of - -- @ArgTy@s. - | StackedVars { stackedVars :: [ArgTy x] } - -- | A single-dim @()@ case - | NilVar - -- | The result type name - | Result { result :: x } - deriving (Show,Eq) - -unpackArgTy :: Show x => ArgTy x -> x -unpackArgTy = go - where go (SynVar x) = x - go (Term x) = x - go (Result x) = x - go err = error $ "unpackArgTy " ++ show err - --- | Get all synvars, even if deep in a stack - -flattenSynVars :: ArgTy x -> [x] -flattenSynVars (SynVar x) = [x] -flattenSynVars (StackedVars xs) = concatMap flattenSynVars xs -flattenSynVars _ = [] - diff --git a/ADP/Fusion/TH/Common.hs b/ADP/Fusion/TH/Common.hs deleted file mode 100644 --- a/ADP/Fusion/TH/Common.hs +++ /dev/null @@ -1,19 +0,0 @@ - -module ADP.Fusion.TH.Common where - -import Data.Tuple.Select -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - - - --- | The last @Name@ of a rule is the name of the syntactic type of the --- result. - -getRuleResultType :: VarStrictType -> Name -getRuleResultType vst = go $ sel3 vst where - go t - | AppT _ (VarT x) <- t = x - | AppT _ x <- t = go x - | otherwise = error $ "undetermined error:" ++ show vst - diff --git a/ADP/Fusion/Term.hs b/ADP/Fusion/Term.hs deleted file mode 100644 --- a/ADP/Fusion/Term.hs +++ /dev/null @@ -1,17 +0,0 @@ - -module ADP.Fusion.Term - ( module ADP.Fusion.Term.Chr - , module ADP.Fusion.Term.Deletion - , module ADP.Fusion.Term.Edge - , module ADP.Fusion.Term.Epsilon - , module ADP.Fusion.Term.PeekIndex - , module ADP.Fusion.Term.Strng - ) where - -import ADP.Fusion.Term.Chr -import ADP.Fusion.Term.Deletion -import ADP.Fusion.Term.Edge -import ADP.Fusion.Term.Epsilon -import ADP.Fusion.Term.PeekIndex -import ADP.Fusion.Term.Strng - diff --git a/ADP/Fusion/Term/Chr.hs b/ADP/Fusion/Term/Chr.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Chr.hs +++ /dev/null @@ -1,199 +0,0 @@ - -module ADP.Fusion.Term.Chr - ( module ADP.Fusion.Term.Chr.Type - , module ADP.Fusion.Term.Chr.Point - , module ADP.Fusion.Term.Chr.Set0 - , module ADP.Fusion.Term.Chr.Subword - ) where - -import ADP.Fusion.Term.Chr.Point -import ADP.Fusion.Term.Chr.Set0 -import ADP.Fusion.Term.Chr.Subword -import ADP.Fusion.Term.Chr.Type - - - - - - - -{- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- --- TODO PointL , PointR need sanity checks for boundaries - -module ADP.Fusion.Term.Chr where - -import Control.Exception(assert) -import qualified Data.Vector.Fusion.Stream.Monadic as S -import qualified Data.Vector.Unboxed as VU - -import Data.PrimitiveArray -- ((:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..)) - - -import Debug.Trace - - - - - --- ** @PointL@ single-dim instances - -{- -instance - ( Monad m - , Element ls PointL - , MkStream m ls PointL - ) => MkStream m (ls :!: Chr r x) PointL where - mkStream (ls :!: Chr f xs) Static lu@(PointL (l:.u)) (PointL (i:.j)) - = staticCheck (j>l && j>0 && j<=u && j<= VG.length xs) $ - let !z = () -- f xs (j-1) -- let-floating leads to too early evaluation - in S.map (ElmChr (f xs $ j-1) (pointL (j-1) j)) - $ mkStream ls Static lu (pointL i $ j-1) --- mkStream _ _ _ _ = error "mkStream / Chr / PointL not implemented" - {-# INLINE mkStream #-} - -instance - ( Monad m - , Element ls (Outside PointL) - , MkStream m ls (Outside PointL) - ) => MkStream m (ls :!: Chr r x) (Outside PointL) where - mkStream (ls :!: Chr f xs) Static lu@(O (PointL (l:.u))) (O (PointL (i:.j))) - = staticCheck (j MkStream m (ls :!: Chr r x) Subword where - mkStream (ls :!: Chr f xs) Static lu@(Subword (l:.u)) ij@(Subword (i:.j)) - -- We use a static check here as we can then pull out the @z@ character - -- lookup. In the Nussinov example (X -> f <<< z1 t z2 t) this gives - -- a 3x performance improvement. Note that this benchmark is a bit - -- artificial. - -- - -- The static part is called @right-most@, i.e. when only terminals with - -- known fixed sizes are on the right of this terminal. - = staticCheck (j>0 && j<=u) $ - let !z = f xs (j-1) - in S.map (ElmChr z (subword (j-1) j)) - $ mkStream ls Static lu (subword i $ j-1) - mkStream (ls :!: Chr f xs) v lu ij@(Subword (i:.j)) - -- This version is used when to right, we already had variable-size - -- (non-)terminals to the right. - = S.map (\s -> let Subword (k:.l) = getIdx s - in ElmChr (f xs l) (subword l $ l+1) s - ) - $ mkStream ls v lu (subword i $ j-1) - {-# INLINE mkStream #-} --} - --- Note how the indices grow to the outside! - -{- -instance - ( Monad m - , Element ls (Outside Subword) - , MkStream m ls (Outside Subword) - ) => MkStream m (ls :!: Chr r x) (Outside Subword) where - -- For the static case, we move the @j@ index. - mkStream (ls :!: Chr f xs) Static lu@(O (Subword (l:.u))) ij@(O (Subword (i:.j))) - = staticCheck (j>=0 && j let O (Subword (_:.l)) = getIdx s - in ElmChr (f xs l) (O . subword l $ l+1) s - ) - $ mkStream ls v lu (O $ subword (i-1) j) - {-# INLINE mkStream #-} --} - - - -{- - --- * Multi-dimensional stuff - -{- -instance TermStaticVar (Chr r x) Subword where - termStaticVar _ sv _ = sv - termStreamIndex _ _ (Subword (i:.j)) = subword i $ j-1 - {-# INLINE termStaticVar #-} - {-# INLINE termStreamIndex #-} --} - -instance TermStaticVar (Chr r x) PointR where - termStaticVar _ sv _ = sv - termStreamIndex _ _ (PointR (i:.j)) = pointR i $ j-1 - {-# INLINE termStaticVar #-} - {-# INLINE termStreamIndex #-} - --- TODO removed the static check since *in principle* the statics system down --- at the bottom of the stack should take care of it! Need to verify with --- QuickCheck, though. - -{- -instance - ( Monad m - , TerminalStream m a is - ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.Subword) where - terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.Subword (i:.j)) - = id -- staticCheck (j>0) - . S.map (\(Qd s (z:._) is e) -> Qd s z (is:.subword (j-1) j) (e:.f v (j-1))) - . terminalStream a sv is - . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is) - terminalStream (a:>Chr f (!v)) (sv:._) (is:.Subword (i:.j)) - = S.map (\(Qd s (z:.Subword (k:.l)) is e) -> Qd s z (is:.subword l (l+1)) (e:.f v (l-1))) - . terminalStream a sv is - . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is) - {-# INLINE terminalStream #-} --} - -{- -instance - ( Monad m - , TerminalStream m a is - ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointR) where - terminalStream (a:>Chr f (!v)) (sv:.Static) (is:.PointR (i:.j)) - = S.map (\(Qd s (z:._) is e) -> Qd s z (is:.pointR (j-1) j) (e:.f v (j-1))) - . terminalStream a sv is - . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is) - terminalStream (a:>Chr f (!v)) (sv:._) (is:.PointR (i:.j)) - = S.map (\(Qd s (z:.PointR (k:.l)) is e) -> Qd s z (is:.pointR l (l+1)) (e:.f v (l-1))) - . terminalStream a sv is - . S.map (\(Tr s z (is:.i)) -> Tr s (z:.i) is) - {-# INLINE terminalStream #-} --} - --} - - --} - diff --git a/ADP/Fusion/Term/Chr/Point.hs b/ADP/Fusion/Term/Chr/Point.hs --- a/ADP/Fusion/Term/Chr/Point.hs +++ b/ADP/Fusion/Term/Chr/Point.hs @@ -9,10 +9,9 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core +import ADP.Fusion.Core.Point import ADP.Fusion.Term.Chr.Type - -import ADP.Fusion.Base.Term diff --git a/ADP/Fusion/Term/Chr/Set0.hs b/ADP/Fusion/Term/Chr/Set0.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Chr/Set0.hs +++ /dev/null @@ -1,65 +0,0 @@ - --- | @Chr@ on sets is equivalent to having a @Vertex@ symbol. Each bit --- denotes one vertex point. - -module ADP.Fusion.Term.Chr.Set0 where - -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Data.Vector.Fusion.Stream.Monadic as S -import qualified Data.Vector.Generic as VG -import Prelude hiding (map) -import Data.Bits -import Data.Bits.Extras (msb,Ranked) -import Data.Bits.Ordered - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.Term.Chr.Type - - - -instance - ( TmkCtx1 m ls (Chr r x) (BitSet i) - ) => MkStream m (ls :!: Chr r x) (BitSet i) where - mkStream (ls :!: Chr f xs) sv us is - = S.map (\(ss,ee,ii) -> 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 - ( 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 RiBsI bs = getIndex (getIdx $ tS svS) (Proxy :: PRI is (BitSet I)) - mask = i `xor` bs - 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 ii ee) :. mask :. k ) - | k < 0 = return $ Done - | otherwise = - 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 #-} - {-# Inline termStream #-} - -instance TermStaticVar (Chr r x) (BitSet I) where - termStaticVar _ (IStatic rb) _ = IStatic $ rb + 1 - termStaticVar _ (IVariable rb) _ = IVariable $ rb + 1 - termStreamIndex _ _ b = b - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Chr/Subword.hs b/ADP/Fusion/Term/Chr/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Chr/Subword.hs +++ /dev/null @@ -1,98 +0,0 @@ - -module ADP.Fusion.Term.Chr.Subword where - -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Data.Vector.Fusion.Stream.Monadic as S -import qualified Data.Vector.Generic as VG -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.Term.Chr.Type - - - -instance - ( 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) -> 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 - ( 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)) - = 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 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 - ( 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 ii ee) -> - let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O)) - l = k - dj - 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 ii ee) -> - let RiSwO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (Subword O)) - l = k - dj - 1 - 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 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 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 #-} - - - -instance TermStaticVar (Chr r x) (Subword I) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ (Subword (i:.j)) = subword i (j-1) - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar (Chr r x) (Subword O) where - termStaticVar _ (OStatic (di:.dj)) _ = OStatic (di :.dj+1) - termStaticVar _ (ORightOf (di:.dj)) _ = ORightOf (di :.dj+1) - termStaticVar _ (OFirstLeft (di:.dj)) _ = OFirstLeft (di+1:.dj ) - termStaticVar _ (OLeftOf (di:.dj)) _ = OLeftOf (di+1:.dj ) - termStreamIndex _ _ sw = sw - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Chr/Type.hs b/ADP/Fusion/Term/Chr/Type.hs --- a/ADP/Fusion/Term/Chr/Type.hs +++ b/ADP/Fusion/Term/Chr/Type.hs @@ -12,7 +12,9 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi + -- | A generic Character parser that reads a single character but allows diff --git a/ADP/Fusion/Term/Deletion.hs b/ADP/Fusion/Term/Deletion.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Deletion.hs +++ /dev/null @@ -1,80 +0,0 @@ - -module ADP.Fusion.Term.Deletion - ( module ADP.Fusion.Term.Deletion.Type - , module ADP.Fusion.Term.Deletion.Point - , module ADP.Fusion.Term.Deletion.Subword - , module ADP.Fusion.Term.Deletion.Unit - ) where - -import ADP.Fusion.Term.Deletion.Point -import ADP.Fusion.Term.Deletion.Subword -import ADP.Fusion.Term.Deletion.Type -import ADP.Fusion.Term.Deletion.Unit - - -{- -import Data.Strict.Maybe -import Data.Strict.Tuple -import Prelude hiding (Maybe(..)) -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR) - -import ADP.Fusion.Term.Classes -import ADP.Fusion.Term.Multi.Classes - - - - -none = None -{-# INLINE none #-} - --- | Since 'None' doesn't really do anything for all indices, we just thread it --- through. - -instance TermStaticVar None ix where - termStaticVar _ sv _ = sv - termStreamIndex _ _ ij = ij - {-# INLINE termStaticVar #-} - {-# INLINE termStreamIndex #-} - -instance - ( Monad m - , TerminalStream m a is - ) => TerminalStream m (TermSymbol a None) (is:.PointL) where - terminalStream (a:|None) (sv:._) (is:._) - = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.())) - . terminalStream a sv is - . S.map moveIdxTr - {-# INLINE terminalStream #-} - - - --- * Single dimensional instances for 'None' are really weird - -{- -instance Element ls Subword => Element (ls :!: None) Subword where - data Elm (ls :!: None) Subword = ElmNone !Subword !(Elm ls Subword) - type Arg (ls :!: None) = Arg ls :. () - getArg (ElmNone _ l) = getArg l :. () - getIdx (ElmNone i _) = i - {-# INLINE getArg #-} - {-# INLINE getIdx #-} --} - --- | The instance does nothing (except insert @()@ into the argument --- stack). - -{- -instance - ( Monad m - , MkStream m ls Subword - ) => MkStream m (ls :!: None) Subword where - mkStream (ls :!: None) sv lu ij - = S.map (ElmNone ij) - $ mkStream ls sv lu ij - {-# INLINE mkStream #-} --} - --} - diff --git a/ADP/Fusion/Term/Deletion/Point.hs b/ADP/Fusion/Term/Deletion/Point.hs --- a/ADP/Fusion/Term/Deletion/Point.hs +++ b/ADP/Fusion/Term/Deletion/Point.hs @@ -7,7 +7,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core +import ADP.Fusion.Core.Point import ADP.Fusion.Term.Deletion.Type diff --git a/ADP/Fusion/Term/Deletion/Subword.hs b/ADP/Fusion/Term/Deletion/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Deletion/Subword.hs +++ /dev/null @@ -1,91 +0,0 @@ - -module ADP.Fusion.Term.Deletion.Subword where - -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic as S -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.Term.Deletion.Type - - - -instance - ( TmkCtx1 m ls Deletion (Subword i) - ) => MkStream m (ls :!: Deletion) (Subword i) where - mkStream (ls :!: Deletion) sv us is - = 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 #-} - - - -instance - ( 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 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 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 - ( 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 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 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 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 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 #-} - - - -instance TermStaticVar Deletion (Subword I) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ ij = ij - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar Deletion (Subword O) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ ij = ij - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Deletion/Type.hs b/ADP/Fusion/Term/Deletion/Type.hs --- a/ADP/Fusion/Term/Deletion/Type.hs +++ b/ADP/Fusion/Term/Deletion/Type.hs @@ -5,7 +5,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi diff --git a/ADP/Fusion/Term/Deletion/Unit.hs b/ADP/Fusion/Term/Deletion/Unit.hs --- a/ADP/Fusion/Term/Deletion/Unit.hs +++ b/ADP/Fusion/Term/Deletion/Unit.hs @@ -7,8 +7,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base -import ADP.Fusion.Term.Deletion.Type +import ADP.Fusion.Core +import ADP.Fusion.Core.Unit diff --git a/ADP/Fusion/Term/Edge.hs b/ADP/Fusion/Term/Edge.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Edge.hs +++ /dev/null @@ -1,64 +0,0 @@ - -module ADP.Fusion.Term.Edge - ( module ADP.Fusion.Term.Edge.Type - , module ADP.Fusion.Term.Edge.Set - ) where - -import ADP.Fusion.Term.Edge.Set -import ADP.Fusion.Term.Edge.Type - - - -{- --- | An edge terminal returns the pair of indices forming the edge. - -data Edge e where - Edge :: !(Int -> Int -> e) -> Edge e - -edge = (,) -{-# Inline edge #-} - -instance Build (Edge i) - -instance - (Element ls i - ) => Element (ls :!: Edge e) i where - data Elm (ls :!: Edge e) i = ElmEdge !e !i !(Elm ls i) - type Arg (ls :!: Edge e) = Arg ls :. e - getArg (ElmEdge e _ ls) = getArg ls :. e - getIdx (ElmEdge _ i _ ) = i - {-# Inline getArg #-} - {-# Inline getIdx #-} - -instance - ( Monad m - , Element ls (BitSet:>Interface First:>Interface Last) - , MkStream m ls (BitSet:>Interface First:>Interface Last) - ) => MkStream m (ls :!: Edge e) (BitSet:>Interface First:>Interface Last) where - -- encodes in the first index arg, what the previously set @Last@ was - mkStream (ls :!: Edge f) Static s@(BitSet zb:>Interface zi:>Interface zj) (BitSet b:>Interface i:>Interface j) - -- if we have @popCount b == 1@, then this is an initial node, - -- creating the first node. Otherwise the edge just extends an - -- existing node. - -- TODO need to figure out this "first node" stuff here - = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z - in ElmEdge (f zj j) (BitSet b:>Interface i:>Interface j) z - ) - $ mkStream ls (Variable Check (Just (popCount b -1) )) s (BitSet (clearBit b j):>Interface i:>Interface j) - -- in the variable case, the @Last@ point is unset and may move freely. - -- @First@ is still fixed. In @k@, we have the number of bits from - -- @BitSet b@ that we should set! The bit we set is also the @Last@ - -- interface bit. - mkStream (ls :!: Edge f) (Variable Check (Just k)) s@(BitSet zb:>Interface zi:>Interface zj) c@(BitSet b:>Interface i:>_) - = S.flatten mk step Unknown - $ mkStream ls (Variable Check (Just $ k-1)) s c - where mk z = let (BitSet z':>_:>_) = getIdx z ; a = b `xor` z' in return (z,a,lsbActive a) - step (z,a,lsbA) - | lsbA < 0 = return $ S.Done - | otherwise = return $ S.Yield (ElmEdge (f cj lsbA) (BitSet (cs .|. bit lsbA):>Interface ci:>Interface lsbA) z) (z,a,nextActive lsbA a) - where (BitSet cs:>Interface ci:>Interface cj) = getIdx z - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} --} - diff --git a/ADP/Fusion/Term/Edge/Set.hs b/ADP/Fusion/Term/Edge/Set.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Edge/Set.hs +++ /dev/null @@ -1,72 +0,0 @@ - -module ADP.Fusion.Term.Edge.Set where - -import Data.Bits -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic hiding (flatten) -import Debug.Trace -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) -import Data.Bits.Ordered - -import ADP.Fusion.Base -import ADP.Fusion.Term.Edge.Type - - - -instance - ( Monad m - , Element ls (BS2 First Last I) - , MkStream m ls (BS2 First Last I) - ) => MkStream m (ls :!: Edge e) (BS2 First Last I) where - mkStream (ls :!: Edge f) (IStatic rp) u sij@(BS2 s i j) - = flatten mk step $ mkStream ls (IStatic rpn) u tik - where rpn | j >= 0 = rp - | otherwise = rp+1 - tik | j >= 0 = BS2 (s `clearBit` (getIter j)) i undefi - | otherwise = sij - mk z - | j >= 0 && popCount s >= 2 = return $ This z - | j < 0 && popCount s >= 2 = return $ That (z,bits,maybeLsb bits) - | popCount s <= max 1 rp = return $ Naught - | otherwise = error $ show ("Edge",s,i,j) - where 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)) (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 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 #-} - - - -instance - ( Monad m - , Element ls (BS2 First Last O) - , MkStream m ls (BS2 First Last O) - ) => MkStream m (ls :!: Edge f) (BS2 First Last O) where - mkStream (ls :!: Edge f) (OStatic ()) u sij - = map undefined - $ mkStream ls (undefined) u sij - {-# Inline mkStream #-} - - - -instance - ( Monad m - , Element ls (BS2 First Last C) - , MkStream m ls (BS2 First Last C) - ) => MkStream m (ls :!: Edge f) (BS2 First Last C) where - mkStream (ls :!: Edge f) Complemented u sij - = map undefined - $ mkStream ls Complemented u sij - {-# Inline mkStream #-} - diff --git a/ADP/Fusion/Term/Edge/Type.hs b/ADP/Fusion/Term/Edge/Type.hs --- a/ADP/Fusion/Term/Edge/Type.hs +++ b/ADP/Fusion/Term/Edge/Type.hs @@ -5,7 +5,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi diff --git a/ADP/Fusion/Term/Epsilon.hs b/ADP/Fusion/Term/Epsilon.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Epsilon.hs +++ /dev/null @@ -1,120 +0,0 @@ - -module ADP.Fusion.Term.Epsilon - ( module ADP.Fusion.Term.Epsilon.Type - , module ADP.Fusion.Term.Epsilon.Point - , module ADP.Fusion.Term.Epsilon.Set - , module ADP.Fusion.Term.Epsilon.Subword - , module ADP.Fusion.Term.Epsilon.Unit - ) where - -import ADP.Fusion.Term.Epsilon.Point -import ADP.Fusion.Term.Epsilon.Set -import ADP.Fusion.Term.Epsilon.Subword -import ADP.Fusion.Term.Epsilon.Type -import ADP.Fusion.Term.Epsilon.Unit - -{- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | The 'Empty' terminal symbol parses only the empty (sub-)input. @Empty@ --- however, can mean different things. --- --- 'Empty' needs to be bound to the input. We require this as certain index --- structures have no natural notion of emptyness -- unless additional --- information is given. --- --- Consider, for example, linear grammars. Left-linear grammars can compare the --- index @i@ to zero, @i==0@ to test for emptyness, while for right-linear --- grammars, we need to test @i==N@ with @N@ the size of the input. Instead of --- carrying @N@ around in the index, we bind the input to @Empty@. --- --- This choice is currently a bit of a "hunch" but we do have algorithms in --- mind, where this could be useful. - -module ADP.Fusion.Term.Empty where - -import Data.Strict.Maybe -import Prelude hiding (Maybe(..)) - -import Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR, Outside(..)) - -import ADP.Fusion.Term.Classes -import ADP.Fusion.Term.Multi.Classes - -import Debug.Trace - - - --- | Empty as an argument only makes sense if empty is static. We don't get to --- use 'staticCheck' as the underlying check for the bottom of the argument --- stack should take care of the @i==j@ check. - -{- -instance - ( Monad m - , MkStream m ls Subword - ) => MkStream m (ls :!: Empty) Subword where - mkStream (ls :!: Empty) Static lu (Subword (i:.j)) - = S.map (ElmEmpty (subword i j)) - $ mkStream ls Static lu (subword i j) - mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters" - {-# INLINE mkStream #-} - -instance - ( Monad m - , MkStream m ls (Outside Subword) - ) => MkStream m (ls :!: Empty) (Outside Subword) where - mkStream (ls :!: Empty) Static lu (O (Subword (i:.j))) - = S.map (ElmEmpty (O $ subword i j)) - $ mkStream ls Static lu (O $ subword i j) - mkStream _ _ _ _ = error "mkStream Empty/Subword called with illegal parameters" - {-# INLINE mkStream #-} --} - -type instance TermArg (TermSymbol a Empty) = TermArg a :. () - -instance TermStaticVar Empty PointL where - termStaticVar _ sv _ = sv - termStreamIndex _ _ ij = ij - {-# INLINE termStaticVar #-} - {-# INLINE termStreamIndex #-} - -{- -instance TermStaticVar Empty Subword where - termStaticVar = error "write me" - termStreamIndex = error "write me" --} - --- | Again, we assume that no 'staticCheck' is necessary and that @i==j@ is --- true. - -instance - ( Monad m - , TerminalStream m a is - ) => TerminalStream m (TermSymbol a Empty) (is:.PointL) where - terminalStream (a:|Empty) (sv:.Static) (is:.PointL (i:.j)) - = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.())) - . terminalStream a sv is - . S.map moveIdxTr - terminalStream _ _ _ = error "mkStream Empty/(is:.PointL) called with illegal parameters" - {-# INLINE terminalStream #-} - -{- -instance - ( Monad m - , TerminalStream m a is - ) => TerminalStream m (TermSymbol a Empty) (is:.Subword) where - terminalStream (a:>Empty) (sv:.Static) (is:.Subword (i:.j)) - = S.map (\(Qd s (z:.i) is e) -> Qd s z (is:.i) (e:.())) - . terminalStream a sv is - . S.map moveIdxTr - terminalStream _ _ _ = error "mkStream Empty/(is:.Subword) called with illegal parameters" - {-# INLINE terminalStream #-} --} - --} - diff --git a/ADP/Fusion/Term/Epsilon/Point.hs b/ADP/Fusion/Term/Epsilon/Point.hs --- a/ADP/Fusion/Term/Epsilon/Point.hs +++ b/ADP/Fusion/Term/Epsilon/Point.hs @@ -7,7 +7,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core +import ADP.Fusion.Core.Point import ADP.Fusion.Term.Epsilon.Type diff --git a/ADP/Fusion/Term/Epsilon/Set.hs b/ADP/Fusion/Term/Epsilon/Set.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Epsilon/Set.hs +++ /dev/null @@ -1,97 +0,0 @@ - -module ADP.Fusion.Term.Epsilon.Set where - -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic as S -import Prelude hiding (map) - -import Data.Bits.Ordered -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.Term.Epsilon.Type - - - --- ** No boundaries - -instance - ( TmkCtx1 m ls Epsilon (BitSet i) - ) => MkStream m (ls :!: Epsilon) (BitSet i) where - mkStream (ls :!: Epsilon) sv us is - = map (\(ss,ee,ii) -> ElmEpsilon ii ss) - . addTermStream1 Epsilon sv us is - $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) - {-# Inline mkStream #-} - - - -instance - ( 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 ii ee) -> - TState s (ii:.:RiBsI 0) (ee:.()) ) - . termStream ts cs us is - {-# Inline termStream #-} - -instance - ( 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 ii ee) -> - TState s (ii:.:RiBsO u u) (ee:.()) ) - . termStream ts cs us is - {-# Inline termStream #-} - - - -instance TermStaticVar Epsilon (BitSet I) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ b = b - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar Epsilon (BitSet O) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ b = b - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - - - --- ** Two boundaries - -instance - ( TmkCtx1 m ls Epsilon (BS2 First Last i) - ) => MkStream m (ls :!: Epsilon) (BS2 First Last i) where - mkStream (ls :!: Epsilon) sv us is - = map (\(ss,ee,ii) -> ElmEpsilon ii ss) - . addTermStream1 Epsilon sv us is - $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is) - {-# Inline mkStream #-} - -instance - ( 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 ii ee) -> - TState s (ii:.:RiBs2I (BS2 0 0 0)) (ee:.()) ) - . termStream ts cs us is - {-# Inline termStream #-} - -instance - ( 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 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 #-} - diff --git a/ADP/Fusion/Term/Epsilon/Subword.hs b/ADP/Fusion/Term/Epsilon/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Epsilon/Subword.hs +++ /dev/null @@ -1,61 +0,0 @@ - -module ADP.Fusion.Term.Epsilon.Subword where - -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic as S -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.Term.Epsilon.Type - - - -instance - ( TmkCtx1 m ls Epsilon (Subword i) - ) => MkStream m (ls :!: Epsilon) (Subword i) where - mkStream (ls :!: Epsilon) sv us is - = 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 - ( 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)) - = map (\(TState s ii ee) -> - TState s (ii:.:RiSwI j) (ee:.()) ) - . termStream ts cs us is - . staticCheck (i==j) - {-# Inline termStream #-} - -instance - ( 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 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 #-} - - - -instance TermStaticVar Epsilon (Subword I) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ ij = ij - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - -instance TermStaticVar Epsilon (Subword O) where - termStaticVar _ sv _ = sv - termStreamIndex _ _ ij = ij - {-# Inline [0] termStaticVar #-} - {-# Inline [0] termStreamIndex #-} - diff --git a/ADP/Fusion/Term/Epsilon/Type.hs b/ADP/Fusion/Term/Epsilon/Type.hs --- a/ADP/Fusion/Term/Epsilon/Type.hs +++ b/ADP/Fusion/Term/Epsilon/Type.hs @@ -5,7 +5,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi diff --git a/ADP/Fusion/Term/Epsilon/Unit.hs b/ADP/Fusion/Term/Epsilon/Unit.hs --- a/ADP/Fusion/Term/Epsilon/Unit.hs +++ b/ADP/Fusion/Term/Epsilon/Unit.hs @@ -7,8 +7,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base -import ADP.Fusion.Term.Epsilon.Type +import ADP.Fusion.Core +import ADP.Fusion.Core.Unit diff --git a/ADP/Fusion/Term/PeekIndex.hs b/ADP/Fusion/Term/PeekIndex.hs deleted file mode 100644 --- a/ADP/Fusion/Term/PeekIndex.hs +++ /dev/null @@ -1,8 +0,0 @@ - -module ADP.Fusion.Term.PeekIndex - ( module ADP.Fusion.Term.PeekIndex.Type - , module ADP.Fusion.Term.PeekIndex.Subword - ) where - -import ADP.Fusion.Term.PeekIndex.Subword -import ADP.Fusion.Term.PeekIndex.Type diff --git a/ADP/Fusion/Term/PeekIndex/Subword.hs b/ADP/Fusion/Term/PeekIndex/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/Term/PeekIndex/Subword.hs +++ /dev/null @@ -1,24 +0,0 @@ - -module ADP.Fusion.Term.PeekIndex.Subword where - -import Data.Strict.Tuple -import Data.Vector.Fusion.Stream.Monadic (map) -import Prelude hiding (map) - -import Data.PrimitiveArray hiding (map) - -import ADP.Fusion.Base -import ADP.Fusion.Term.PeekIndex.Type - - - -instance - ( Monad m - , Element ls (Subword C) - , MkStream m ls (Subword C) - ) => MkStream m (ls :!: PeekIndex (Subword C)) (Subword C) where - mkStream (ls :!: PeekIndex) Complemented h ij - = map (\s -> let ri@(RiSwC k l) = getIdx s in ElmPeekIndex (subword k l) ri s) - $ mkStream ls Complemented h ij - {-# Inline mkStream #-} - diff --git a/ADP/Fusion/Term/PeekIndex/Type.hs b/ADP/Fusion/Term/PeekIndex/Type.hs --- a/ADP/Fusion/Term/PeekIndex/Type.hs +++ b/ADP/Fusion/Term/PeekIndex/Type.hs @@ -5,7 +5,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi diff --git a/ADP/Fusion/Term/Strng.hs b/ADP/Fusion/Term/Strng.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Strng.hs +++ /dev/null @@ -1,13 +0,0 @@ - --- | A 'Strng' matches [0..] 'Chr's. - -module ADP.Fusion.Term.Strng - ( module ADP.Fusion.Term.Strng.Type - , module ADP.Fusion.Term.Strng.Point - , module ADP.Fusion.Term.Strng.Subword - ) where - -import ADP.Fusion.Term.Strng.Point -import ADP.Fusion.Term.Strng.Subword -import ADP.Fusion.Term.Strng.Type - diff --git a/ADP/Fusion/Term/Strng/Point.hs b/ADP/Fusion/Term/Strng/Point.hs --- a/ADP/Fusion/Term/Strng/Point.hs +++ b/ADP/Fusion/Term/Strng/Point.hs @@ -9,7 +9,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core +import ADP.Fusion.Core.Point import ADP.Fusion.Term.Strng.Type diff --git a/ADP/Fusion/Term/Strng/Subword.hs b/ADP/Fusion/Term/Strng/Subword.hs deleted file mode 100644 --- a/ADP/Fusion/Term/Strng/Subword.hs +++ /dev/null @@ -1,84 +0,0 @@ - -module ADP.Fusion.Term.Strng.Subword where - -import Data.Proxy -import Data.Strict.Tuple -import Data.Vector.Fusion.Util (delay_inline) -import Debug.Trace -import Prelude hiding (map) -import qualified Data.Vector.Fusion.Stream.Monadic as S -import qualified Data.Vector.Generic as VG - -import Data.PrimitiveArray - -import ADP.Fusion.Base -import ADP.Fusion.Term.Strng.Type - - - -instance - ( TmkCtx1 m ls (Strng v x) (Subword i) - ) => MkStream m (ls :!: Strng v x) (Subword i) where - mkStream (ls :!: strng) sv us is - = S.map (\(ss,ee,ii) -> ElmStrng ee ii ss) - . addTermStream1 strng sv us is - $ mkStream ls (termStaticVar strng sv is) us (termStreamIndex strng sv is) - {-# Inline mkStream #-} - -instance - ( 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 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 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 #-} - {-# Inline [0] step #-} - {-# Inline termStream #-} - -{- - --- | TODO If we use (IVariable mx) we might be able to request @exactly@ --- the range we need! - -instance - ( Monad m - , Element ls (Subword I) - , MkStream m ls (Subword I) - ) => MkStream m (ls :!: Strng v x) (Subword I) where - mkStream (ls :!: Strng slice mn mx v) (IStatic ()) hh (Subword (i:.j)) - = S.filter (\s -> let Subword (k:.l) = getIdx s in l-k <= mx) - . S.map (\s -> let (Subword (_:.l)) = getIdx s - in ElmStrng (slice l (j-l) v) (subword l j) (subword 0 0) s) - $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn)) - mkStream (ls :!: Strng slice mn mx v) (IVariable ()) hh (Subword (i:.j)) - = S.flatten mk step $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - mn)) - where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - mn) - step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s - l = j - z - kl = subword k l - return $ S.Yield (ElmStrng (slice k (l-k) v) kl (subword 0 0) s) (s:.z-1) - | otherwise = return $ S.Done - {-# Inline [0] mk #-} - {-# Inline [0] step #-} - {-# Inline mkStream #-} - --} - diff --git a/ADP/Fusion/Term/Strng/Type.hs b/ADP/Fusion/Term/Strng/Type.hs --- a/ADP/Fusion/Term/Strng/Type.hs +++ b/ADP/Fusion/Term/Strng/Type.hs @@ -6,7 +6,8 @@ import Data.PrimitiveArray -import ADP.Fusion.Base +import ADP.Fusion.Core.Classes +import ADP.Fusion.Core.Multi diff --git a/ADP/Fusion/Tutorial/NeedlemanWunsch.hs b/ADP/Fusion/Tutorial/NeedlemanWunsch.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Tutorial/NeedlemanWunsch.hs @@ -0,0 +1,495 @@ + +{-# Options_GHC -fno-warn-unused-imports #-} + +{-| + +The Needleman-Wunsch global alignment algorithm. This algorithm is +extremely simple but provides a good showcase for what ADPfusion offers. + +The Needleman-Wunsch algorithm aligns to strings @x = x_1 x_2 x_3 ...@ and +@y = y_1 y_2 y_3 ...@ which may be of differing lengths. Assume that @x_1 +... x_{i-1}@ and @y_1 ... y_{j-1}@ have already been optimally aligned. We +can match @x_i@ with @y_j@, or perform one of two possible insert-deletion +pairs. Either @x_i@ is aligned with @-@ or @-@ is aligned with @y_j@. More +general, in each DP step, either one or both inputs are extended by one +character. + +For the actual implementation, we assume however, that we work backward. +The entries @d@, @u@, and @l@ have already been calculated. Now we want to +compute the entry at @x@ in the lower right corner. + +@ + ----- + |d|u| + ----- + |l|x| + ----- +@ + +We introduce a generic naming scheme for each possible move. If we move in +a direction, we call it a @step@. If we do not move, then we call it +a @loop@, because the index loops for this computation. + +We can arrive from @d@, making a diagonal step, called @step_step@ as we +advance by one in both dimensions. This leads to an alignment of two +characters, one from each input, at @x@, which is combined with the already +calculated alignment at @d@. + +We can also just step in the first dimension @step_loop@, going from @l@ to +@x@. Which means that the first-dim character does not have a partner, +leading to an insert/deletion or in/del. We typically do not care in which +of the two dimensions the in/del happens, just that it does. + +The third case is an in/del in the other dimension, giving us @loop_step@ +or going from @u@ to @x@. + +Of course, if @x@ happens to be the uppermost, leftmost cell, we have +nowhere to come from, so we need to inititialize (or terminate depending on +your view point) using the @nil_nil@ case. That one is the base case. + +We also want to know which of the three cases is the best case (coming from +@d,l,u@), this requires a "choice" function or @h@. + + +We now implement this algorithm using the low-level ADPfusion library. +Follow the code from top to bottom for a tutorial on usage. The +Needleman-Wunsch tutorial for the @FormalGrammars@ library provides +a higher-level style of implementation. + + + +We also provide an implementation based on grammar products, which simplify +the design of alignment-type algorithms. The corresponding tutorial is +here. + + + + + +Don't forget to inline basically everything! + +-} + +module ADP.Fusion.Tutorial.NeedlemanWunsch + ( + -- * Module Header + -- $header + + -- * Signature + -- $signature + + -- * Algebra Product + -- $algebraproduct + + -- * Grammar + -- $grammar + + -- * Scoring Algebra + -- $algebrascore + + -- * Pretty-printing Algebra + -- $algebrapretty + + -- * The @Inside@ version + + -- ** Table-filling for the @Inside@ version + -- $insideforward + + -- ** Backtracking optimal results for the @Inside@ version + -- $insidebacktrack + + -- ** Glueing the @Inside@ version parts together + -- $runforward + + -- * The @Outside@ version + + -- ** Table-filling for the @Outside@ version + -- $outsideforward + + -- ** Backtracking optimal results for the @Outside@ version + -- $outsidebacktrack + + -- ** Glueing the @Outside@ version parts together + -- $runoutside + + -- * Wrapping everything up + + -- ** Alignment wrapper + -- $alignwrapper + + -- ** Main + -- $main + + ) where + +import ADP.Fusion.Point + +{- $header + +We start by importing a bunch of modules, including @Data.PrimitiveArray@ +for low-level arrays and automated filling of the arrays or tables in the +correct order. + +We also need to import @ADP.Fusion@ to access the high-level code for +dynamic programs. + + +> module Main where + +> import Control.Monad (forM_) +> import System.Environment (getArgs) +> import Text.Printf + +Streams of parses are the streams defined in the @vector@ package. + +> import qualified Data.Vector.Fusion.Stream.Monadic as SM + +We use unboxed vectors to hold the input sequences to be aligned. The +terminal parses work with any vector in the @vector@ package. + +> import qualified Data.Vector.Unboxed as VU + +@Data.PrimitiveArray@ contains data structures, and index structures for +dynamic programming. Notably, the primitive arrays holding the cell data +with Boxed and Unboxed tables. In addition, linear, context-free, and set +data structures are made available. + +> import Data.PrimitiveArray as PA hiding (map) + +@ADP.Fusion.Point@ exposes everything necessary for higher-level DP +algorithms. Depending on the type of DP algorithm, different top-level +modules can be imported. @.Point@ for linear grammars, and @.Core@ are +provided in this package. @.Core@ exports only the core modules required to +extend ADPfusion. + +> import ADP.Fusion.Point + +-} + + + +{- $signature + +A signature connects the types of all non-terminals and terminals with +evaluation (or attribute) functions. In the grammar below, we not only want +to create all possible parses of how two strings can be aligned but also +evaluate each parse and choose the optimal one based on Bellman's principle +of optimality. + +We take a close look at the type signatures. @step_step :: x -> (Z:.c:.c) +-> x@ tells us that @step_step@ requires the score from the non-terminal, +typed @x@ for the alignment up to @d@, then we get the two characters with +type @c@ and produce a new non-terminal typed score @x@. For our simple +alignment we'll later choose @Char@ for @c@ and @Int@ for @x@. + +The type of @h :: Stream m x -> m r@ is more interesting. We get a @Stream@ +of @x@'s and produce an @r@ monadically. The left part is clear @Stream +m x@ are the results from the four rules, but the right part allows us to +maybe not only return the best case, types @x == r@, but maybe the two best +cases @r == (x,x)@ or similar. While we do not use this feature here, it +makes ADPfusion fully "classified DP" capable, which is a really cool +feature for advanced algorithms. + +> 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 +> , h :: Stream m x -> m r +> } + +-} + + + +{- $algebraproduct + +We also want to be able to backtrace the optimal result. Given our +alignment, knowing that we get an alignment score of 29 doesn't help us +much. But with /algebra products/ we can ask for @(optimal <** pretty)@ and +get the optimal result /and/ the parse for it. + +The @(<**)@ operator is notoriously difficult to write, so we just compute +it ☺. + +Note that haddock actually shows @(<**)@, while you just write +@makeAlgebraProductH ['h] ''Signature@ (the primes are TemplateHaskell, +the only TemplateHaskell we need). + +> makeAlgebraProduct ''Signature + +-} + + + +{- $grammar + +This is the linear grammar in two dimensions describing the +"Needleman-Wunsch" search space. It will, in principle, enumerate the +exponential number of possible alignment, but due to memoization and the +choice function @h@, the calculation time is @O(N^2)@ and if only one +optimal alignment is requested, backtracking works in linear time. + +The grammar first requires a 'Signature', we use @RecordWildCards@ as +a language extension to bind @step_step@ and friends. We also need +a variable for the single non-terminal (@a@), and have two inputs @i1@ and +@i2@. Each grammar starts with a "base case" @Z:.@ followed by one or more +pairs of non-terminal plus rules. Here we have one pair @(a, rules)@, where +in @rules@ we combine the four different rules. + +@step_step \<\<\< a % (M:>chr i1:>chr i2)@, for example, means that +@step_step@ first gets the non-terminal @a@, which will give the score up +to @d@ (see the ascii-art above), followed by @(%)@ the 2-dim terminal for +@i1@ and @i2@. + +Multi-dimensional terminals are built up from the zero-dimension @M@, +separated by @:|@ symbols and just bind the input. In this case we want +individual characters from @i1@ and @i2@, so we write @chr i1@ or @chr i2@. + +Different rules are combined with @(|||)@ and the optimal case is selected +via @... h@. Rules can, of course, be co-recursive, each rule can request +all terminal and non-terminal symbols. + +Due to the way @nil_nil@ works on @Epsilon@, @nil_nil@ is actually /only/ +called once, when we start the alignment, not for every cell! + +/However/, due to this being a high-performance library, we do not provide +a runtime scheme to detect misbehaving rules. Some debug-code is in place +that performs certain checks in non-optimized GHCI sessions, but optimized +code is built for raw speed, without any checks. + +If you are a "conventional" DP programmer, you might miss the usual +indices. Just as in the spiritual father of @ADPfusion@, Robert Giegerichs +@ADP@, we hide the actual index calculations. + +> grammar Signature{..} !a' !i1 !i2 = +> let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2) ||| +> step_loop <<< a % (M:|chr i1:|Deletion ) ||| +> loop_step <<< a % (M:|Deletion :|chr i2) ||| +> nil_nil <<< (M:|Epsilon:|Epsilon) ... h +> ) +> in Z:.a +@ +\{\-\# INLINE grammar \#\-\} +@ + +-} + + + +{- $algebrascore + +A grammar alone is not enough, we also need to say what a @step_step@ +means, or what an optimum is. Here, we do exactly that. We create an +instance of the 'Signature' from above. Since this is a simple example, we +just say that two aligned characters @a@ and @b@ yield a score of @x+1@ +(with @x@ the previous alignment score) if the characters are identical. +Otherwise we lower the score by 2. In/dels incur a cost of @-1@, meaning +that a mismatch is actually the same as two in/dels, one in each dimension. +The start of the alignment gives an initial score of 0. + +And the optimal choice, of course, is to start with a default of @-999999@ +and find the maximum of that score and the choices we are given. + +> 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 +> , h = SM.foldl' max (-999999) +> } +@ +\{\-\# INLINE sScore \#\-\} +@ + +-} + + + +{- $algebrapretty + +Scores alone are still not enough, we also want to pretty-print alignments. +An alignment are basically two strings @[String 1, String 2]@, being turned +into a whole stream of alignments, using @Char@s for the individual +characters being aligned. + +We follow the same theme as in 'sScore', but this time @h = toList@, that +is the choice function @h@ does not (!) make choice but rather returns all +alignments. You already heard about @<**@, we'll use it below. + +> sPretty :: Monad m => Signature m [String] [[String]] Char +> sPretty = Signature +> { step_step = \[x,y] (Z:.a :.b ) -> [a :x, b :y] +> , step_loop = \[x,y] (Z:.a :.()) -> [a :x, '-':y] +> , loop_step = \[x,y] (Z:.():.b ) -> ['-':x, b :y] +> , nil_nil = const ["",""] +> , h = SM.toList +> } +@ +\{\-\# Inline sPretty \#\-\} +@ + +-} + + + +{- $insideforward + +The forward or table-filling phase. It is possible to inline this code +directly into 'runNeedlemanWunsch'. Here, this phase is separated. If you +use @ghc-core@ to examine the @GHC Core@ language, you can search for +@nwInsideForward@ and check wether the inside code is optimized well. This +is normally /not/ required, and only done here, because these algorithms +are used to gauge efficiency of the fusion framework as well. + +For your own code, you can write as done here, or in the way of +'runOutsideNeedlemanWunsch'. + +> nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl 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 \#\-\} +@ + +We normally do not want to inline a fully specified algorithm. Compilation +times are rather long, and in this way, we only compile once for the +library, not every time the algorithm is called. + +-} + + + +{- $insidebacktrack + +> nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> TwITbl 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 +> :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String] +@ +\{\-\# NoInline nwInsideBacktrack \#\-\} +@ + +-} + + + +{- $runforward + +The inside grammar, with efficient table-filling (via 'nwInsideForward') +and backtracking. Requests @k@ co-optimal backtrackings, given the inputs +@i1@ and @i2@. The @fst@ element returned is the score, the @snd@ are the +co-optimal parses. + +runNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]]) +runNeedlemanWunsch k i1' i2' = (d, take k bs) 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 + bs = nwInsideBacktrack i1 i2 t +@ +\{\-\# Noinline runNeedlemanWunsch \#\-\} +@ + +-} + + + +{- $outsideforward + +Again, to be able to observe performance, we have extracted the +outside-table-filling part. + +> nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl 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) [])) +> i1 i2 +> where n1 = VU.length i1 +> n2 = VU.length i2 +@ +\{\-\# Noinline nwOutsideForward \#\-\} +@ + +-} + + + +{- $runoutside + +The outside version of the Needleman-Wunsch alignment algorithm. The +outside grammar is identical to the inside grammar! This is not generally +the case, but here it is. Hence we may just use outside tables and the +grammar from above. + +> runOutsideNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]]) +> runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where +> i1 = VU.fromList i1' +> i2 = VU.fromList i2' +> n1 = VU.length i1 +> n2 = VU.length i2 +> !(Z:.t) = nwOutsideForward i1 i2 +> d = unId $ axiom t +> !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 +> :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String] +@ +\{\-\# Noinline runOutsideNeedlemanWunsch \#\-\} +@ + +-} + + + +{- $alignwrapper + +This wrapper takes a list of input sequences and aligns each odd sequence +with the next even sequence. We want one alignment for each such pair. + +Since we use basic lists during backtracking, the resulting lists have to +be reversed for inside-backtracking. Note that because the Outside grammar +is quasi-right-linear, it does not require reversing the two strings. + +For real applications, consider using @Data.Sequence@ which has @O(1)@ +append and prepend. + +> align _ [] = return () +> align _ [c] = putStrLn "single last line" +> align k (a:b:xs) = {-# SCC "align" #-} do +> putStrLn a +> putStrLn b +> putStrLn "" +> let (sI,rsI) = runNeedlemanWunsch k a b +> let (sO,rsO) = runOutsideNeedlemanWunsch k a b +> forM_ rsI $ \[u,l] -> printf "%s\n%s %d\n\n" (reverse u) (reverse l) sI +> forM_ rsO $ \[u,l] -> printf "%s\n%s %d\n\n" (id u) (id l) sO +> align k xs + +-} + + + +{- $main + +And finally have a minimal main that reads from stdio. + +If you are brave enough then put this through @ghc-core@ and look for +@nwInsideForward@ or @nwOutsideForward@ in the CORE. Everything coming from +the forward phase should be beautifully optimized and the algorithm should +run quite fast. + +> main = do +> as <- getArgs +> let k = if null as then 1 else read $ head as +> ls <- lines <$> getContents +> align k ls + +-} + diff --git a/ADP/Fusion/Unit.hs b/ADP/Fusion/Unit.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Unit.hs @@ -0,0 +1,18 @@ + +-- | Unit indices have just a single element in their set. This is actually +-- *not* useless, since it can be used to "fold" from another index +-- structure into the single @()@ element. + +module ADP.Fusion.Unit + ( module ADP.Fusion.Core + , module ADP.Fusion.Term.Deletion.Unit + , module ADP.Fusion.SynVar.Indices.Unit + , module ADP.Fusion.Term.Epsilon.Unit + ) where + +import ADP.Fusion.Core + +import ADP.Fusion.Term.Deletion.Unit +import ADP.Fusion.Term.Epsilon.Unit +import ADP.Fusion.SynVar.Indices.Unit + diff --git a/ADPfusion.cabal b/ADPfusion.cabal --- a/ADPfusion.cabal +++ b/ADPfusion.cabal @@ -1,5 +1,5 @@ name: ADPfusion -version: 0.5.1.0 +version: 0.5.2.0 author: Christian Hoener zu Siederdissen, 2011-2016 copyright: Christian Hoener zu Siederdissen, 2011-2016 homepage: https://github.com/choener/ADPfusion @@ -11,7 +11,7 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0 -tested-with: GHC == 7.8.4, GHC == 7.10.3 +tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 synopsis: Efficient, high-level dynamic programming. description: @@ -64,87 +64,80 @@ default: False manual: True +flag devel + description: build additional tests + default: False + manual: True +flag btstruc + description: performance test for backtracking structures + default: False + manual: True + + library - build-depends: base >= 4.7 && < 4.9 - , bits >= 0.4 && < 0.5 + build-depends: base >= 4.7 && < 5.0 + , bits >= 0.4 && < 0.6 , containers - , mmorph >= 1.0 && < 1.1 - , 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 - , strict >= 0.3 && < 0.4 - , template-haskell >= 2.0 && < 3.0 - , th-orphans >= 0.12 && < 0.14 - , transformers >= 0.3 && < 0.5 - , tuple >= 0.3 && < 0.4 - , vector >= 0.11 && < 0.12 + , mmorph >= 1.0 && < 1.1 + , mtl >= 2.0 && < 2.3 + , primitive >= 0.5.4 && < 0.7 + , QuickCheck >= 2.7 && < 2.9 + , strict >= 0.3 && < 0.4 + , template-haskell >= 2.0 && < 3.0 + , th-orphans >= 0.12 && < 0.14 + , transformers >= 0.3 && < 0.6 + , tuple >= 0.3 && < 0.4 + , vector >= 0.11 && < 0.12 + -- + , DPutils == 0.0.0.* + , OrderedBits == 0.0.1.* + , PrimitiveArray == 0.7.1.* exposed-modules: - ADP.Fusion - ADP.Fusion.Apply - ADP.Fusion.Base - ADP.Fusion.Base.Classes - ADP.Fusion.Base.Multi - ADP.Fusion.Base.Point - ADP.Fusion.Base.Set - ADP.Fusion.Base.Subword - ADP.Fusion.Base.Term - ADP.Fusion.Base.TyLvlIx - ADP.Fusion.Base.Unit - ADP.Fusion.SynVar + -- multi imports + ADP.Fusion.Core + ADP.Fusion.Point + ADP.Fusion.Unit + -- core system + ADP.Fusion.Core.Apply + ADP.Fusion.Core.Classes + ADP.Fusion.Core.Multi + ADP.Fusion.Core.TH + ADP.Fusion.Core.TH.Backtrack + ADP.Fusion.Core.TH.Common + ADP.Fusion.Core.TyLvlIx ADP.Fusion.SynVar.Array - ADP.Fusion.SynVar.Array.TermSymbol ADP.Fusion.SynVar.Array.Type ADP.Fusion.SynVar.Axiom ADP.Fusion.SynVar.Backtrack ADP.Fusion.SynVar.Fill - ADP.Fusion.SynVar.Indices ADP.Fusion.SynVar.Indices.Classes - ADP.Fusion.SynVar.Indices.Point - ADP.Fusion.SynVar.Indices.Set0 - ADP.Fusion.SynVar.Indices.Subword - ADP.Fusion.SynVar.Indices.Unit - ADP.Fusion.SynVar.Recursive - ADP.Fusion.SynVar.Recursive.Point - ADP.Fusion.SynVar.Recursive.Subword ADP.Fusion.SynVar.Recursive.Type - ADP.Fusion.SynVar.Split - ADP.Fusion.SynVar.Split.Subword ADP.Fusion.SynVar.Split.Type - ADP.Fusion.Term - ADP.Fusion.Term.Chr - ADP.Fusion.Term.Chr.Point - ADP.Fusion.Term.Chr.Set0 - ADP.Fusion.Term.Chr.Subword + ADP.Fusion.SynVar.TableWrap ADP.Fusion.Term.Chr.Type - ADP.Fusion.Term.Deletion - ADP.Fusion.Term.Deletion.Point - ADP.Fusion.Term.Deletion.Subword ADP.Fusion.Term.Deletion.Type - ADP.Fusion.Term.Deletion.Unit - ADP.Fusion.Term.Edge - ADP.Fusion.Term.Edge.Set ADP.Fusion.Term.Edge.Type - ADP.Fusion.Term.Epsilon - ADP.Fusion.Term.Epsilon.Point - ADP.Fusion.Term.Epsilon.Set - ADP.Fusion.Term.Epsilon.Subword ADP.Fusion.Term.Epsilon.Type - ADP.Fusion.Term.Epsilon.Unit - ADP.Fusion.Term.PeekIndex - ADP.Fusion.Term.PeekIndex.Subword ADP.Fusion.Term.PeekIndex.Type - ADP.Fusion.Term.Strng - ADP.Fusion.Term.Strng.Point - ADP.Fusion.Term.Strng.Subword ADP.Fusion.Term.Strng.Type - ADP.Fusion.TH - ADP.Fusion.TH.Backtrack - ADP.Fusion.TH.Common + -- Point + ADP.Fusion.Core.Point + ADP.Fusion.SynVar.Indices.Point + ADP.Fusion.SynVar.Recursive.Point + ADP.Fusion.Term.Chr.Point + ADP.Fusion.Term.Deletion.Point + ADP.Fusion.Term.Epsilon.Point + ADP.Fusion.Term.Strng.Point + -- Unit + ADP.Fusion.Core.Unit + ADP.Fusion.SynVar.Indices.Unit + ADP.Fusion.Term.Deletion.Unit + ADP.Fusion.Term.Epsilon.Unit + -- tutorials + ADP.Fusion.Tutorial.NeedlemanWunsch default-extensions: BangPatterns , ConstraintKinds @@ -174,101 +167,55 @@ --- Very simple two-sequence alignment. - -executable NeedlemanWunsch - - if flag(examples) - buildable: - True - build-depends: base - , ADPfusion - , PrimitiveArray - , template-haskell - , vector - else - buildable: - False - hs-source-dirs: - src +test-suite properties + type: + exitcode-stdio-1.0 main-is: - NeedlemanWunsch.hs - default-language: - Haskell2010 - default-extensions: BangPatterns - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , RecordWildCards - , TemplateHaskell - , TypeFamilies - , TypeOperators + properties.hs + other-modules: + QuickCheck.Common + QuickCheck.Point ghc-options: - -O2 - -funbox-strict-fields - -funfolding-use-threshold1000 - -funfolding-keeness-factor1000 - if flag(debug) - ghc-options: - -ddump-to-file - -ddump-simpl - -dsuppress-all - - - --- Basic RNA secondary structure folding - -executable Nussinov - - if flag(examples) - buildable: - True - build-depends: base - , ADPfusion - , PrimitiveArray - , template-haskell - , vector - else - buildable: - False + -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: - src - main-is: - Nussinov.hs + tests default-language: Haskell2010 default-extensions: BangPatterns + , CPP , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses - , RecordWildCards + , ScopedTypeVariables , TemplateHaskell , TypeFamilies , TypeOperators - , UndecidableInstances - ghc-options: - -O2 - -funbox-strict-fields - -funfolding-use-threshold1000 - -funfolding-keeness-factor1000 - if flag(debug) - ghc-options: - -ddump-to-file - -ddump-simpl - -dsuppress-all + , TypeSynonymInstances + cpp-options: + -DADPFUSION_TEST_SUITE_PROPERTIES + build-depends: base + , ADPfusion + , bits + , OrderedBits + , PrimitiveArray + , QuickCheck + , strict + , test-framework >= 0.8 && < 0.9 + , test-framework-quickcheck2 >= 0.3 && < 0.4 + , test-framework-th >= 0.2 && < 0.3 + , vector --- Basic RNA secondary structure folding with partition function calculations +-- Very simple two-sequence alignment. -executable PartNussinov +executable NeedlemanWunsch if flag(examples) buildable: True build-depends: base , ADPfusion - , log-domain == 0.10.* , PrimitiveArray , template-haskell , vector @@ -278,7 +225,7 @@ hs-source-dirs: src main-is: - PartNussinov.hs + NeedlemanWunsch.hs default-language: Haskell2010 default-extensions: BangPatterns @@ -302,127 +249,11 @@ -executable Durbin - if flag(examples) - buildable: - True - build-depends: base - , ADPfusion - , PrimitiveArray - , template-haskell - , vector - else - buildable: - False - hs-source-dirs: - src - main-is: - Durbin.hs - default-language: - Haskell2010 - default-extensions: BangPatterns - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , RecordWildCards - , TemplateHaskell - , TypeFamilies - , TypeOperators - ghc-options: - -O2 - -fcpr-off - -funbox-strict-fields - -funfolding-use-threshold1000 - -funfolding-keeness-factor1000 - if flag(debug) - ghc-options: - -ddump-to-file - -ddump-simpl - -dsuppress-all - - - -executable Pseudoknot - if flag(examples) - buildable: - True - build-depends: base - , ADPfusion - , PrimitiveArray - , template-haskell - , vector - else - buildable: - False - hs-source-dirs: - src - main-is: - Pseudoknot.hs - default-language: - Haskell2010 - default-extensions: BangPatterns - , DataKinds - , 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 - - - -executable OverlappingPalindromes - if flag(examples) - buildable: - True - build-depends: base - , ADPfusion - , PrimitiveArray - , template-haskell - , vector - else - buildable: - False - hs-source-dirs: - src - main-is: - OverlappingPalindromes.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 - +-- Very simple two-sequence alignment. +executable spectest -executable SplitTests - if flag(examples) + if flag(spectest) buildable: True build-depends: base @@ -436,7 +267,7 @@ hs-source-dirs: src main-is: - SplitTests.hs + SpecTest.hs default-language: Haskell2010 default-extensions: BangPatterns @@ -460,102 +291,25 @@ -test-suite properties +benchmark TestBacktrackingStructures type: exitcode-stdio-1.0 - main-is: - properties.hs - other-modules: - QuickCheck.Common - QuickCheck.Point - QuickCheck.Set - QuickCheck.Subword - ghc-options: - -threaded -rtsopts -with-rtsopts=-N - hs-source-dirs: - tests - default-language: - Haskell2010 - default-extensions: BangPatterns - , CPP - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , TemplateHaskell - , TypeFamilies - , TypeOperators - , TypeSynonymInstances - cpp-options: - -DADPFUSION_TEST_SUITE_PROPERTIES - build-depends: base - , ADPfusion - , bits - , OrderedBits - , PrimitiveArray - , QuickCheck - , strict - , test-framework >= 0.8 && < 0.9 - , test-framework-quickcheck2 >= 0.3 && < 0.4 - , test-framework-th >= 0.2 && < 0.3 - , vector - - -benchmark performance - type: - exitcode-stdio-1.0 - main-is: - performance.hs - ghc-options: - -rtsopts -with-rtsopts=-N -with-rtsopts=-T - -O2 - -funbox-strict-fields - -funfolding-use-threshold1000 - -funfolding-keeness-factor1000 - if flag(debug) - ghc-options: - -ddump-to-file - -ddump-simpl - -dsuppress-all - hs-source-dirs: - tests - default-language: - Haskell2010 - default-extensions: BangPatterns - , FlexibleContexts - , TemplateHaskell - , RecordWildCards - , TypeFamilies - , TypeOperators - , StandaloneDeriving - , DeriveGeneric - build-depends: base - , ADPfusion - , BenchmarkHistory >= 0.0.0 && < 0.0.1 - , PrimitiveArray - , vector - - - --- Very simple two-sequence alignment. - -executable spectest - - if flag(spectest) + if flag(btstruc) buildable: True - build-depends: base - , ADPfusion - , PrimitiveArray - , template-haskell - , vector + build-depends: base + , template-haskell + , fmlist >= 0.9 && < 0.10 + , vector + , criterion >= 1.1 && < 1.2 else buildable: False hs-source-dirs: - src + tests main-is: - SpecTest.hs + BacktrackingStructures.hs default-language: Haskell2010 default-extensions: BangPatterns @@ -568,14 +322,8 @@ , 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,14 @@ +0.5.2.0 +------- + +- table filling fully inlined in the forward algorithm +- experimental PrimBool operations +- note: these optimizations are mostly of interest for linear languages, where + is rule (or function call) is comparatively expensive +- major re-arrangement of modules: import ADP.Fusion.Core for development of + novel DP systems. Import ADP.Fusion.Point if you want to write a sequence + alignment algorithm + 0.5.1.0 ------- diff --git a/src/Durbin.hs b/src/Durbin.hs deleted file mode 100644 --- a/src/Durbin.hs +++ /dev/null @@ -1,136 +0,0 @@ - --- | Nussinovs RNA secondary structure prediction algorithm via basepair --- maximization. Follow this file from top to bottom for a short tutorial --- on how to use @ADPfusion@. --- --- In general the task is the following: We are given a sequence of --- characters from the alphabet @ACGU@. There are 6 pairing rules (cf. --- 'pairs'), @A-U@, @C-G@, @G-C@, @G-U@, @U-A@, and @U-G@ can /pair/ with --- each other. Pairs, denoted by brackets @(@, @)@ may be juxtaposed --- @().()@ or enclosing @(())@. /Crossing/ pairs are not allowed: @([)]@ is --- forbidden, with @()@ and @[]@ pairing. Dots @.@ denote unpaired --- characters. --- --- As an example, the sequence @CACAAGGAUU@ admits the following --- dot-bracket string @(.)..((..))@. --- --- The algorithm below maximizes the number of legal brackets. - -module Main where - -import Control.Applicative -import Control.Monad -import Control.Monad.ST -import Data.Char (toUpper,toLower) -import Data.List -import Data.Vector.Fusion.Util -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ---import qualified Data.Vector.Fusion.Stream as S -import qualified Data.Vector.Fusion.Stream.Monadic as SM -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. - -import Data.PrimitiveArray as PA - --- High-level ADPfusion stuff. - -import ADP.Fusion - - - --- | All grammars require a signature. - -data Durbin m c e x r = Durbin - { nil :: e -> x - , lef :: c -> x -> x - , rig :: x -> c -> x - , pai :: c -> x -> c -> x - , spl :: x -> x -> x - , h :: SM.Stream m x -> m r - } - -makeAlgebraProduct ''Durbin - -bpmax :: Monad m => Durbin m Char () Int Int -bpmax = Durbin - { nil = \ () -> 0 - , lef = \ _ x -> x - , rig = \ x _ -> x - , 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 - } -{-# INLINE bpmax #-} - -pairs !c !d - = c=='A' && d=='U' - || c=='C' && d=='G' - || c=='G' && d=='C' - || c=='G' && d=='U' - || c=='U' && d=='A' - || 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 = \ () -> "" - , lef = \ _ x -> "." ++ x - , rig = \ x _ -> x ++ "." - , pai = \ _ x _ -> "(" ++ x ++ ")" - , spl = \ x y -> x ++ y - , h = SM.toList - } -{-# INLINE pretty #-} - --- grammar :: Durbin m Char () x r -> c' -> t' -> (t', Subword -> m r) -grammar Durbin{..} c t' = - let t = t' ( nil <<< Epsilon ||| - lef <<< c % t ||| - rig <<< t % c ||| - pai <<< c % t % c ||| - spl <<< tt % tt ... h - ) - tt = toNonEmpty t - {-# Inline tt #-} - 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 - n = VU.length i - !(Z:.t) = mutateTablesDefault - $ grammar bpmax - (chr i) - (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:.Backtrack (ITbl Id Unboxed EmptyOk (Subword I) Int) Id Id String -{-# NoInline runDurbin #-} - -main = do - as <- getArgs - let k = if null as then 1 else read $ head as - ls <- lines <$> getContents - forM_ ls $ \l -> do - putStrLn l - let (s,xs) = runDurbin k l - mapM_ (\x -> printf "%s %5d\n" x s) xs - diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs --- a/src/NeedlemanWunsch.hs +++ b/src/NeedlemanWunsch.hs @@ -2,8 +2,67 @@ -- | The Needleman-Wunsch global alignment algorithm. This algorithm is -- extremely simple but provides a good showcase for what ADPfusion offers. -- --- Follow the code from top to bottom for a tutorial on usage. +-- The Needleman-Wunsch algorithm aligns to strings @x = x_1 x_2 x_3 ...@ +-- and @y = y_1 y_2 y_3 ...@ which may be of differing lengths. Assume that +-- @x_1 ... x_{i-1}@ and @y_1 ... y_{j-1}@ have already been optimally +-- aligned. We can match @x_i@ with @y_j@, or perform one of two possible +-- insert-deletion pairs. Either @x_i@ is aligned with @-@ or @-@ is +-- aligned with @y_j@. More general, in each DP step, either one or both +-- inputs are extended by one character. -- +-- For the actual implementation, we assume however, that we work backward. +-- The entries @d@, @u@, and @l@ have already been calculated. Now we want +-- to compute the entry at @x@ in the lower right corner. +-- +-- @ +-- ----- +-- |d|u| +-- ----- +-- |l|x| +-- ----- +-- @ +-- +-- We introduce a generic naming scheme for each possible move. If we move +-- in a direction, we call it a @step@. If we do not move, then we call it +-- a @loop@, because the index loops for this computation. +-- +-- We can arrive from @d@, making a diagonal step, called @step_step@ as we +-- advance by one in both dimensions. This leads to an alignment of two +-- characters, one from each input, at @x@, which is combined with the +-- already calculated alignment at @d@. +-- +-- We can also just step in the first dimension @step_loop@, going from @l@ +-- to @x@. Which means that the first-dim character does not have +-- a partner, leading to an insert/deletion or in/del. We typically do not +-- care in which of the two dimensions the in/del happens, just that it +-- does. +-- +-- The third case is an in/del in the other dimension, giving us +-- @loop_step@ or going from @u@ to @x@. +-- +-- Of course, if @x@ happens to be the uppermost, leftmost cell, we have +-- nowhere to come from, so we need to inititialize (or terminate depending +-- on your view point) using the @nil_nil@ case. That one is the base case. +-- +-- We also want to know which of the three cases is the best case (coming +-- from @d,l,u@), this requires a "choice" function or @h@. +-- +-- +-- We now implement this algorithm using the low-level ADPfusion library. +-- Follow the code from top to bottom for a tutorial on usage. The +-- Needleman-Wunsch tutorial for the @FormalGrammars@ library provides +-- a higher-level style of implementation. +-- +-- +-- +-- We also provide an implementation based on grammar products, which +-- simplify the design of alignment-type algorithms. The corresponding +-- tutorial is here. +-- +-- +-- +-- +-- -- We start by importing a bunch of modules, including -- @Data.PrimitiveArray@ for low-level arrays and automated filling of the -- arrays or tables in the correct order. @@ -21,19 +80,19 @@ module 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 Control.Monad (forM_) import System.Environment (getArgs) -import System.IO.Unsafe (unsafePerformIO) import Text.Printf +-- Streams of parses are the streams defined in the @vector@ package. + +import qualified Data.Vector.Fusion.Stream.Monadic as SM + +-- We use unboxed vectors to hold the input sequences to be aligned. The +-- terminal parses work with any vector in the @vector@ package. + +import qualified Data.Vector.Unboxed as VU + -- @Data.PrimitiveArray@ contains data structures, and index structures for -- dynamic programming. Notably, the primitive arrays holding the cell data -- with Boxed and Unboxed tables. In addition, linear, context-free, and @@ -41,10 +100,13 @@ import Data.PrimitiveArray as PA hiding (map) --- @ADP.Fusion@ exposes everything necessary for higher-level DP --- algorithms. +-- @ADP.Fusion.Point@ exposes everything necessary for higher-level DP +-- algorithms. Depending on the type of DP algorithm, different top-level +-- modules can be imported. @.Point@ for linear grammars, and @.Core@ are +-- provided in this package. @.Core@ exports only the core modules required +-- to extend ADPfusion. -import ADP.Fusion +import ADP.Fusion.Point @@ -54,37 +116,6 @@ -- also evaluate each parse and choose the optimal one based on Bellman's -- principle of optimality. -- --- Assume we are in the matrix and want to calculate @x@: --- --- @ --- ----- --- |d|u| --- ----- --- |l|x| --- ----- --- @ --- --- We can arrive from @d@, making a diagonal step, called @step_step@ as we --- advance by one in both dimensions. This leads to an alignment of two --- characters, one from each input, at @x@, which is combined with the --- already calculated alignment at @d@. --- --- We can also just step in the first dimension @step_loop@, going from @l@ --- to @x@. Which means that the first-dim character does not have --- a partner, leading to an insert/deletion or in/del. We typically do not --- care in which of the two dimensions the in/del happens, just that it --- does. --- --- The third case is an in/del in the other dimension, giving us --- @loop_step@ or going from @u@ to @x@. --- --- Of course, if @x@ happens to be the uppermost, leftmost cell, we have --- nowhere to come from, so we need to inititialize (or terminate depending --- on your view point) using the @nil_nil@ case. That one is the base case. --- --- We also want to know which of the three cases is the best case (coming --- from @d,l,u@), this requires a "choice" function or @h@. --- -- We take a close look at the type signatures. @step_step :: x -> -- (Z:.c:.c) -> x@ tells us that @step_step@ requires the score from the -- non-terminal, typed @x@ for the alignment up to @d@, then we get the two @@ -161,12 +192,12 @@ -- indices. Just as in the spiritual father of @ADPfusion@, Robert -- Giegerichs @ADP@, we hide the actual index calculations. -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) ||| - nil_nil <<< (M:|Epsilon:|Epsilon) ... h - ) +grammar Signature{..} !a' !i1 !i2 = + let a = TW a' ( step_step <<< a % (M:|chr i1:|chr i2) ||| + step_loop <<< a % (M:|chr i1:|Deletion ) ||| + loop_step <<< a % (M:|Deletion :|chr i2) ||| + nil_nil <<< (M:|Epsilon:|Epsilon) ... h + ) in Z:.a {-# INLINE grammar #-} @@ -240,7 +271,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:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int +nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl 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,9 +280,10 @@ n2 = VU.length i2 {-# NoInline nwInsideForward #-} -nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int -> [[String]] +nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> TwITbl 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 + :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int Id Id [String] {-# NoInline nwInsideBacktrack #-} -- | The outside version of the Needleman-Wunsch alignment algorithm. The @@ -260,21 +292,21 @@ -- and the grammar from above. runOutsideNeedlemanWunsch :: Int -> String -> String -> (Int,[[String]]) -runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where -- . S.toList . unId $ axiom b) where -- ,gogo) where +runOutsideNeedlemanWunsch k i1' i2' = {-# SCC "runOutside" #-} (d, take k . unId $ axiom b) where i1 = VU.fromList i1' i2 = VU.fromList i2' n1 = VU.length i1 n2 = VU.length i2 !(Z:.t) = nwOutsideForward i1 i2 - -- d = let (ITbl _ _ arr _) = t in arr PA.! (O (Z:.PointL 0:.PointL 0)) - d = iTblArray t PA.! (Z:.PointL 0:.PointL 0) + d = unId $ axiom t !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2 + :: Z:.TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int Id Id [String] {-# Noinline runOutsideNeedlemanWunsch #-} -- | Again, to be able to observe performance, we have extracted the -- outside-table-filling part. -nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int +nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl 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) [])) diff --git a/src/Nussinov.hs b/src/Nussinov.hs deleted file mode 100644 --- a/src/Nussinov.hs +++ /dev/null @@ -1,132 +0,0 @@ - --- | Nussinovs RNA secondary structure prediction algorithm via basepair --- maximization. - -module Main where - -import Control.Applicative -import Control.Monad -import Control.Monad.ST -import Data.Char (toUpper,toLower) -import Data.List as L -import Data.Vector.Fusion.Util -import Debug.Trace -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ---import qualified Data.Vector.Fusion.Stream as S -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Unboxed as VU -import System.Environment (getArgs) -import Text.Printf - -import Data.PrimitiveArray as PA - -import ADP.Fusion - - - -data Nussinov m x r c = Nussinov - { unp :: x -> c -> x - , jux :: x -> c -> x -> c -> x - , nil :: () -> x - , h :: SM.Stream m x -> m r - } - -makeAlgebraProduct ''Nussinov - -{- - - due to backtracking schemes, we need a bunch of combintors - - - - how to deal with sup-optimal backtracking, without having to use (*||) ? - -(<||) :: Single a -> List b -> List b -- co-optimal backtracking -(*||) :: Vector a -> List b -> List (a,b) -- classified co-optimal backtracking -(***) :: Single a -> Single b -> Vector (a,b) -- classified DP - --} - -bpmax :: Monad m => Nussinov m Int Int Char -bpmax = Nussinov - { unp = \ x c -> x - , jux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999 - , nil = \ () -> 0 - , h = SM.foldl' max (-999999) - } -{-# INLINE bpmax #-} - -prob :: Monad m => Nussinov m Double Double Char -prob = Nussinov - { unp = \ x c -> 0.3 * x - , jux = \ x c y d -> 0.6 * if c `pairs` d then x * y else 0 - , nil = \ () -> 0.1 - , h = SM.foldl' (+) 0 - } - --- | - -pairs !c !d - = c=='A' && d=='U' - || c=='C' && d=='G' - || c=='G' && d=='C' - || c=='G' && d=='U' - || c=='U' && d=='A' - || c=='U' && d=='G' -{-# INLINE pairs #-} - -pretty :: Monad m => Nussinov m String [String] Char -- (SM.Stream m String) -pretty = Nussinov - { unp = \ x c -> x ++ "." - , jux = \ x c y d -> x ++ "(" ++ y ++ ")" - , nil = \ () -> "" - , h = SM.toList -- return . id - } -{-# INLINE pretty #-} - -prettyL :: Monad m => Nussinov m String String Char -prettyL = Nussinov - { unp = \ x c -> x ++ "." - , jux = \ x c y d -> x ++ "(" ++ y ++ ")" - , nil = \ () -> "" - , h = SM.head -- return . id - } -{-# INLINE prettyL #-} - -grammar Nussinov{..} c t' = - let t = t' ( unp <<< t % c ||| - jux <<< t % c % t % c ||| - nil <<< Epsilon ... h - ) - in Z:.t -{-# INLINE grammar #-} - -runNussinov :: Int -> String -> (Int,[String]) -runNussinov k inp = (d, take k bs) where - i = VU.fromList . Prelude.map toUpper $ inp - n = VU.length i - !(Z:.t) = runInsideForward i - d = unId $ axiom t - bs = runInsideBacktrack i t -{-# NOINLINE runNussinov #-} - -runInsideForward :: VU.Vector Char -> Z:.ITbl Id Unboxed EmptyOk (Subword I) Int -runInsideForward i = mutateTablesDefault - $ grammar bpmax - (chr i) - (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) - where n = VU.length i -{-# NoInline runInsideForward #-} - -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 #-} - -main = do - as <- getArgs - let k = if null as then 1 else read $ head as - ls <- lines <$> getContents - forM_ ls $ \l -> do - putStrLn l - let (s,xs) = runNussinov k l - mapM_ (\x -> printf "%s %5d\n" x s) xs - diff --git a/src/OverlappingPalindromes.hs b/src/OverlappingPalindromes.hs deleted file mode 100644 --- a/src/OverlappingPalindromes.hs +++ /dev/null @@ -1,155 +0,0 @@ - -{-# Language DataKinds #-} -{-# Language KindSignatures #-} -{-# Language ScopedTypeVariables #-} -{-# Language DataKinds #-} -{-# Language DefaultSignatures #-} -{-# Language FlexibleContexts #-} -{-# Language FlexibleInstances #-} -{-# Language GADTs #-} -{-# Language KindSignatures #-} -{-# Language MultiParamTypeClasses #-} -{-# Language RankNTypes #-} -{-# Language StandaloneDeriving #-} -{-# Language TemplateHaskell #-} -{-# Language TypeFamilies #-} -{-# Language TypeOperators #-} -{-# Language TypeSynonymInstances #-} -{-# Language UndecidableInstances #-} - -module 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 - { ovrlap :: () -> () -> x -> x -> () -> x -- TODO !!! - , brckts :: (Z:.c:.()) -> x -> (Z:.():.c) -> x - , braces :: (Z:.c:.()) -> x -> (Z:.():.c) -> x - , nilnil :: (Z:.():.()) -> x - , h :: Stream m x -> m r - } - -makeAlgebraProduct ''Signature - - - --- | --- --- @ --- 012345678 --- [[((]])) --- @ - -grammar Signature{..} x' a' b' i = - let x = x' ( ovrlap <<< (split (Proxy :: Proxy "a") (Proxy :: Proxy Fragment) a) - % (split (Proxy :: Proxy "b") (Proxy :: Proxy Fragment) b) - % (split (Proxy :: Proxy "a") (Proxy :: Proxy Final ) a) - % (split (Proxy :: Proxy "b") (Proxy :: Proxy Final ) b) -- ... h - % (split (Proxy :: Proxy "c") (Proxy :: Proxy Fragment) b) ... h - ) - a = a' ( nilnil <<< (M:|Epsilon:|Epsilon) ||| - brckts <<< (M:|chr i:|Deletion) % a % (M:|Deletion:|chr i) ... h - ) - b = b' ( nilnil <<< (M:|Epsilon:|Epsilon) ||| - braces <<< (M:|chr i:|Deletion) % b % (M:|Deletion:|chr i) ... h - ) - in Z:.x:.a:.b -{-# Inline grammar #-} - - - -score :: Monad m => Signature m Int Int Char -score = Signature - { ovrlap = \ a' b' a b _ -> {- if a>0 || b>0 then traceShow ("oo",a',b',a,b) $ a + b else -} a+b -- TODO !!! - , brckts = \ (Z:.l:.()) a (Z:.():.r) -> {- traceShow ("[]",l,a,r) $ -} if l=='[' && r==']' then a+1 else -999999 - , braces = \ (Z:.l:.()) b (Z:.():.r) -> {- traceShow ("()",l,b,r) $ -} if l=='(' && r==')' then b+1 else -999999 - , nilnil = \ _ -> 0 - , h = SM.foldl' max (-999999) - } -{-# Inline score #-} - - - --- | --- --- TODO pretty shows in @ovrlap@ that we might want to introduce a second --- @h@ together with @Stream m y -> m s@? - -pretty :: Monad m => Signature m [String] [[String]] Char -pretty = Signature - { ovrlap = \ () () [a,a'] [b,b'] () -> [a ++ b ++ a' ++ b'] -- TODO !!! - , brckts = \ (Z:.l:.()) [a,a'] (Z:.():.r) -> ["a"++a , a'++"A"] - , braces = \ (Z:.l:.()) [b,b'] (Z:.():.r) -> ["b"++b , b'++"B"] - , nilnil = \ _ -> ["",""] - , h = SM.toList - } -{-# Inline pretty #-} - - - -overlappingPalindromes :: String -> (Int,[[String]]) -overlappingPalindromes inp = (d,bs) where - i = VU.fromList inp - n = VU.length i - d = unId $ axiom x - bs = unId $ axiom x' - x :: X - a :: T - b :: T - (Z:.x:.a:.b) = opForward i - {- - (Z:.x:.a:.b) = mutateTablesDefault $ - grammar score - (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) - (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) [])) - (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) [])) - i - -} - (Z:.x':.a':.b') = grammar (score <|| pretty) - (toBacktrack x (undefined :: Id a -> Id a)) - (toBacktrack a (undefined :: Id a -> Id a)) - (toBacktrack b (undefined :: Id a -> Id a)) - i -{-# NoInline overlappingPalindromes #-} - -opForward :: VU.Vector Char -> Z:.X:.T:.T -opForward i = - let n = VU.length i - in mutateTablesDefault $ - grammar score - (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) - (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) [])) - (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) [])) - i -{-# NoInline opForward #-} - -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 () -main = do - xs <- fmap lines $ getContents - forM_ xs $ \x -> do - let (d,bs) = overlappingPalindromes x - putStrLn x - print d --- putStrLn $ head $ head bs - diff --git a/src/PartNussinov.hs b/src/PartNussinov.hs deleted file mode 100644 --- a/src/PartNussinov.hs +++ /dev/null @@ -1,274 +0,0 @@ - --- | Nussinovs RNA secondary structure prediction algorithm via basepair --- maximization. - -module Main where - -import Control.Applicative -import Control.Monad -import Control.Monad.ST -import Data.Char (toUpper,toLower) -import Data.List -import Data.Vector.Fusion.Util -import Debug.Trace -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Numeric.Log as Log -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Unboxed as VU -import System.Environment (getArgs) -import Text.Printf - -import Data.PrimitiveArray as PA - -import ADP.Fusion - - - --- * Inside and Outside grammar constructs - -data Nussinov m c e x r = Nussinov - { unp :: x -> c -> x - , jux :: x -> x -> x - , pai :: c -> x -> c -> x - , nil :: e -> x - , h :: SM.Stream m x -> m r - } - -makeAlgebraProduct ''Nussinov - -bpmax :: Monad m => Nussinov m Char () Int Int -bpmax = Nussinov - { unp = \ x c -> x - , jux = \ x y -> x + y - , pai = \ c x d -> if c `pairs` d then x+1 else (-999999) - , nil = \ () -> 0 - , h = SM.foldl' max (-999999) - } -{-# INLINE bpmax #-} - -prob :: Monad m => Nussinov m Char () (Log Double) (Log Double) -prob = Nussinov - { unp = \ x c -> 0.1 * x -- 'any' - , jux = \ x y -> 0.9 * x * y -- 'any' - , pai = \ c x d -> 1.0 * if c `pairs` d then x else 0 -- 'paired' - , nil = \ () -> 1.0 -- 'any' - , h = SM.foldl' (+) 0 - } -{-# Inline prob #-} - --- | - -pairs !c !d - = c=='A' && d=='U' - || c=='C' && d=='G' - || c=='G' && d=='C' - || c=='G' && d=='U' - || c=='U' && d=='A' - || c=='U' && d=='G' -{-# INLINE pairs #-} - -pretty :: Monad m => Nussinov m Char () String (SM.Stream m String) -pretty = Nussinov - { unp = \ x c -> x ++ "." - , jux = \ x y -> x ++ y - , pai = \ c x d -> "(" ++ x ++ ")" - , nil = \ () -> "" - , h = return . id - } -{-# INLINE pretty #-} - --- | The inside grammar is: --- --- @ --- A -> A c --- A -> A P --- A -> ε --- P -> c A c --- @ - --- insideGrammar :: Nussinov m Char () x r -> c' -> t' -> (t', Subword -> m r) -insideGrammar Nussinov{..} c a' p' = - let a = a' ( unp <<< a % c ||| - jux <<< a % p ||| - nil <<< Epsilon ... h - ) - p = p' ( pai <<< c % a % c ... h - ) - in Z:.p:.a -{-# INLINE insideGrammar #-} - --- | Given the inside grammar, the outside grammar is: --- --- @ --- B -> B c --- B -> B P --- B -> ε --- B -> c Q c --- Q -> A B --- @ - -outsideGrammar Nussinov{..} c a p b' q' = - let b = b' ( unp <<< b % c ||| - jux <<< b % p ||| - pai <<< c % q % c ||| - nil <<< Epsilon ... h - ) - q = q' ( jux <<< a % b ... h - ) - in Z:.b:.q -{-# INLINE outsideGrammar #-} - - - --- * Ensemble collection constructs - -data NussinovEnsemble m v ci x r = NussinovEnsemble - { ens :: v -> ci -> v -> x - , hhh :: SM.Stream m x -> m r - } - -ensemble - :: Monad m - => Log Double - -> NussinovEnsemble - m - (Log Double) - (Subword C) - (Subword C, Log Double) - [(Subword C, Log Double)] -ensemble z = NussinovEnsemble - { ens = \ x i y -> ( i , x * y / z ) - , hhh = SM.toList - } -{-# Inline ensemble #-} - -ensembleGrammar NussinovEnsemble{..} i o v' = - let v = v' ( ens <<< i % (PeekIndex :: PeekIndex (Subword C)) % o ... hhh ) - in Z:.v -{-# Inline ensembleGrammar #-} - --- makeAlgebraProductH ['hhh] ''NussinovEnsemble - - - --- * Run different algorithm parts - -runNussinov :: String -> ([(Subword C, Log Double)], Log Double, [(Int,Int, Log Double, Log Double, Log Double, Log Double)]) -runNussinov inp = (es,z,ys) where - i = VU.fromList . Prelude.map toUpper $ inp - n = VU.length i - !(Z:.p:.a) = runInsideForward i - !(Z:.b:.q) = runOutsideForward i a p - es = runEnsembleForward z p q - za = let (ITbl _ _ _ arr _) = a in arr PA.! subword 0 n - zp = let (ITbl _ _ _ arr _) = p in arr PA.! subword 0 n - z = za - e = let (ITbl _ _ _ arr _) = b in Log.sum [ arr PA.! (subword k k) | k <- [0 .. n] ] - ys = [ ( k - , l - , fwda PA.! subword k l - , fwdp PA.! subword k l - , bwdb PA.! subword k l - , bwdq PA.! subword k l - ) - | let (ITbl _ _ _ fwda _) = a - , let (ITbl _ _ _ fwdp _) = p - , let (ITbl _ _ _ bwdb _) = b - , let (ITbl _ _ _ bwdq _) = q - , k <- [0 .. n] - , l <- [k .. n] - ] -{-# NOINLINE runNussinov #-} - -neat :: String -> IO () -neat i = do let (es,z,ys) = runNussinov i - forM_ ys $ \ (k,_,_,_,_,_) -> printf " %6d" k - putStrLn "" - forM_ ys $ \ (_,l,_,_,_,_) -> printf " %6d" l - putStrLn "" - forM_ ys $ \ (_,_,a,_,_,_) -> printf " %0.4f" (exp $ ln a) - putStrLn "" - forM_ ys $ \ (_,_,_,p,_,_) -> printf " %0.4f" (exp $ ln p) - putStrLn "" - forM_ ys $ \ (_,_,_,_,b,_) -> printf " %0.4f" (exp $ ln b) - putStrLn "" - forM_ ys $ \ (_,_,_,_,_,q) -> printf " %0.4f" (exp $ ln q) - putStrLn "" - printf "%0.4f\n" $ exp $ ln z - forM_ ys $ \ (_,_,_,p,_,q) -> printf " %0.4f" ((exp $ ln p) * (exp $ ln q) / (exp $ ln z)) - putStrLn "" - putStrLn "" - forM_ es $ \ (Subword (i:.j),v) -> printf "%3d %3d %0.4f\n" i j (exp $ ln v) - putStrLn "" - -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 - $ insideGrammar prob - (chr i) - (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 [])) - (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 [])) - where n = VU.length i -{-# NoInline runInsideForward #-} - -runOutsideForward :: VU.Vector Char -> TblI -> TblI -> Z:.TblO:.TblO -runOutsideForward i a p = mutateTablesDefault - $ outsideGrammar prob - (chr i) - a p - (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 [])) - (ITbl 0 1 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 [])) - where n = VU.length i -{-# NoInline runOutsideForward #-} - -runEnsembleForward :: Log Double -> TblI -> TblO -> [ (Subword C,Log Double) ] -runEnsembleForward z i o = unId $ axiom g - where (Z:.g) = ensembleGrammar (ensemble z) - i o - (IRec EmptyOk (Subword l) (Subword h)) - :: Z :. IRec Id EmptyOk (Subword C) [(Subword C, Log Double)] - (Subword l,Subword h) = let (ITbl _ _ _ arr _) = i in bounds arr -{-# NoInline runEnsembleForward #-} - -{- -runPartitionNussinov :: String -> [(Subword,Double,Double,Double)] -runPartitionNussinov inp - = Data.List.map (\(sh,a) -> let b = iTblArray t PA.! (O sh) - in (sh, a, b, a*b/d) - ) (PA.assocs $ iTblArray s) - where - i = VU.fromList . Prelude.map toUpper $ inp - n = VU.length i - s :: ITbl Id Unboxed Subword Double - !(Z:.s) = mutateTablesDefault - $ grammar prob - (chr i) - (ITbl EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) 0 [])) - - d = iTblArray s PA.! subword 0 n - t :: ITbl Id Unboxed (Outside Subword) Double - !(Z:.t) = mutateTablesDefault - $ outsideGrammar prob - (chr i) - --(undefined :: ITbl Id Unboxed (Outside Subword) Double) - s - (ITbl EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-1) [])) -{-# NOINLINE runPartitionNussinov #-} --} - -main :: IO () -main = do - return () - {- - as <- getArgs - let k = if null as then 1 else read $ head as - ls <- lines <$> getContents - forM_ ls $ \l -> do - putStrLn l - let (s,xs) = runNussinov k l - mapM_ (\x -> printf "%s %5d\n" x s) xs - -} - diff --git a/src/Pseudoknot.hs b/src/Pseudoknot.hs deleted file mode 100644 --- a/src/Pseudoknot.hs +++ /dev/null @@ -1,149 +0,0 @@ - -module Main where - -import Control.Applicative -import Control.Monad -import Control.Monad.ST -import Data.Char (toUpper,toLower) -import Data.List as L -import Data.Vector.Fusion.Util -import Debug.Trace -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Unboxed as VU -import System.Environment (getArgs) -import Text.Printf - -import Data.PrimitiveArray as PA - -import ADP.Fusion - - - -data Nussinov m x r c = Nussinov - { unp :: x -> c -> x - , jux :: x -> c -> x -> c -> x - , pse :: () -> () -> x -> x -> x - , nil :: () -> x - , pk1 :: (Z:.x:.()) -> (Z:.c:.()) -> x -> (Z:.():.x) -> (Z:.():.c) -> x - , pk2 :: (Z:.x:.()) -> (Z:.c:.()) -> x -> (Z:.():.x) -> (Z:.():.c) -> x - , nll :: (Z:.():.()) -> x - , h :: SM.Stream m x -> m r - } - -makeAlgebraProduct ''Nussinov - - -bpmax :: Monad m => Nussinov m Int Int Char -bpmax = Nussinov - { unp = \ x c -> x - , jux = \ x c y d -> if c `pairs` d then x + y + 1 else -999999 - , pse = \ () () x y -> x + y - , nil = \ () -> 0 - , pk1 = \ (Z:.x:.()) (Z:.a:.()) y (Z:.():.z) (Z:.():.b) -> if a `pairs` b then x + y + z + 1 else -888888 - , pk2 = \ (Z:.x:.()) (Z:.a:.()) y (Z:.():.z) (Z:.():.b) -> if a `pairs` b then x + y + z + 1 else -888888 - , nll = \ (Z:.():.()) -> 0 - , h = SM.foldl' max (-999999) - } -{-# INLINE bpmax #-} - --- | - -pairs !c !d - = c=='A' && d=='U' - || c=='C' && d=='G' - || c=='G' && d=='C' - || c=='G' && d=='U' - || c=='U' && d=='A' - || c=='U' && d=='G' -{-# INLINE pairs #-} - --- | --- --- TODO It could be beneficial to introduce --- @type Splitted = Either String (String,String)@ --- or something isomorphic. While [String] works, it allows for too many --- possibilities here! ([] ist lightweight, on the other hand ...) - -pretty :: Monad m => Nussinov m [String] [[String]] Char -pretty = Nussinov - { unp = \ [x] c -> [x ++ "."] - , jux = \ [x] c [y] d -> [x ++ "(" ++ y ++ ")"] - , pse = \ () () [x1,x2] [y1,y2] -> [x1 ++ y1 ++ x2 ++ y2] - , nil = \ () -> [""] - , pk1 = \ (Z:.[x]:.()) (Z:.a:.()) [y1,y2] (Z:.():.[z]) (Z:.():.b) -> [x ++ "[" ++ y1 , y2 ++ z ++ "]"] - , pk2 = \ (Z:.[x]:.()) (Z:.a:.()) [y1,y2] (Z:.():.[z]) (Z:.():.b) -> [x ++ "{" ++ y1 , y2 ++ z ++ "}"] - , nll = \ (Z:.():.()) -> ["",""] - , h = SM.toList - } -{-# INLINE pretty #-} - --- | - -grammar Nussinov{..} t' u' v' c = - let t = t' ( unp <<< t % c ||| - jux <<< t % c % t % c ||| - nil <<< Epsilon ||| - pse <<< (split (Proxy :: Proxy "U") (Proxy :: Proxy Fragment) u) - % (split (Proxy :: Proxy "V") (Proxy :: Proxy Fragment) v) - % (split (Proxy :: Proxy "U") (Proxy :: Proxy Final) u) - % (split (Proxy :: Proxy "V") (Proxy :: Proxy Final) v) ... h - ) - u = u' ( pk1 <<< (M:|t:|Deletion) % (M:|c:|Deletion) % u % (M:|Deletion:|t) % (M:|Deletion:|c) ||| - nll <<< (M:|Epsilon:|Epsilon) ... h - ) - v = v' ( pk2 <<< (M:|t:|Deletion) % (M:|c:|Deletion) % v % (M:|Deletion:|t) % (M:|Deletion:|c) ||| - nll <<< (M:|Epsilon:|Epsilon) ... h - ) - in Z:.t:.u:.v -{-# INLINE grammar #-} - -runPseudoknot :: Int -> String -> (Int,[[String]]) -runPseudoknot k inp = (d, take k bs) where - i = VU.fromList . Prelude.map toUpper $ inp - n = VU.length i - !(Z:.t:.u:.v) = runInsideForward i - d = unId $ axiom t - bs = {- let ITbl _ _ _ x _ = v in traceShow (filter (flip elem gives . fst) $ assocs x) $ -} runInsideBacktrack i (Z:.t:.u:.v) - gives = [ Z:.subword 2 2 :. subword 3 3 - , Z:.subword 1 2 :. subword 3 5 - ] - {- - - u g a a c - - 0 1 2 3 4 5 - -} -{-# NOINLINE runPseudoknot #-} - -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) - $ grammar bpmax - (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-666999) [])) - (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-777999) [])) - (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-888999) [])) - (chr i) - where n = VU.length i -{-# NoInline runInsideForward #-} - -runInsideBacktrack :: VU.Vector Char -> Z:.X:.T:.T -> [[String]] -runInsideBacktrack i (Z:.t:.u:.v) = unId $ axiom b - where !(Z:.b:._:._) = grammar (bpmax <|| pretty) - (toBacktrack t (undefined :: Id a -> Id a)) - (toBacktrack u (undefined :: Id a -> Id a)) - (toBacktrack v (undefined :: Id a -> Id a)) - (chr i) -{-# NoInline runInsideBacktrack #-} - -main = do - as <- getArgs - let k = if null as then 1 else read $ head as - ls <- lines <$> getContents - forM_ ls $ \l -> do - putStrLn l - let (s,xs) = runPseudoknot k l - print s - mapM_ (\[x] -> printf "%s %5d\n" x s) xs - diff --git a/src/SpecTest.hs b/src/SpecTest.hs --- a/src/SpecTest.hs +++ b/src/SpecTest.hs @@ -18,7 +18,7 @@ import Data.PrimitiveArray as PA hiding (map) -import ADP.Fusion +import ADP.Fusion.Point diff --git a/src/SplitTests.hs b/src/SplitTests.hs deleted file mode 100644 --- a/src/SplitTests.hs +++ /dev/null @@ -1,135 +0,0 @@ - -{-# Language DataKinds #-} -{-# Language KindSignatures #-} -{-# Language ScopedTypeVariables #-} -{-# Language DataKinds #-} -{-# Language DefaultSignatures #-} -{-# Language FlexibleContexts #-} -{-# Language FlexibleInstances #-} -{-# Language GADTs #-} -{-# Language KindSignatures #-} -{-# Language MultiParamTypeClasses #-} -{-# Language RankNTypes #-} -{-# Language StandaloneDeriving #-} -{-# Language TemplateHaskell #-} -{-# Language TypeFamilies #-} -{-# Language TypeOperators #-} -{-# Language TypeSynonymInstances #-} -{-# Language UndecidableInstances #-} - -module 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 - { ovrlap :: () -> x -> x - , brckts :: (Z:.c:.()) -> x -> (Z:.():.c) -> x - , nilnil :: (Z:.():.()) -> x - , h :: Stream m x -> m r - } - -makeAlgebraProduct ''Signature - - - --- | --- --- @ --- 012345678 --- [[((]])) --- @ - -grammar Signature{..} x' a' i = - let x = x' ( ovrlap <<< (split (Proxy :: Proxy "a") (Proxy :: Proxy Fragment) a) - % (split (Proxy :: Proxy "a") (Proxy :: Proxy Final ) a) ... h - ) - a = a' ( nilnil <<< (M:|Epsilon:|Epsilon) ||| - brckts <<< (M:|chr i:|Deletion) % a % (M:|Deletion:|chr i) ... h - ) - in Z:.x:.a -{-# Inline grammar #-} - - - -score :: Monad m => Signature m Int Int Char -score = Signature - { ovrlap = \ a' a -> a + 4711 - , brckts = \ (Z:.l:.()) a (Z:.():.r) -> {- traceShow ("[]",l,a,r) $ -} if l=='[' && r==']' then a+1 else -999999 - , nilnil = \ _ -> 0 - , h = SM.foldl' max (-999999) - } -{-# Inline score #-} - - - --- | --- --- TODO pretty shows in @ovrlap@ that we might want to introduce a second --- @h@ together with @Stream m y -> m s@? - -pretty :: Monad m => Signature m [String] [[String]] Char -pretty = Signature - { ovrlap = \ () [a,a'] -> [a ++ a'] - , brckts = \ (Z:.l:.()) [a,a'] (Z:.():.r) -> ["a"++a , a'++"A"] - , nilnil = \ _ -> ["",""] - , h = SM.toList - } -{-# Inline pretty #-} - - - -overlappingPalindromes :: String -> (Int,[[String]]) -overlappingPalindromes inp = (d,bs) where - i = VU.fromList inp - n = VU.length i - d = unId $ axiom x - bs = unId $ axiom x' - x :: X - a :: T - (Z:.x:.a) = opForward i - (Z:.x':.a') = grammar (score <|| pretty) - (toBacktrack x (undefined :: Id a -> Id a)) - (toBacktrack a (undefined :: Id a -> Id a)) - i -{-# NoInline overlappingPalindromes #-} - -opForward :: VU.Vector Char -> Z:.X:.T -opForward i = - let n = VU.length i - in mutateTablesDefault $ - grammar score - (ITbl 1 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) - (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 n:.subword 0 n) (-999999) [])) - i -{-# NoInline opForward #-} - -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 () -main = do - xs <- fmap lines $ getContents - forM_ xs $ \x -> do - let (d,bs) = overlappingPalindromes x - putStrLn x - print d --- putStrLn $ head $ head bs - diff --git a/tests/BacktrackingStructures.hs b/tests/BacktrackingStructures.hs new file mode 100644 --- /dev/null +++ b/tests/BacktrackingStructures.hs @@ -0,0 +1,76 @@ + +{-# Language MagicHash #-} + +module Main where + +import Criterion.Main +import Data.Vector.Fusion.Stream.Monadic (Stream,foldl',mapM_) +import Data.Vector.Fusion.Util +import Data.Vector.Unboxed (Vector, fromList) +import GHC.Exts (inline, Int(..), (<=#) ) +import Prelude hiding (mapM_) +import System.IO.Unsafe +import qualified Data.FMList as F + + + +listLeft :: Int -> Int +listLeft k = sum $ go k [] + where go 0 xs = xs + go k xs = go (k-1) (k:xs) +{-# NoInline listLeft #-} + +listRight :: Int -> Int +listRight k = sum $ go k [] + where go 0 xs = xs + go k xs = go (k-1) (xs++[k]) +{-# NoInline listRight #-} + +listRightRev :: Int -> Int +listRightRev k = sum . reverse $ go k [] + where go 0 xs = xs + go k xs = go (k-1) (k:xs) +{-# NoInline listRightRev #-} + +listBoth :: Int -> Int +listBoth k = sum $ go (k `div` 2) [] + where go 0 xs = xs + go k xs = go (k-1) (k:xs++[k]) +{-# NoInline listBoth #-} + +fmLeft :: Int -> Int +fmLeft k = sum . F.toList $ go k F.empty + where go 0 xs = xs + go k xs = go (k-1) (k `F.cons` xs) +{-# NoInline fmLeft #-} + +fmRight :: Int -> Int +fmRight k = sum . F.toList $ go k F.empty + where go 0 xs = xs + go k xs = go (k-1) (xs `F.snoc` k) +{-# NoInline fmRight #-} + +-- | + +benchWithK s k = + bgroup s + [ bench "listLeft" $ whnf listLeft k + , bench "listRight" $ whnf listRight k + , bench "listRightRev" $ whnf listRight k + , bench "listBoth" $ whnf listBoth k + , bench "fmLeft" $ whnf fmLeft k + , bench "fmRight" $ whnf fmRight k + ] +{-# Inline benchWithK #-} + +-- | + +main :: IO () +main = do + defaultMain + [ benchWithK "10" 10 + , benchWithK "20" 20 + , benchWithK "100" 100 + , benchWithK "1000" 1000 + ] + diff --git a/tests/QuickCheck/Point.hs b/tests/QuickCheck/Point.hs --- a/tests/QuickCheck/Point.hs +++ b/tests/QuickCheck/Point.hs @@ -19,10 +19,9 @@ import Test.Framework.Providers.QuickCheck2 #endif - import Data.PrimitiveArray -import ADP.Fusion +import ADP.Fusion.Point @@ -36,7 +35,7 @@ zs = (id <<< Epsilon ... stoList) maxPLo ix ls = [ () | j == maxI ] -prop_ZEpsilon ix@(Z:.PointL j) = zs == ls where +prop_I_ZEpsilon ix@(Z:.PointL j) = zs == ls where zs = (id <<< (M:|Epsilon) ... stoList) (Z:.maxPLi) ix ls = [ Z:.() | j == 0 ] @@ -53,16 +52,14 @@ -- * Deletion cases 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 + zs = ((,,) <<< tSI % Deletion % chr xs ... stoList) maxPLi ix ls = [ ( unsafeIndex xsP (PointL $ j-1) , () , xs VU.! (j-1) ) | j >= 1, j <= (maxI) ] prop_O_ItNC ix@(PointL j) = zs == ls where - t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1) - zs = ((,,) <<< t % Deletion % chr xs ... stoList) maxPLo ix + zs = ((,,) <<< tSO % Deletion % chr xs ... stoList) maxPLo ix ls = [ ( unsafeIndex xsPo (PointL $ j+1) , () , xs VU.! (j+0) @@ -70,24 +67,21 @@ {-# Noinline prop_O_ItNC #-} prop_O_ZItNC ix@(Z:.PointL j) = zs == ls where - t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1) - zs = ((,,) <<< t % (M:|Deletion) % (M:|chr xs) ... stoList) (Z:.maxPLo) ix + zs = ((,,) <<< tZ1O % (M:|Deletion) % (M:|chr xs) ... stoList) (Z:.maxPLo) ix ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+1)) , Z:.() , Z:.xs VU.! (j+0) ) | j >= 0, j <= (maxI-1) ] prop_O_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where - t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1) - zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (Z:.maxPLo:.maxPLo) ix + zs = ((,,) <<< tZ2O % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (Z:.maxPLo:.maxPLo) ix ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+1):.PointL (l+1)) , Z:.() :.xs VU.! (l+0) , Z:.xs VU.! (j+0):.() ) | j>=0, l>=0, j<=(maxI-1), l<=(maxI-1) ] prop_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 + zs = ((,,) <<< tZ2I % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... stoList) (Z:.maxPLi:.maxPLi) ix ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1)) , Z:.() :.xs VU.! (l-1) , Z:.xs VU.! (j-1):.() @@ -113,33 +107,35 @@ zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... stoList) (Z:.maxPLi) ix ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ] +tSI = TW (ITbl 0 0 EmptyOk xsP) (\ (_ :: PointL I) (_ :: PointL I) -> Id (1::Int)) +tSO = TW (ITbl 0 0 EmptyOk xsPo) (\ (_ :: PointL O) (_ :: PointL O) -> Id (1::Int)) +tZ1I = TW (ITbl 0 0 (Z:.EmptyOk) xsZP) (\ (_::Z:.PointL I) (_::Z:.PointL I) -> Id (1::Int)) +tZ1O = TW (ITbl 0 0 (Z:.EmptyOk) xsZPo) (\ (_::Z:.PointL O) (_::Z:.PointL O) -> Id (1::Int)) +tZ2I = TW (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP) (\ (_::Z:.PointL I:.PointL I) (_::Z:.PointL I:.PointL I) -> Id (1::Int)) +tZ2O = TW (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo) (\ (_::Z:.PointL O:.PointL O) (_::Z:.PointL O:.PointL O) -> Id (1::Int)) + -- | Just a table prop_I_It ix@(PointL j) = zs == ls where - t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1) - zs = (id <<< t ... stoList) maxPLi ix + zs = (id <<< tSI ... stoList) maxPLi ix ls = [ unsafeIndex xsP ix | j>=0, j<=maxI ] prop_O_It ix@(PointL j) = zs == ls where - t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1) - zs = (id <<< t ... stoList) maxPLo ix + zs = (id <<< tSO ... stoList) maxPLo ix ls = [ unsafeIndex xsPo ix | j>=0, j<=maxI ] 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 + zs = (id <<< tZ1I ... stoList) (Z:.maxPLi) ix ls = [ unsafeIndex xsZP ix | j>=0, j<=maxI ] prop_O_ZIt ix@(Z:.PointL j) = zs == ls where - t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1) - zs = (id <<< t ... stoList) (Z:.maxPLo) ix + zs = (id <<< tZ1O ... stoList) (Z:.maxPLo) ix ls = [ unsafeIndex xsZPo ix | j>=0, j<=maxI ] -- | Table, then single terminal prop_I_ItC ix@(PointL j) = zs == ls where - t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1) - zs = ((,) <<< t % chr xs ... stoList) maxPLi ix + zs = ((,) <<< tSI % chr xs ... stoList) maxPLi ix ls = [ ( unsafeIndex xsP (PointL $ j-1) , xs VU.! (j-1) ) | j>=1, j<=maxI ] @@ -147,23 +143,20 @@ -- | @A^*_j -> A^*_{j+1} c_{j+1)@ ! prop_O_ItC ix@(PointL j) = zs == ls where - t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1) - zs = ((,) <<< t % chr xs ... stoList) maxPLo ix + zs = ((,) <<< tSO % chr xs ... stoList) maxPLo ix ls = [ ( unsafeIndex xsPo (PointL $ j+1) , xs VU.! (j+0) ) | j >= 0, j <= (maxI-1) ] prop_O_ItCC ix@(PointL j) = zs == ls where - t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1) - zs = ((,,) <<< t % chr xs % chr xs ... stoList) maxPLo ix + zs = ((,,) <<< tSO % chr xs % chr xs ... stoList) maxPLo ix ls = [ ( unsafeIndex xsPo (PointL $ j+2) , xs VU.! (j+0) , xs VU.! (j+1) ) | j >= 0, j <= (maxI-2) ] 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 + zs = ((,,,) <<< tSO % chr xs % chr xs % chr xs ... stoList) maxPLo ix ls = [ ( unsafeIndex xsPo (PointL $ j+3) , xs VU.! (j+0) , xs VU.! (j+1) @@ -171,8 +164,7 @@ ) | 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 + zs = ((,,) <<< tZ1O % (M:|chr xs) % (M:|chr xs) ... stoList) (Z:.maxPLo) ix ls = [ ( unsafeIndex xsZPo (Z:.PointL (j+2)) , Z:.xs VU.! (j+0) , Z:.xs VU.! (j+1) @@ -181,29 +173,19 @@ -- | synvar followed by a 2-tape character terminal 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 + zs = ((,,) <<< tZ2I % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (Z:.maxPLi:.maxPLi) ix ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2)) , Z:.xs VU.! (j-2):.xs VU.! (l-2) , Z:.xs VU.! (j-1):.xs VU.! (l-1) ) | j>=2, l>=2, j<=maxI, l<=maxI ] prop_O_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where - t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1) - zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (Z:.maxPLo:.maxPLo) ix + zs = ((,,) <<< tZ2O % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... stoList) (Z:.maxPLo:.maxPLo) ix ls = [ ( unsafeIndex xsPPo (Z:.PointL (j+2):.PointL (l+2)) , Z:.xs VU.! (j+0):.xs VU.! (l+0) , Z:.xs VU.! (j+1):.xs VU.! (l+1) ) | j>=0, l>=0, j<=(maxI-2), l<=(maxI-2) ] --- * direct index tests - -{- -xprop_O_ixZItCC ix@(O (Z:.PointL j)) = zs where - t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1) - zs = (id >>> t % (M:|chr xs) % (M:|chr xs) ... stoList) (O (Z:.maxPLo)) ix --} - -- * 'Strng' tests -- ** Just the 'Strng' terminal @@ -216,44 +198,38 @@ zs = (id <<< someS xs ... stoList) maxPLi ix ls = [ (VU.slice 0 j xs) | j>0 ] ---prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where --- zs = (id <<< (M:|manyS xs:|manyS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix --- ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ] +prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where + zs = (id <<< (M:|manyS xs:|manyS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix + ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ] ---prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where --- zs = (id <<< (M:|someS xs:|someS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix --- ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ] +prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where + zs = (id <<< (M:|someS xs:|someS xs) ... stoList) (Z:.maxPLi:.maxPLi) ix + ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ] -- ** Together with a syntactic variable. prop_I_Itbl_ManyS ix@(PointL i) = zs == ls where - t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1) - zs = ((,) <<< t % manyS xs ... stoList) maxPLi ix + zs = ((,) <<< tSI % manyS xs ... stoList) maxPLi ix ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ] 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 + zs = ((,) <<< tSI % someS xs ... stoList) maxPLi ix ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ] 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 + zs = ((,) <<< tZ1I % (M:|manyS xs) ... stoList) (Z:.maxPLi) ix ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ] 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 + zs = ((,) <<< tZ1I % (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_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 + zs = ((,) <<< tZ2I % (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_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 + zs = ((,) <<< tZ2I % (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] ] diff --git a/tests/QuickCheck/Set.hs b/tests/QuickCheck/Set.hs deleted file mode 100644 --- a/tests/QuickCheck/Set.hs +++ /dev/null @@ -1,314 +0,0 @@ - -{-# Options_GHC -O0 #-} - -module QuickCheck.Set where - -import Data.Bits -import Data.Bits.Extras (msb) -import Data.Vector.Fusion.Util -import Debug.Trace -import qualified Data.List as L -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Unboxed as VU -import Test.QuickCheck.All -import Test.QuickCheck hiding (NonEmpty) -import Test.QuickCheck.Monadic -#ifdef ADPFUSION_TEST_SUITE_PROPERTIES -import Test.Framework.TH -import Test.Framework.Providers.QuickCheck2 -#endif - -import Data.Bits.Ordered -import Data.PrimitiveArray - -import ADP.Fusion -import QuickCheck.Common - - - --- * BitSets without interfaces - --- ** Inside checks - -prop_BS0_I_Eps ix@(BitSet _) = zs == ls where - zs = (id <<< Epsilon ... stoList) highestBi ix - ls = [ () | ix == 0 ] - -prop_BS0_I_Iv ix@(BitSet _) = {- traceShow (zs,ls) $ -} L.sort zs == L.sort ls where - tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - zs = ((,) <<< tia % chr csB0 ... stoList) highestBi ix - ls = [ (xsB ! (clearBit ix a), csB0 VU.! a) | a <- activeBitsL ix ] - -prop_BS0_I_Ivv ix@(BitSet _) = {- traceShow (zs,ls) $ -} L.sort zs == L.sort ls where - tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - zs = ((,,) <<< tia % chr csB0 % chr csB0 ... stoList) highestBi ix - ls = [ (xsB ! (clearBit (clearBit ix a) b), csB0 VU.! a, csB0 VU.! b) | a <- activeBitsL ix, b <- activeBitsL ix, a /=b ] - -prop_BS0_I_II ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - zs = ((,) <<< tia % tib ... stoList) highestBi ix - ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) - | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] - , let kk = popShiftL ix (BitSet k) - ] - -prop_BS0_I_JJ ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - zs = ((,) <<< tia % tib ... stoList) highestBi ix - ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) - | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] - , let kk = popShiftL ix (BitSet k) - , popCount kk > 0 - , popCount (ix `xor` kk) > 0 - ] - -prop_BS0_I_III ix@(BitSet _) = {- traceShow (zs,ls) $ -} zs == ls where - tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - zs = ((,,) <<< tia % tib % tic ... stoList) highestBi ix - ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm ) - | k <- VU.toList . popCntSorted $ popCount ix - , l <- VU.toList . popCntSorted $ popCount ix - popCount k - , let kk = popShiftL ix (BitSet k) - , let ll = popShiftL (ix `xor` kk) (BitSet l) - , let mm = (ix `xor` (kk .|. ll)) - ] - -prop_BS0_I_JJJ ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1) - zs = ((,,) <<< tia % tib % tic ... stoList) highestBi ix - ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm ) - | k <- VU.toList . popCntSorted $ popCount ix - , l <- VU.toList . popCntSorted $ popCount ix - popCount k - , let kk = popShiftL ix (BitSet k) - , let ll = popShiftL (ix `xor` kk) (BitSet l) - , let mm = (ix `xor` (kk .|. ll)) - , popCount kk > 0, popCount ll > 0, popCount mm > 0 - ] - - --- * Outside checks --- These checks are very similar to those in the @Subword@ module. We just --- need to be a bit more careful, as indexed sets have overlap. - -prop_BS0_O_Eps ix@(BitSet _) = zs == ls where - zs = (id <<< Epsilon ... stoList) highestBo ix - ls = [ () | ix == highestBo ] - -prop_BS0_O_O ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 EmptyOk xoB (\ _ _ -> Id 1) - zs = (id <<< tia ... stoList) highestBo ix - ls = [ xoB ! ix ] - ---prop_BS0_O_IO ix@(BitSet _) = zs == ls where --- tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) --- tib = ITbl 0 0 EmptyOk xoB (\ _ _ -> Id 1) --- zs = ((,) <<< tia % tib ... stoList) highestBo ix --- ls = [] --- {- --- ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) --- | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] --- , let kk = popShiftL ix (BitSet k) --- ] -} - -{- -prop_BS0_I_II ix@(BitSet _) = zs == ls where - tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1) - zs = ((,) <<< tia % tib ... stoList) highestBi ix - ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) ) - | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ] - , let kk = popShiftL ix (BitSet k) - ] --} - - --- ** Two non-terminals. --- --- @A_s -> B_(s\t) C_t (s\t) ++ t == s@ --- @s = 111 , s\t = 101, t = 010@ --- --- with @Z@ the full set. --- @Z = 1111@ - --- @B*_Z\(s\t) -> A*_Z\s C_t@ --- @Z\(s\t) = 1010, Z\s = 1000, t = 010@ - - - - --- * BitSets with two interfaces - --- ** Inside checks - ---prop_bii_i :: BS2 First Last I -> Bool ---prop_bii_i ix@(BS2 s i j) = zs == ls where --- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- zs = (id <<< tia ... stoList) highestBII ix --- ls = [ xsBII ! ix ] --- ---prop_bii_i_n :: BS2 First Last I -> Bool ---prop_bii_i_n ix@(BS2 s i j) = zs == ls where --- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) --- zs = (id <<< tia ... stoList) highestBII ix --- ls = [ xsBII ! ix | popCount s > 0 ] - --- | Edges should never work as a single terminal element. - ---prop_bii_e :: BS2 First Last I -> Bool ---prop_bii_e ix@(BS2 s (Iter i) (Iter j)) = zs == ls where --- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) --- zs = (id <<< e ... stoList) highestBII ix --- ls = [] :: [ (Int,Int) ] - --- | Edges extend only in cases where in @i -> j@, @i@ actually happens to --- be a true interface. - ---prop_bii_ie :: BS2 First Last I -> Bool ---prop_bii_ie ix@(BS2 s i (Iter j)) = zs == ls where --- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) --- zs = ((,) <<< tia % e ... stoList) highestBII ix --- ls = [ ( xsBII ! (BS2 t i (Iter k :: Interface Last)) , (k,j) ) --- | let t = s `clearBit` j --- , k <- activeBitsL t ] --- ---prop_bii_ie_n :: BS2 First Last I -> Bool ---prop_bii_ie_n ix@(BS2 s i (Iter j)) = zs == ls where --- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) --- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) --- zs = ((,) <<< tia % e ... stoList) highestBII ix --- ls = [ ( xsBII ! (BS2 t i (Iter k :: Interface Last)) , (k,j) ) --- | let t = s `clearBit` j --- , popCount t >= 2 --- , k <- activeBitsL t --- , k /= getIter i --- ] --- ---prop_bii_iee :: BS2 First Last I -> Bool ---prop_bii_iee ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where --- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) --- zs = ((,,) <<< tia % e % e ... stoList) highestBII ix --- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,j) ) --- | let tmp = (s `clearBit` j) --- , l <- activeBitsL tmp --- , l /= getIter i --- , let t = tmp `clearBit` l --- , k <- activeBitsL t --- , let kk = Iter k --- ] --- ---prop_bii_ieee :: BS2 First Last I -> Bool ---prop_bii_ieee ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where --- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) --- zs = ((,,,) <<< tia % e % e % e ... stoList) highestBII ix --- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,m) , (m,j) ) --- | let tmpM = (s `clearBit` j) --- , m <- activeBitsL tmpM --- , m /= getIter i --- , let tmpL = (tmpM `clearBit` m) --- , l <- activeBitsL tmpL --- , l /= getIter i --- , let t = tmpL `clearBit` l --- , k <- activeBitsL t --- , let kk = Iter k --- ] --- ---prop_bii_iee_n :: BS2 First Last I -> Bool ---prop_bii_iee_n ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where --- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) --- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) --- zs = ((,,) <<< tia % e % e ... stoList) highestBII ix --- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,j) ) --- | let tmp = (s `clearBit` j) --- , l <- activeBitsL tmp --- , l /= getIter i --- , let t = tmp `clearBit` l --- , popCount t >= 2 --- , k <- activeBitsL t --- , k /= getIter i --- , let kk = Iter k --- ] --- ---prop_bii_ieee_n :: BS2 First Last I -> Bool ---prop_bii_ieee_n ix@(BS2 s i (Iter j)) = L.sort zs == L.sort ls where --- tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1) --- e = Edge (\ i j -> (i,j)) :: Edge (Int,Int) --- zs = ((,,,) <<< tia % e % e % e ... stoList) highestBII ix --- ls = [ ( xsBII ! (BS2 t i kk) , (k,l) , (l,m) , (m,j) ) --- | let tmpM = (s `clearBit` j) --- , m <- activeBitsL tmpM --- , m /= getIter i --- , let tmpL = (tmpM `clearBit` m) --- , l <- activeBitsL tmpL --- , l /= getIter i --- , let t = tmpL `clearBit` l --- , popCount t >= 2 --- , k <- activeBitsL t --- , k /= getIter i --- , let kk = Iter k --- ] - --- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where --- tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1) --- zs = ((,) <<< tia % tib ... stoList) highestBII ix --- ls = [ ( xsBII ! kk , xsBII ! ll ) --- | k <- VU.toList . popCntSorted $ popCount s --- , ki <- if k==0 then [0] else activeBitsL k --- , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki) --- , let kk = (BitSet k:>Iter ki:>Iter kj) --- , let l = s `xor` BitSet k --- , li <- if l==0 then [0] else activeBitsL l --- , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li) --- , let ll = (l:>Iter li:>Iter lj) --- ] - - - --- * Helper functions - -stoList = unId . SM.toList - -highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary -highestBi :: BitSet I -highestBi = BitSet $ 2^(highBit+1) -1 -highestBo :: BitSet O -highestBo = BitSet $ 2^(highBit+1) -1 -highestBII = BS2 highestBi (Iter $ highBit-1) (Iter $ highBit-1) -- assuming @highBit >= 1@ - -xsB :: Unboxed (BitSet I) Int -xsB = fromList (BitSet 0) highestBi [ 0 .. ] - -xoB :: Unboxed (BitSet O) Int -xoB = fromList (BitSet 0) highestBo [ 0 .. ] - -xsBII :: Unboxed (BS2 First Last I) Int -xsBII = fromList (BS2 0 0 0) highestBII [ 0 .. ] - -csB0 :: VU.Vector Int -csB0 = VU.fromList [ i | i <- [0 .. msb highestBi] ] - --- * general quickcheck stuff - -options = stdArgs {maxSuccess = 1000} - -customCheck = quickCheckWithResult options - -return [] -allProps = $forAllProperties customCheck - - - -#ifdef ADPFUSION_TEST_SUITE_PROPERTIES -testgroup_set = $(testGroupGenerator) -#endif - - diff --git a/tests/QuickCheck/Subword.hs b/tests/QuickCheck/Subword.hs deleted file mode 100644 --- a/tests/QuickCheck/Subword.hs +++ /dev/null @@ -1,230 +0,0 @@ - -{-# Options_GHC -O0 #-} - --- | --- --- TODO need to carefully check all props against boundary errors! --- Especially the 2-dim cases! - -module QuickCheck.Subword where - -import Data.Vector.Fusion.Util -import Debug.Trace -import qualified Data.List as L -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Unboxed as VU -import Test.QuickCheck -import Test.QuickCheck.All -import Test.QuickCheck.Monadic -#ifdef ADPFUSION_TEST_SUITE_PROPERTIES -import Test.Framework.TH -import Test.Framework.Providers.QuickCheck2 -#endif - -import Data.PrimitiveArray - -import ADP.Fusion - - - --- * Outside checks - --- ** two non-terminals on the r.h.s. --- --- A_ij -> B_ik C_kj --- --- B*_ik -> A*_ij C_kj --- C*_kj -> B_ik A*_ij - -prop_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 - ls = [ ( unsafeIndex xoS (subword i j) - , unsafeIndex xsS (subword k j) ) - | j <- [ k .. highest ] ] - -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 - ls = [ ( unsafeIndex xsS (subword i k) - , unsafeIndex xoS (subword i j) ) - | j <= highest, i <- [ 0 .. k ] ] - --- ** three non-terminals on the r.h.s. (this provides situations where two --- syntactic terminals are on the same side) --- --- A_ij -> B_ik C_kl D_lj --- --- B*_ik -> A*_ij C_kl D_lj --- C*_kl -> B_ik A*_ij D_lj --- D*_lj -> B_ik C_kl A*_ij - -prop_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)) - zs = ((,,) <<< toa % tic % tid ... stoList) maxSWo ox - ls = [ ( unsafeIndex xoS (subword i j) - , unsafeIndex xsS (subword k l) - , unsafeIndex xsS (subword l j) ) - | j <- [ k .. highest ], l <- [ k .. j ] ] - -prop_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)) - zs = ((,,) <<< tib % toa % tid ... stoList) maxSWo ox - ls = [ ( unsafeIndex xsS (subword i k) - , unsafeIndex xoS (subword i j) - , unsafeIndex xsS (subword l j) ) - | i <- [ 0 .. k ], j <- [ l .. highest ] ] - -prop_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)) - zs = ((,,) <<< tib % tic % toa ... stoList) maxSWo ox - ls = [ ( unsafeIndex xsS (subword i k) - , unsafeIndex xsS (subword k l) - , unsafeIndex xoS (subword i j) ) - | j <= highest, i <- [ 0 .. l ], k <- [ i .. l ] ] - --- ** four non-terminals on the r.h.s. ? - --- ** five non-terminals on the r.h.s. ? - --- ** Non-terminal and terminal combinations - -prop_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) - , unsafeIndex xoS (subword (i-1) (j+1)) - , csS VU.! (j ) ) - | i > 0 && j < highest ] - -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) - , csS VU.! (i-1) - , unsafeIndex xoS (subword (i-2) (j+2)) - , csS VU.! (j ) - , csS VU.! (j+1) ) - | i > 1 && j < highest -1 ] - -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) - , unsafeIndex xoS (subword (i-1) (j+3)) - , csS VU.! (j ) - , csS VU.! (j+1) - , csS VU.! (j+2) ) - | i > 0 && j < highest -2 ] - --- ** Terminals, syntactic terminals, and non-terminals - -prop_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 - ls = [ ( csS VU.! (i-1) - , unsafeIndex xoS (subword (i-1) j ) - , csS VU.! (k ) - , unsafeIndex xsS (subword (k+1) (j-1)) - , csS VU.! (j-1) ) - | i > 0, j <- [ k+2 .. highest ] ] - -prop_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 - ls = [ ( csS VU.! (i ) - , unsafeIndex xsS (subword (i+1) (k-1)) - , csS VU.! (k-1) - , unsafeIndex xoS (subword i (j+1)) - , csS VU.! (j ) ) - | j+1 <= highest, k>1, i <- [ 0 .. k-2 ] ] - --- ** Epsilonness - -prop_O_Epsilon ox@(Subword (i:.j)) = zs === ls where - zs = (id <<< Epsilon ... stoList) (maxSWo) ox - ls = [ () | i==0 && j==highest ] - - --- ** Multi-tape cases - -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_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) - , unsafeIndex xsSS (Z :. subword (i+1) j :. subword (k+1) l) ) - | j<=highest && l<=highest - , i+1<=j && k+1<=l ] - -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)) - , Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) ) - | j<=highest && l<=highest - , i+1<=j && k+1<=l ] - -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) - , unsafeIndex xsSS (Z :. subword (i+1) (j-1) :. subword (k+1) (l-1)) - , Z :. (csS VU.! (j-1)) :. (csS VU.! (l-1)) ) - | j<=highest && l<=highest - , i+2<=j && k+2<=l ] - - - -stoList = unId . SM.toList - -highest = 20 - -maxSWi :: Subword I -maxSWi = subword 0 highest - -maxSWo :: Subword O -maxSWo = subword 0 highest - -csS :: VU.Vector (Int,Int) -csS = VU.fromList [ (i,i+1) | i <- [0 .. highest-1] ] -- this should be @highest -1@, we should die if we see @(highest,highest+1)@ - -xsS :: Unboxed (Subword I) (Int,Int) -xsS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ] - -xoS :: Unboxed (Subword O) (Int,Int) -xoS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ] - -xsSS :: Unboxed (Z:.Subword I:.Subword I) ( (Int,Int) , (Int,Int) ) -xsSS = fromAssocs (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 highest:.subword 0 highest) ((-1,-1),(-1,-1)) - $ Prelude.map (\((i,j),(k,l)) -> (Z:.subword i j:.subword k l, ((i,j),(k,l)) )) [ ((i,j) , (k,l)) | i <- [0 .. highest], j <-[i .. highest], k <- [0 .. highest], l <- [0 .. highest] ] - --- * general quickcheck stuff - -options = stdArgs {maxSuccess = 10000} - -customCheck = quickCheckWithResult options - -return [] -allProps = $forAllProperties customCheck - - - -#ifdef ADPFUSION_TEST_SUITE_PROPERTIES -testgroup_subword = $(testGroupGenerator) -#endif - diff --git a/tests/performance.hs b/tests/performance.hs deleted file mode 100644 --- a/tests/performance.hs +++ /dev/null @@ -1,89 +0,0 @@ - -module Main where - -import Data.Vector.Fusion.Util -import GHC.Stats -import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Unboxed as VU -import System.Mem -import System.Environment -import GHC.Conc (pseq) -import GHC.Generics -import qualified Data.Vector as V -import Control.Arrow (second) -import Data.Int(Int64) -import System.Exit - -import ADP.Fusion hiding (Split) -import Data.PrimitiveArray hiding (map) -import BenchmarkHistory - - - --- | All grammars require a signature. - -data Split m x r = Split - { nil :: () -> x - , lef :: Int -> x -> x - , spl :: x -> x -> x - , h :: SM.Stream m x -> m r - } - --- makeAlgebraProduct ''Split - -algMax :: Monad m => Split m Int Int -algMax = Split - { nil = \ () -> 0 - , lef = \k x -> k+x - , spl = \ x y -> x+y - , h = SM.foldl' max 0 - } -{-# Inline algMax #-} - -gLeft Split{..} c t' = - let t = t' ( lef <<< chr c % t ||| - spl <<< t % t ||| - nil <<< Epsilon ... h - ) - in Z:.t -{-# Inline gLeft #-} - -mkArrs :: Int -> (VU.Vector Int, Unboxed (Subword I) Int) -mkArrs n = ( VU.enumFromTo 1 n - , fromAssocs (subword 0 0) (subword 0 n) (-999999) [] - ) -{-# NoInline mkArrs #-} - --- | WARNING: Multiple runs of @runLeft@ make use of the same @arr@. This --- is, of course, dangerous. Unless you know what you are doing. - -runLeft :: (VU.Vector Int, Unboxed (Subword I) Int) -> Int -> Int -runLeft (!i, !arr) k = seq k d where --- i = VU.enumFromTo 1 k - n = VU.length i --- arr = fromAssocs (subword 0 0) (subword 0 n) (-999999) [] - (Z:.t) = runLeftForward i arr - d = unId $ axiom t -{-# NoInline runLeft #-} - -runLeftForward :: VU.Vector Int -> Unboxed (Subword I) Int -> Z:.ITbl Id Unboxed EmptyOk (Subword I) Int -runLeftForward !i !arr = mutateTablesDefault - $ gLeft algMax - i - (ITbl 0 0 EmptyOk arr) -{-# NoInline runLeftForward #-} - - - -main :: IO () -main = do - es <- sequence - [ benchmark 10000 ("bench-0100.csv") mkArrs runLeft 100 - , benchmark 10 ("bench-1000.csv") mkArrs runLeft 1000 - , benchmark 1 ("bench-2000.csv") mkArrs runLeft 2000 - ] - let ok = all (== ExitSuccess) es - if ok - then exitSuccess - else exitFailure - diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -1,19 +1,14 @@ --- | Test all properties automatically. We keep the QC2 modules in the main --- library for now, as this allows for more efficient repl tests. +-- | Test all properties automatically. module Main where ---import Test.Framework.Providers.QuickCheck2 ---import Test.Framework.TH import Test.Framework import QuickCheck.Point (testgroup_point) -import QuickCheck.Set (testgroup_set) -import QuickCheck.Subword (testgroup_subword) main :: IO () -main = defaultMain [testgroup_point, testgroup_set, testgroup_subword] +main = defaultMain [testgroup_point]