diff --git a/ADP/Fusion.hs b/ADP/Fusion.hs
--- a/ADP/Fusion.hs
+++ b/ADP/Fusion.hs
@@ -1,16 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 -- | Generalized fusion system for grammars.
 --
@@ -18,54 +5,32 @@
 -- 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.
---
--- TODO each combinator should come with a special outer check. Given some
--- index (say (i,j), this can then check if i-const >= 0, or j+const<=n, or
--- i+const<=j. That should speed up everything that uses GChr combinators.
--- Separating out this check means that certain inner loops can run without any
--- conditions and just jump.
 
 module ADP.Fusion
-  -- basic combinators
-  ( (<<<)
-  , (<<#)
-  , (|||)
-  , (...)
-  , (~~)
-  , (%)
-  -- filters
-  , check
-  -- parsers
-  , chr
-  , chrLeft
-  , chrRight
-  , peekL
-  , peekR
-  , empty
-  , region
-  , sregion
---  , Tbl (..)
---  , BtTbl (..)
-  , MTbl (..)
-  , ENE (..)
-  , ENZ (..)
-  , None (..)
+  ( 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           Data.Strict.Tuple
+import           GHC.Exts (inline)
 import qualified Data.Vector.Fusion.Stream.Monadic as S
 
-import ADP.Fusion.Apply
-import ADP.Fusion.Chr
-import ADP.Fusion.Classes
-import ADP.Fusion.Empty
-import ADP.Fusion.Region
-import ADP.Fusion.Table
-import ADP.Fusion.None
+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
@@ -74,17 +39,17 @@
 -- function 'f'.
 
 infixl 8 <<<
-(<<<) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.map (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij
+(<<<) f xs = \lu ij -> S.map (apply (inline f) . getArg) . mkStream (build xs) (initialContext ij) lu $ ij
 {-# INLINE (<<<) #-}
 
 infixl 8 <<#
-(<<#) f xs = \ij -> outerCheck (checkValidIndex (build xs) ij) . S.mapM (apply (inline f) . getArg) . mkStream (build xs) (outer ij) $ ij
+(<<#) 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 = \ij -> xs ij S.++ ys ij
+(|||) xs ys = \lu ij -> xs lu ij S.++ ys lu ij
 {-# INLINE (|||) #-}
 
 -- | Applies the objective function 'h' to a stream 's'. The objective function
@@ -92,14 +57,14 @@
 -- things).
 
 infixl 5 ...
-(...) s h = h . s
+(...) 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 #-}
+-- -- | 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.
 
@@ -112,11 +77,4 @@
 infixl 9 %
 (%) = (:!:)
 {-# INLINE (%) #-}
-
-
-
-
-
-
-
 
diff --git a/ADP/Fusion/Apply.hs b/ADP/Fusion/Apply.hs
--- a/ADP/Fusion/Apply.hs
+++ b/ADP/Fusion/Apply.hs
@@ -1,10 +1,8 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 module ADP.Fusion.Apply where
 
-import Data.Array.Repa.Index
+--import Data.Array.Repa.Index
+import Data.PrimitiveArray (Z(..), (:.)(..))
 
 
 
diff --git a/ADP/Fusion/Base.hs b/ADP/Fusion/Base.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Base.hs
@@ -0,0 +1,15 @@
+
+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
+  ) 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
+
diff --git a/ADP/Fusion/Base/Classes.hs b/ADP/Fusion/Base/Classes.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Base/Classes.hs
@@ -0,0 +1,142 @@
+
+module ADP.Fusion.Base.Classes where
+
+import           Data.Strict.Tuple
+import           Data.Vector.Fusion.Stream.Size
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import           Data.PrimitiveArray
+
+
+
+data OutsideContext s
+  = OStatic     s
+  | ORightOf    s
+  | OFirstLeft  s
+  | OLeftOf     s
+
+data InsideContext s
+  = IStatic   s
+  | IVariable s
+
+data ComplementContext
+  = Complemented
+
+class RuleContext i where
+  type Context i :: *
+  initialContext :: i -> Context i
+
+-- | 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 Arg x :: *
+  getArg :: Elm x i -> Arg x
+  getIdx :: Elm x i -> i
+  getOmx :: Elm x i -> 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 !i !i
+  type Arg S   = Z
+  getArg (ElmS _ _) = Z
+  getIdx (ElmS i _) = i
+  getOmx (ElmS _ o) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+deriving instance Show 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 n) = b `seq` S.Stream snew (CheckLeft (b:.t)) (toMax n) 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 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)
+
+minSize :: TableConstraint -> Int
+minSize NonEmpty = 1
+minSize _        = 0
+{-# INLINE minSize #-}
+
+class ModifyConstraint t where
+  toNonEmpty :: t -> t
+  toEmpty    :: t -> t
+
+-- |
+
+type family   TblConstraint x       :: *
+
+type instance TblConstraint (is:.i)        =  TblConstraint is :. TblConstraint i
+type instance TblConstraint Z              = Z
+type instance TblConstraint (Outside o)    = TblConstraint o
+type instance TblConstraint (Complement o) = TblConstraint o
+
+-- TODO move into the sub-modules
+
+type instance TblConstraint PointL      = TableConstraint
+type instance TblConstraint PointR      = TableConstraint
+type instance TblConstraint Subword     = TableConstraint
+
diff --git a/ADP/Fusion/Base/Multi.hs b/ADP/Fusion/Base/Multi.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Base/Multi.hs
@@ -0,0 +1,189 @@
+
+module ADP.Fusion.Base.Multi where
+
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+import           Data.Strict.Tuple
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Base.Classes
+
+
+
+-- * 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
+
+instance (Element ls i) => Element (ls :!: TermSymbol a b) i where
+  data Elm (ls :!: TermSymbol a b) i = ElmTS !(TermArg (TermSymbol a b)) !i !i !(Elm ls i)
+  type Arg (ls :!: TermSymbol a b)   = Arg ls :. TermArg (TermSymbol a b)
+  getArg (ElmTS a _ _ ls) = getArg ls :. a
+  getIdx (ElmTS _ i _ _ ) = i
+  getOmx (ElmTS _ _ o _ ) = o
+  {-# INLINE getArg #-}
+  {-# INLINE getIdx #-}
+
+deriving instance (Show i, Show (TermArg (TermSymbol a b)), Show (Elm ls i)) => Show (Elm (ls :!: TermSymbol a b) i)
+
+instance
+  ( Monad m
+  , MkStream m ls i
+  , Element ls i
+  , TerminalStream m (TermSymbol a b) i
+  , TermStaticVar (TermSymbol a b) i
+  ) => MkStream m (ls :!: TermSymbol a b) i where
+  mkStream (ls :!: ts) sv lu i
+    = S.map fromTerminalStream
+    . terminalStream ts sv i
+    . S.map toTerminalStream
+    $ 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 #-}
+
+oPackTerminalStream a sv (O (is:.i)) = terminalStream a sv (O is) . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))
+{-# Inline oPackTerminalStream #-}
+
+instance (Monad m) => TerminalStream m M Z where
+  terminalStream M _ Z = S.map (\(S5 s j1 j2 Z Z) -> S6 s j1 j2 Z Z Z)
+  {-# INLINE terminalStream #-}
+
+instance (Monad m) => TerminalStream m M (Outside Z) where
+  terminalStream M _ (O Z) = S.map (\(S5 s j1 j2 (O Z) (O Z)) -> S6 s j1 j2 (O Z) (O Z) Z)
+  {-# INLINE terminalStream #-}
+
+instance Monad m => MkStream m S Z where
+  mkStream _ _ _ _ = S.singleton (ElmS Z Z)
+  {-# INLINE mkStream #-}
+
+instance Monad m => MkStream m S (Outside Z) where
+  mkStream _ _ _ _ = S.singleton (ElmS (O Z) (O Z))
+  {-# INLINE mkStream #-}
+
+-- | For multi-dimensional terminals we need to be able to calculate how the
+-- static/variable signal changes and if the index for the inner part needs to
+-- be modified.
+
+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 termStaticVar #-}
+  {-# INLINE termStreamIndex #-}
+
+instance TermStaticVar M (Outside Z) where
+  termStaticVar   _ _ _ = Z
+  termStreamIndex _ _ _ = O Z
+  {-# INLINE termStaticVar #-}
+  {-# INLINE termStreamIndex #-}
+
+instance
+  ( TermStaticVar a is
+  , TermStaticVar b i
+  ) => TermStaticVar (TermSymbol a b) (is:.i) where
+  termStaticVar   (a:|b) (vs:.v) (is:.i) = termStaticVar   a vs is :. termStaticVar   b v i
+  termStreamIndex (a:|b) (vs:.v) (is:.i) = termStreamIndex a vs is :. termStreamIndex b v i
+  {-# INLINE termStaticVar #-}
+  {-# INLINE termStreamIndex #-}
+
+instance
+  ( TermStaticVar a (Outside is)
+  , TermStaticVar b (Outside i)
+  ) => TermStaticVar (TermSymbol a b) (Outside (is:.i)) where
+  termStaticVar   (a:|b) (vs:.v) (O (is:.i)) = termStaticVar   a vs (O is) :. termStaticVar   b v (O i)
+  termStreamIndex (a:|b) (vs:.v) (O (is:.i)) =
+    let (O js) = termStreamIndex a vs (O is)
+        (O j)  = termStreamIndex b v (O i)
+    in O (js:.j)
+  {-# INLINE termStaticVar #-}
+  {-# INLINE termStreamIndex #-}
+
+data 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
+
+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 (Outside Z) where
+  type Context (Outside Z) = Z
+  initialContext _ = Z
+  {-# INLINE initialContext #-}
+
+instance (RuleContext is, RuleContext i) => RuleContext (is:.i) where
+  type Context (is:.i) = Context is:.Context i
+  initialContext (is:.i) = initialContext is:.initialContext i
+  {-# INLINE initialContext #-}
+
+instance (RuleContext (Outside is), RuleContext (Outside i)) => RuleContext (Outside (is:.i)) where
+  type Context (Outside (is:.i)) = Context (Outside is):.Context (Outside i)
+  initialContext (O (is:.i)) = initialContext (O is):.initialContext (O i)
+  {-# INLINE initialContext #-}
+
+class TableStaticVar i where
+  tableStaticVar   ::                    Context i -> i -> Context i
+  tableStreamIndex :: TblConstraint i -> Context i -> i -> i
+
+instance TableStaticVar Z where
+  tableStaticVar     _ _ = Z
+  tableStreamIndex _ _ _ = Z
+  {-# INLINE [0] tableStaticVar   #-}
+  {-# INLINE [0] tableStreamIndex #-}
+
+instance TableStaticVar (Outside Z) where
+  tableStaticVar     _ _ = Z
+  tableStreamIndex _ _ _ = O Z
+  {-# INLINE [0] tableStaticVar   #-}
+  {-# INLINE [0] tableStreamIndex #-}
+
+instance (TableStaticVar is, TableStaticVar i) => TableStaticVar (is:.i) where
+  tableStaticVar           (vs:.v) (is:.i) = tableStaticVar      vs is :. tableStaticVar     v i
+  tableStreamIndex (cs:.c) (vs:.v) (is:.i) = tableStreamIndex cs vs is :. tableStreamIndex c v i
+  {-# INLINE [0] tableStaticVar   #-}
+  {-# INLINE [0] tableStreamIndex #-}
+
+instance (TableStaticVar (Outside is), TableStaticVar (Outside i)) => TableStaticVar (Outside (is:.i)) where
+  tableStaticVar           (vs:.v) (O (is:.i)) = tableStaticVar      vs (O is) :. tableStaticVar     v (O i)
+  tableStreamIndex (cs:.c) (vs:.v) (O (is:.i)) =
+    let (O js) = tableStreamIndex cs vs (O is)
+        (O j)  = tableStreamIndex c  v  (O i)
+    in O (js:.j)
+  {-# INLINE [0] tableStaticVar   #-}
+  {-# INLINE [0] tableStreamIndex #-}
+
diff --git a/ADP/Fusion/Base/Point.hs b/ADP/Fusion/Base/Point.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Base/Point.hs
@@ -0,0 +1,112 @@
+
+module ADP.Fusion.Base.Point where
+
+import Data.Vector.Fusion.Stream.Monadic (singleton,map,filter,Step(..),flatten)
+import Data.Vector.Fusion.Stream.Size
+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 where
+  type Context PointL = InsideContext Int
+  initialContext _ = IStatic 0
+  {-# Inline initialContext #-}
+
+instance RuleContext (Outside PointL) where
+  type Context (Outside PointL) = OutsideContext Int
+  initialContext _ = OStatic 0
+  {-# Inline initialContext #-}
+
+instance RuleContext (Complement PointL) where
+  type Context (Complement PointL) = ComplementContext
+  initialContext _ = Complemented
+  {-# Inline initialContext #-}
+
+
+
+instance (Monad m) => MkStream m S PointL where
+  mkStream S (IStatic d) (PointL u) (PointL j)
+    = staticCheck (j>=0 && j<=d) . singleton $ ElmS (PointL 0) (PointL 0)
+  mkStream S (IVariable _) (PointL u) (PointL j)
+    = staticCheck (0<=j) . singleton $ ElmS (PointL 0) (PointL 0)
+  {-# Inline mkStream #-}
+
+instance (Monad m) => MkStream m S (Outside PointL) where
+  mkStream S (OStatic d) (O (PointL u)) (O (PointL i))
+    = staticCheck (i>=0 && i+d<=u && u == i) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)
+  mkStream S (OFirstLeft d) (O (PointL u)) (O (PointL i))
+    = staticCheck (i>=0 && i+d<=u) . singleton $ ElmS (O $ PointL i) (O . PointL $ i+d)
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( Monad m
+  , MkStream m S is
+  , Context (is:.PointL) ~ (Context is:.(InsideContext Int))
+  ) => MkStream m S (is:.PointL) where
+  mkStream S (vs:.IStatic d) (lus:.PointL u) (is:.PointL i)
+    = staticCheck (i>=0 && i<=d && i<=u)
+    . map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))
+    $ mkStream S vs lus is
+  {-
+  mkStream S (vs:.IVariable ) (lus:.PointL u) (is:.PointL i)
+    = flatten mk step Unknown $ mkStream S vs lus is
+    where mk e = i `seq` return (e,i)
+          step (ElmS zi zo,k )
+            | k>=0 && k<=u = return $ Yield (ElmS (zi:.PointL k) (zo:.PointL 0)) (ElmS zi zo, -1)
+            | otherwise    = return $ Done
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  -}
+  -- TODO here, we have a problem in the interplay of @staticCheck@ or
+  -- @flatten@ and how we modify @is@. Apparently, once we demand to know
+  -- about @i@, fusion breaks down.
+  mkStream S (vs:.IVariable d) (lus:.PointL u) (is:.PointL i)
+    = staticCheck (i>=0 && i<=u)
+    $ map (\(ElmS zi zo) -> ElmS (zi:.PointL 0) (zo:.PointL 0))
+    $ mkStream S vs lus is
+  {-# INLINE mkStream #-}
+
+instance
+  ( Monad m
+  , MkStream m S (Outside is)
+  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)
+  ) => MkStream m S (Outside (is:.PointL)) where
+  mkStream S (vs:.OStatic d) (O (lus:.PointL u)) (O (is:.PointL i))
+    = staticCheck (i>=0 && i+d == u)
+    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))
+    $ mkStream S vs (O lus) (O is)
+  mkStream S (vs:.OFirstLeft d) (O (us:.PointL u)) (O (is:.PointL i))
+    = staticCheck (i>=0 && i+d<=u)
+    . map (\(ElmS (O zi) (O zo)) -> ElmS (O (zi:.PointL i)) (O (zo:.(PointL $ i+d))))
+    $ mkStream S vs (O us) (O is)
+  {-# Inline mkStream #-}
+
+instance TableStaticVar PointL where
+  tableStaticVar (IStatic   d) _ = IVariable d
+  tableStaticVar (IVariable d) _ = IVariable d
+  -- NOTE this code used to destroy fusion. If we inline tableStreamIndex
+  -- very late (after 'mkStream', probably) then everything works out.
+  tableStreamIndex c _ (PointL j)
+    | c==EmptyOk  = PointL j
+    | c==NonEmpty = PointL $ j-1
+    | c==OnlyZero = PointL j -- this should then actually request a size in 'tableStaticVar' ...
+  {-# INLINE [0] tableStaticVar   #-}
+  {-# INLINE [0] tableStreamIndex #-}
+
+instance TableStaticVar (Outside PointL) where
+  tableStaticVar     (OStatic d) _ = OFirstLeft d
+  tableStreamIndex c _ (O (PointL j))
+    | c==EmptyOk  = O (PointL j)
+    | c==NonEmpty = O (PointL $ j-1)
+    | c==OnlyZero = O (PointL j) -- this should then actually request a size in 'tableStaticVar' ...
+  {-# INLINE [0] tableStaticVar   #-}
+  {-# INLINE [0] tableStreamIndex #-}
+
diff --git a/ADP/Fusion/Base/Set.hs b/ADP/Fusion/Base/Set.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Base/Set.hs
@@ -0,0 +1,103 @@
+
+-- | 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.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)
+import Data.Vector.Fusion.Stream.Size
+import Debug.Trace
+import Prelude hiding (map,filter)
+import Data.Bits
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Base.Classes
+import ADP.Fusion.Base.Multi
+
+
+
+type instance TblConstraint BitSet                              = TableConstraint
+type instance TblConstraint (BitSet:>Interface i:>Interface j)  = TableConstraint
+
+
+
+instance RuleContext BitSet where
+  type Context BitSet = InsideContext Int
+  initialContext _ = IStatic 0
+  {-# Inline initialContext #-}
+
+instance RuleContext (Outside BitSet) where
+  type Context (Outside BitSet) = OutsideContext ()
+  initialContext _ = OStatic ()
+  {-# Inline initialContext #-}
+
+instance RuleContext (Complement BitSet) where
+  type Context (Complement BitSet) = ComplementContext
+  initialContext _ = Complemented
+  {-# Inline initialContext #-}
+
+
+
+instance RuleContext (BS2I First Last) where
+  type Context (BS2I First Last) = InsideContext Int
+  initialContext _ = IStatic 0
+  {-# Inline initialContext #-}
+
+instance RuleContext (Outside (BS2I First Last)) where
+  type Context (Outside (BS2I First Last)) = OutsideContext ()
+  initialContext _ = OStatic ()
+  {-# Inline initialContext #-}
+
+instance RuleContext (Complement (BS2I First Last)) where
+  type Context (Complement (BS2I First Last)) = ComplementContext
+  initialContext _ = Complemented
+  {-# Inline initialContext #-}
+
+
+
+instance
+  ( Monad m
+  ) => MkStream m S BitSet where
+  mkStream S (IStatic c) u s
+    = staticCheck (c <= popCount s) . singleton $ ElmS s 0
+  mkStream S (IVariable c) u s
+    = staticCheck (c <= popCount s) . singleton $ ElmS 0 0
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( Monad m
+  ) => MkStream m S (BS2I First Last) where
+  mkStream S (IStatic rp) u sij@(s:>Iter i:>j)
+    = staticCheck (popCount s == 0 && rp == 0) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i
+  mkStream S (IVariable rp) u sij@(s:>Iter i:>j)
+    = staticCheck (popCount s >= rp) . singleton $ ElmS (0:>Iter i:>Iter i) undefbs2i
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  ) => MkStream m S (Outside (BS2I First Last)) where
+
+instance
+  ( Monad m
+  ) => MkStream m S (Complement (BS2I First Last)) where
+
+
+
+-- | An undefined bitset with 2 interfaces.
+
+undefbs2i :: BS2I f l
+undefbs2i = (-1) :> (-1) :> (-1)
+{-# Inline undefbs2i #-}
+
+undefi :: Interface i
+undefi = (-1)
+{-# Inline undefi #-}
+
+-- | 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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Base/Subword.hs
@@ -0,0 +1,75 @@
+
+-- | 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 Data.Vector.Fusion.Stream.Size
+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 where
+  type Context Subword = InsideContext ()
+  initialContext _ = IStatic ()
+  {-# Inline initialContext #-}
+
+instance RuleContext (Outside Subword) where
+  type Context (Outside Subword) = OutsideContext (Int:.Int)
+  initialContext _ = OStatic (0:.0)
+  {-# Inline  initialContext #-}
+
+instance RuleContext (Complement Subword) where
+  type Context (Complement Subword) = ComplementContext
+  initialContext _ = Complemented
+  {-# Inline initialContext #-}
+
+-- TODO write instance
+
+-- instance RuleContext (Complement Subword)
+
+
+
+instance (Monad m) => MkStream m S Subword where
+  mkStream S (IStatic ()) (Subword (_:.h)) (Subword (i:.j))
+    = staticCheck (i>=0 && i==j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)
+  -- NOTE it seems that a static check within an @IVariable@ context
+  -- destroys fusion; maybe because of the outer flatten? We don't actually
+  -- need a static check anyway because the next flatten takes care of
+  -- conditional checks. @filter@ on the other hand, does work.
+  -- TODO test with and without filter using quickcheck
+  mkStream S (IVariable ()) (Subword (_:.h)) (Subword (i:.j))
+    = filter (const $ 0<=i && i<=j && j<=h) . singleton $ ElmS (subword i i) (subword 0 0)
+  {-# Inline mkStream #-}
+
+instance (Monad m) => MkStream m S (Outside Subword) where
+  mkStream S (OStatic (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
+    = staticCheck (i==0 && j+dj==h) . singleton $ ElmS (O $ subword i j) (O $ Subword (i:.j+dj))
+  mkStream S (OFirstLeft (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
+    = let i' = i-di
+      in  staticCheck (0 <= i' && i<=j && j+dj<=h) . singleton $ ElmS (O $ subword i' i') (O $ subword i' i')
+  mkStream S (OLeftOf (di:.dj)) (O (Subword (_:.h))) (O (Subword (i:.j)))
+    = let i' = i-di
+      in  staticCheck (0 <= i' && i<=j && j+dj<=h)
+    $ map (\k -> ElmS (O $ subword 0 k) (O $ subword k j))
+    $ enumFromStepN 0 1 (i'+1)
+  {-# Inline mkStream #-}
+
+instance (Monad m) => MkStream m S (Complement Subword) where
+  mkStream S Complemented (C (Subword (_:.h))) (C (Subword (i:.j)))
+    = map (\(k,l) -> ElmS (C $ subword k l) (C $ subword k l))
+    $ 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 #-}
+
diff --git a/ADP/Fusion/Chr.hs b/ADP/Fusion/Chr.hs
deleted file mode 100644
--- a/ADP/Fusion/Chr.hs
+++ /dev/null
@@ -1,306 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-module ADP.Fusion.Chr where
-
-import Data.Array.Repa.Index
-import Data.Strict.Tuple
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-import qualified Data.Vector.Generic as VG
-import Data.Strict.Maybe
-import Prelude hiding (Maybe(..))
-
-import Data.Array.Repa.Index.Subword
-
-import ADP.Fusion.Classes
-
-import Debug.Trace
-
-
-
--- | Parses a single character.
-
-chr xs = GChr (VG.unsafeIndex) xs
-{-# INLINE chr #-}
-
--- | Parses a single character and returns the character to the left in a
--- strict Maybe.
-
-chrLeft xs = GChr f xs where
-  f xs k = ( xs VG.!? (k-1)
-           , VG.unsafeIndex xs k
-           )
-  {-# INLINE f #-}
-{-# INLINE chrLeft #-}
-
--- With default character
-
-chrLeftD d xs = GChr f xs where
-  f xs k = ( Prelude.maybe d id $ xs VG.!? (k-1)
-           , VG.unsafeIndex xs k
-           )
-  {-# INLINE f #-}
-{-# INLINE chrLeftD #-}
-
--- | Parses a single character and returns the character to the right in a
--- strict Maybe.
-
-chrRight xs = GChr f xs where
-  f xs k = ( VG.unsafeIndex xs k
-           , xs VG.!? (k+1)
-           )
-  {-# INLINE f #-}
-{-# INLINE chrRight #-}
-
--- | A generic Character parser that reads a single character but allows
--- passing additional information.
-
-data GChr r x where -- = forall v . VG.Vector v x =>
-  GChr :: VG.Vector v x => !(v x -> Int -> r) -> !(v x) -> GChr r x
-
-instance Build (GChr r x)
-
-instance
-  ( ValidIndex ls Subword
-  ) => ValidIndex (ls :!: GChr r x) Subword where
-    validIndex (ls :!: GChr _ xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-      i>=a && j<=VG.length xs -c && i+b<=j && validIndex ls abc ij
-    {-# INLINE validIndex #-}
-    getParserRange (ls :!: GChr _ _) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+1:!:max 0 (c-1))
-    {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: GChr r x) Subword where
-    data Elm (ls :!: GChr r x) Subword = ElmGChr !(Elm ls Subword) !r !Subword
-    type Arg (ls :!: GChr r x) = Arg ls :. r
-    getArg !(ElmGChr ls x _) = getArg ls :. x
-    getIdx !(ElmGChr _ _ idx) = idx
-    {-# INLINE getArg #-}
-    {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: GChr r x) Subword where
-  mkStream !(ls :!: GChr f xs) Outer !ij@(Subword (i:.j)) =
-    let dta = f xs (j-1)
-    in  dta `seq` S.map (\s -> ElmGChr s dta (subword (j-1) j)) $ mkStream ls Outer (subword i $ j-1)
-  mkStream !(ls :!: GChr f xs) (Inner cnc szd) !ij@(Subword (i:.j))
-    = S.map (\s -> let Subword (k:.l) = getIdx s
-                   in  ElmGChr s (f xs l) (subword l $ l+1)
-            )
-    $ mkStream ls (Inner cnc szd) (subword i $ j-1)
-  {-# INLINE mkStream #-}
-
--- | Wrapping a GChr to allow zero/one behaviour. Parses a character (or not)
--- in a strict maybe.
-
-newtype ZeroOne r x = ZeroOne { unZeroOne :: GChr r x }
-
-zoLeft xs = ZeroOne $ chrLeft xs
-{-# INLINE zoLeft #-}
-
-
-
--- | Generalized peek.
-
-data GPeek r x = GPeek !(VU.Vector x -> Int -> r) !(VU.Vector x) !(Int:!:Int)
-
-instance Build (GPeek r x)
-
-instance
-  ( ValidIndex ls Subword
-  , VU.Unbox x
-  ) => ValidIndex (ls :!: GPeek r x) Subword where
-    validIndex (ls :!: GPeek _ xs _) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-      i>=a && j<VU.length xs -c && i+b<=j && validIndex ls abc ij
-    {-# INLINE validIndex #-}
-    getParserRange (ls :!: GPeek _ _ (a':!:c')) ix =
-      let (a:!:b:!:c) = getParserRange ls ix in (a+a' :!: b :!: (c+c'))
-    {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: GPeek r x) Subword where
-    data Elm (ls :!: GPeek r x) Subword = ElmGPeek !(Elm ls Subword) !r !Subword
-    type Arg (ls :!: GPeek r x) = Arg ls :. r
-    getArg !(ElmGPeek ls x _) = getArg ls :. x
-    getIdx !(ElmGPeek _ _ idx) = idx
-    {-# INLINE getArg #-}
-    {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , VU.Unbox x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: GPeek r x) Subword where
-  mkStream !(ls :!: GPeek f xs _) Outer !ij@(Subword (i:.j)) =
-    let dta = f xs (j-1)
-    in  dta `seq` S.map (\s -> ElmGPeek s dta (subword j j)) $ mkStream ls Outer ij
-  mkStream !(ls :!: GPeek f xs _) (Inner cnc szd) !ij@(Subword (i:.j))
-    = S.map (\s -> let (Subword (k:.l)) = getIdx s
-                   in  ElmGPeek s (f xs (l-1)) (subword l l)
-            )
-    $ mkStream ls (Inner cnc szd) ij
-  {-# INLINE mkStream #-}
-
-
-{-
--- * Parse a single character.
-
-data Chr x = Chr !(VU.Vector x)
-
---chr = Chr
---{-# INLINE chr #-}
-
-instance
-  ( ValidIndex ls Subword
-  , VU.Unbox xs
-  ) => ValidIndex (ls :!: Chr xs) Subword where
-    validIndex (ls :!: Chr xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-      let
-      in  i>=a && j<VU.length xs -c && i+b<=j && validIndex ls abc ij
-    {-# INLINE validIndex #-}
-    getParserRange (ls :!: Chr xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+1:!:max 0 (c-1))
-    {-# INLINE getParserRange #-}
-
-instance Build (Chr x)
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: Chr x) Subword where
-  data Elm (ls :!: Chr x) Subword = ElmChr !(Elm ls Subword) !x !Subword
-  type Arg (ls :!: Chr x) = Arg ls :. x
-  getArg !(ElmChr ls x _) = getArg ls :. x
-  getIdx !(ElmChr _ _ idx) = idx
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
--- |
---
--- For 'Outer' cases, we extract the data, 'seq' it and then stream. This moves
--- extraction out of the loop.
-
-instance
-  ( Monad m
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: Chr x) Subword where
-  mkStream !(ls :!: Chr xs) Outer !ij@(Subword(i:.j)) =
-    let dta = VG.unsafeIndex xs (j-1)
-    in  dta `seq` S.map (\s -> ElmChr s dta (subword (j-1) j)) $ mkStream ls Outer (subword i $ j-1)
-  mkStream !(ls :!: Chr xs) (Inner cnc szd) !ij@(Subword(i:.j))
-    = S.map (\s -> let (Subword (k:.l)) = getIdx s
-                   in  ElmChr s (VG.unsafeIndex xs l) (subword l $ l+1)
-            )
-    $ mkStream ls (Inner cnc szd) (subword i $ j-1)
-  {-# INLINE mkStream #-}
--}
-
-
-
--- * Peeking to the left
-
-data PeekL x = PeekL !(VU.Vector x)
-
-peekL = PeekL
-{-# INLINE peekL #-}
-
-instance Build (PeekL x)
-
-instance
-  ( ValidIndex ls Subword
-  , VU.Unbox x
-  ) => ValidIndex (ls :!: PeekL x) Subword where
-  validIndex (ls :!: PeekL xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: PeekL xs) ix = let (a:!:b:!:c) = getParserRange ls ix in if b==0 then (a+1:!:b:!:c) else (a:!:b:!:c)
-  {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: PeekL x) Subword where
-  data Elm (ls :!: PeekL x) Subword = ElmPeekL !(Elm ls Subword) !x !Subword
-  type Arg (ls :!: PeekL x) = Arg ls :. x
-  getArg !(ElmPeekL ls x _) = getArg ls :. x
-  getIdx !(ElmPeekL _ _ idx) = idx
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , VU.Unbox x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: PeekL x) Subword where
-  mkStream !(ls :!: PeekL xs) Outer !ij@(Subword(i:.j)) =
-    let dta = VU.unsafeIndex xs (j-1)
-    in  dta `seq` S.map (\s -> ElmPeekL s dta (subword j j)) $ mkStream ls Outer ij
-  mkStream !(ls :!: PeekL xs) (Inner cnc szd) !ij@(Subword(i:.j))
-    = S.map (\s -> let (Subword (k:.l)) = getIdx s
-                   in  ElmPeekL s (VU.unsafeIndex xs $ l-1) (subword l l)
-            )
-    $ mkStream ls (Inner cnc szd) ij
-  {-# INLINE mkStream #-}
-
-
-
--- * Peeking to the right
-
-data PeekR x = PeekR !(VU.Vector x)
-
-peekR = PeekR
-{-# INLINE peekR #-}
-
-instance Build (PeekR x)
-
-instance
-  ( ValidIndex ls Subword
-  , VU.Unbox x
-  ) => ValidIndex (ls :!: PeekR x) Subword where
-  validIndex (ls :!: PeekR xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: PeekR xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b:!:c+1)
-  {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: PeekR x) Subword where
-  data Elm (ls :!: PeekR x) Subword = ElmPeekR !(Elm ls Subword) !x !Subword
-  type Arg (ls :!: PeekR x) = Arg ls :. x
-  getArg !(ElmPeekR ls x _) = getArg ls :. x
-  getIdx !(ElmPeekR _ _ idx) = idx
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , VU.Unbox x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: PeekR x) Subword where
-  mkStream !(ls :!: PeekR xs) Outer !ij@(Subword(i:.j)) =
-    let dta = VU.unsafeIndex xs j
-    in  dta `seq` S.map (\s -> ElmPeekR s dta (subword j j)) $ mkStream ls Outer ij
-  mkStream !(ls :!: PeekR xs) (Inner cnc szd) !ij@(Subword(i:.j))
-    = S.map (\s -> let (Subword (k:.l)) = getIdx s
-                   in  ElmPeekR s (VU.unsafeIndex xs l) (subword l l)
-            )
-    $ mkStream ls (Inner cnc szd) ij
-  {-# INLINE mkStream #-}
-
diff --git a/ADP/Fusion/Classes.hs b/ADP/Fusion/Classes.hs
deleted file mode 100644
--- a/ADP/Fusion/Classes.hs
+++ /dev/null
@@ -1,396 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-module ADP.Fusion.Classes where
-
-import Data.Array.Repa.Index
-import Data.Strict.Maybe
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Size
-import Prelude hiding (Maybe(..))
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Prelude as P
-
-import Data.Array.Repa.Index.Subword
-import Data.Array.Repa.Index.Outside
-import Data.Array.Repa.Index.Points
-
-
-
--- * Data and type constructors
-
--- | The Inner/Outer handler. We encode three states. We are in 'Outer' or
--- right-most position, or 'Inner' position. The 'Inner' position encodes if
--- loop conditional 'CheckNoCheck' need to be performed.
---
--- In f <<< Z % table % table, the two tables already perform a conditional
--- branch, so that Z/table does not have to check boundary conditions.
---
--- In f <<< Z % table % char, no check is performed in table/char, so Z/table
--- needs to perform a boundary check.
-
-data CheckNoCheck
-  = Check
-  | NoCheck
-  deriving (Eq,Show)
-
-data InnerOuter
-  = Inner !CheckNoCheck !(Maybe Int)
-  | Outer
-  deriving (Eq,Show)
-
-data ENE
-  = EmptyT
-  | NonEmptyT
-  | ZeroT
-  deriving (Eq,Show)
-
-
-
--- * Classes
-
--- |
-
-class Elms x i where
-  data Elm x i :: *
-  type Arg x :: *
-  getArg :: Elm x i -> Arg x
-  getIdx :: Elm x i -> i
-
--- |
-
-class Index i where
-  type InOut  i :: *
-  type ENZ    i :: *
-  type PartialIndex i :: *
-  type ParserRange i :: *
-  outer :: i -> InOut i
-  leftPartialIndex  :: i -> PartialIndex i
-  rightPartialIndex :: i -> PartialIndex i
-  fromPartialIndices :: PartialIndex i -> PartialIndex i -> i
-
-class EmptyENZ enz where
-  toEmptyENZ    :: enz -> enz
-  toNonEmptyENZ :: enz -> enz
-
--- |
-
-class (Monad m) => MkStream m x i where
-  mkStream :: x -> InOut i -> i -> S.Stream m (Elm x i)
-
--- | Build the stack using (%)
-
-class Build x where
-  type Stack x :: *
-  type Stack x = Z :!: x
-  build :: x -> Stack x
-  default build :: (Stack x ~ (Z :!: x)) => x -> Stack x
-  build x = Z :!: x
-  {-# INLINE build #-}
-
--- | 'ValidIndex', via 'validIndex' statically checks if an index 'i' is valid
--- for a stack of terminals and non-terminals 'x'. 'validIndex' is used to
--- short-circuit streams via 'outerCheck'.
-
-class (Index i) => ValidIndex x i where
-  validIndex :: x -> ParserRange i -> i -> Bool
-  getParserRange :: x -> i -> ParserRange i
-
-
-
--- * Helper functions
-
--- | Correct wrapping of 'validIndex' and 'getParserRange'.
-
-checkValidIndex x i = validIndex x (getParserRange x i) i
-{-# INLINE checkValidIndex #-}
-
--- | 'outerCheck' acts as a static filter. If 'b' is true, we keep all stream
--- elements. If 'b' is false, we discard all stream elements.
-
-outerCheck :: Monad m => Bool -> S.Stream m a -> S.Stream m a
-outerCheck b (S.Stream step sS n) = b `seq` S.Stream snew (Left (b,sS)) Unknown where
-  {-# INLINE [1] snew #-}
-  snew (Left  (False,s)) = return $ S.Done
-  snew (Left  (True ,s)) = return $ S.Skip (Right s)
-  snew (Right s        ) = do r <- step s
-                              case r of
-                                S.Yield x s' -> return $ S.Yield x (Right s')
-                                S.Skip    s' -> return $ S.Skip    (Right s')
-                                S.Done       -> return $ S.Done
-{-# INLINE outerCheck #-}
-
-
-
--- * Instances
-
-
-
--- ** Unsorted
-
-instance EmptyENZ ENE where
-  toEmptyENZ ene  | ene==NonEmptyT = EmptyT
-                  | otherwise      = ene
-  toNonEmptyENZ ene | ene==EmptyT  = NonEmptyT
-                    | otherwise    = ene
-  {-# INLINE toEmptyENZ #-}
-  {-# INLINE toNonEmptyENZ #-}
-
-
-
--- ** PointL
-
-instance Index PointL where
-  type InOut PointL = InnerOuter
-  type ENZ   PointL = ENE
-  type PartialIndex PointL = Int
-  type ParserRange  PointL = (Int:!:Int:!:Int)
-  outer _ = Outer
-  leftPartialIndex (PointL (i:.j)) = i
-  rightPartialIndex (PointL (i:.j)) = j
-  fromPartialIndices i j = pointL i j
-  {-# INLINE outer #-}
-  {-# INLINE leftPartialIndex #-}
-  {-# INLINE rightPartialIndex #-}
-  {-# INLINE fromPartialIndices #-}
-
-instance ValidIndex Z PointL where
-  {-# INLINE validIndex #-}
-  {-# INLINE getParserRange #-}
-  validIndex _ _ _ = True
-  getParserRange _ _ = (0 :!: 0 :!: 0)
-
-
-
--- ** 'Subword'
-
-instance Index Subword where
-  type InOut Subword = InnerOuter
-  type ENZ   Subword = ENE
-  type PartialIndex Subword = Int
-  type ParserRange Subword = (Int :!: Int :!: Int)
-  outer _ = Outer
-  leftPartialIndex (Subword (i:.j)) = i
-  rightPartialIndex (Subword (i:.j)) = j
-  fromPartialIndices i j = subword i j
-  {-# INLINE outer #-}
-  {-# INLINE leftPartialIndex #-}
-  {-# INLINE rightPartialIndex #-}
-  {-# INLINE fromPartialIndices #-}
-
--- | The bottom of every stack of RHS arguments in a grammar.
-
-instance
-  ( Monad m
-  ) => MkStream m Z Subword where
-  mkStream Z Outer !(Subword (i:.j)) = S.unfoldr step i where
-    step !k
-      | k==j      = P.Just $ (ElmZ (subword i i), j+1)
-      | otherwise = P.Nothing
-  mkStream Z (Inner NoCheck Nothing)  !(Subword (i:.j)) = S.singleton $ ElmZ $ subword i i
-  mkStream Z (Inner NoCheck (Just z)) !(Subword (i:.j)) = S.unfoldr step i where
-    step !k
-      | k<=j && k+z>=j = P.Just $ (ElmZ (subword i i), j+1)
-      | otherwise      = P.Nothing
-  mkStream Z (Inner Check Nothing)   !(Subword (i:.j)) = S.unfoldr step i where
-    step !k
-      | k<=j      = P.Just $ (ElmZ (subword i i), j+1)
-      | otherwise = P.Nothing
-  mkStream Z (Inner Check (Just z)) !(Subword (i:.j)) = S.unfoldr step i where
-    step !k
-      | k<=j && k+z>=j = P.Just $ (ElmZ (subword i i), j+1)
-      | otherwise      = P.Nothing
-  {-# INLINE mkStream #-}
-
-instance ValidIndex Z Subword where
-  {-# INLINE validIndex #-}
-  {-# INLINE getParserRange #-}
-  validIndex _ _ _ = True
-  getParserRange _ _ = (0 :!: 0 :!: 0)
-
-
-
--- ** Outside
-
-instance Index Outside where
-  type InOut Outside = InnerOuter
-  type ENZ   Outside = ENE
-  type PartialIndex Outside = Int
-  type ParserRange Outside = (Int :!: Int :!: Int)
-  outer _ = Outer
-  leftPartialIndex (Outside (i:.j)) = error "outside: not sure yet" -- i
-  rightPartialIndex (Outside (i:.j)) = error "outside: not sure yet" -- j
-  fromPartialIndices i j = error "outside: not sure yet" -- outside i j
-  {-# INLINE outer #-}
-  {-# INLINE leftPartialIndex #-}
-  {-# INLINE rightPartialIndex #-}
-  {-# INLINE fromPartialIndices #-}
-
--- | The bottom of every stack of RHS arguments in a grammar.
-
-instance
-  ( Monad m
-  ) => MkStream m Z Outside where
-  {-
-  mkStream Z Outer !(Outside (i:.j)) = S.unfoldr step i where
-    step !k
-      | k==j      = P.Just $ (ElmZ (outside i i), j+1)
-      | otherwise = P.Nothing
-  mkStream Z (Inner NoCheck Nothing)  !(Outside (i:.j)) = S.singleton $ ElmZ $ outside i i
-  mkStream Z (Inner NoCheck (Just z)) !(Outside (i:.j)) = S.unfoldr step i where
-    step !k
-      | k<=j && k+z>=j = P.Just $ (ElmZ (outside i i), j+1)
-      | otherwise      = P.Nothing
-  mkStream Z (Inner Check Nothing)   !(Outside (i:.j)) = S.unfoldr step i where
-    step !k
-      | k<=j      = P.Just $ (ElmZ (outside i i), j+1)
-      | otherwise = P.Nothing
-  mkStream Z (Inner Check (Just z)) !(Outside (i:.j)) = S.unfoldr step i where
-    step !k
-      | k<=j && k+z>=j = P.Just $ (ElmZ (outside i i), j+1)
-      | otherwise      = P.Nothing
-  {-# INLINE mkStream #-}
-  -}
-
-instance ValidIndex Z Outside where
-  {-# INLINE validIndex #-}
-  {-# INLINE getParserRange #-}
-  validIndex _ _ _ = True
-  getParserRange _ _ = (0 :!: 0 :!: 0)
-
-
-
--- ** 'Z'
-
-instance Index Z where
-  type InOut Z = Z
-  type ENZ   Z = Z
-  type PartialIndex Z = Z
-  type ParserRange Z = Z
-  outer Z = Z
-  leftPartialIndex Z = Z
-  rightPartialIndex Z = Z
-  fromPartialIndices Z Z = Z
-  {-# INLINE outer #-}
-  {-# INLINE leftPartialIndex #-}
-  {-# INLINE rightPartialIndex #-}
-  {-# INLINE fromPartialIndices #-}
-
-instance EmptyENZ Z where
-  toEmptyENZ _ = Z
-  toNonEmptyENZ _ = Z
-  {-# INLINE toEmptyENZ #-}
-  {-# INLINE toNonEmptyENZ #-}
-
-instance
-  (
-  ) => Elms Z ix where
-  data Elm Z ix = ElmZ !ix
-  type Arg Z = Z
-  getArg !(ElmZ _) = Z
-  getIdx !(ElmZ ix) = ix
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance Monad m => MkStream m Z Z where
-  mkStream _ _ _ = S.singleton (ElmZ Z)
-  {-# INLINE mkStream #-}
-
-instance ValidIndex Z Z where
-  {-# INLINE validIndex #-}
-  {-# INLINE getParserRange #-}
-  validIndex _ _ _ = True
-  getParserRange _ _ = Z
-
-
-
--- * Multi-dim instances
-
--- ** '(is:.i)'
-
-instance (Index is, Index i) => Index (is:.i) where
-  type InOut (is:.i) = InOut is :. InOut i
-  type ENZ   (is:.i) = ENZ   is :. ENZ i
-  type PartialIndex (is:.i) = PartialIndex is :. PartialIndex i
-  type ParserRange (is:.i) = ParserRange is :. ParserRange i
-  outer (is:.i) = outer is :. outer i
-  leftPartialIndex (is:.i) = leftPartialIndex is :. leftPartialIndex i
-  rightPartialIndex (is:.i) = rightPartialIndex is :. rightPartialIndex i
-  fromPartialIndices (is:.i) (js:.j) = fromPartialIndices is js :. fromPartialIndices i j
-  {-# INLINE outer #-}
-  {-# INLINE leftPartialIndex #-}
-  {-# INLINE rightPartialIndex #-}
-  {-# INLINE fromPartialIndices #-}
-
-instance (EmptyENZ es, EmptyENZ e) => EmptyENZ (es:.e) where
-  toEmptyENZ (es:.e) = toEmptyENZ es :. toEmptyENZ e
-  toNonEmptyENZ (es:.e) = toNonEmptyENZ es :. toNonEmptyENZ e
-  {-# INLINE toEmptyENZ #-}
-  {-# INLINE toNonEmptyENZ #-}
-
-instance (ValidIndex Z is, ValidIndex Z i) => ValidIndex Z (is:.i) where
-  {-# INLINE validIndex #-}
-  {-# INLINE getParserRange #-}
-  validIndex _ _ _ = True
-  getParserRange Z (is:.i) = getParserRange Z is :. getParserRange Z i
-
-
-
--- ** multi-dim with Subword
-
-instance
-  ( Monad m
-  , MkStream m Z is
-  ) => MkStream m Z (is:.Subword) where
-  mkStream Z (io:.Outer) (is:.Subword (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i==j) $ mkStream Z io is
-  mkStream Z (io:.Inner NoCheck Nothing) (is:.Subword (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) $ mkStream Z io is
-  mkStream Z (io:.Inner NoCheck (Just z)) (is:.Subword (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
-  mkStream Z (io:.Inner Check Nothing) (is:.Subword (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j) $ mkStream Z io is
-  mkStream Z (io:.Inner Check (Just z)) (is:.Subword (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.subword i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
-  {-# INLINE mkStream #-}
-
-
-
--- ** multi-dim with PointL
-
--- TODO automatically created, check correctness
-
-instance
-  ( Monad m
-  , MkStream m Z is
-  ) => MkStream m Z (is:.PointL) where
-  mkStream Z (io:.Outer) (is:.PointL (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i==j) $ mkStream Z io is
-  mkStream Z (io:.Inner NoCheck Nothing) (is:.PointL (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) $ mkStream Z io is
-  mkStream Z (io:.Inner NoCheck (Just z)) (is:.PointL (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
-  mkStream Z (io:.Inner Check Nothing) (is:.PointL (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j) $ mkStream Z io is
-  mkStream Z (io:.Inner Check (Just z)) (is:.PointL (i:.j))
-    = S.map (\(ElmZ jt) -> ElmZ (jt:.pointL i i)) . S.filter (const $ i<=j && i+z>=j) $ mkStream Z io is
-  {-# INLINE mkStream #-}
-
-
-
-
-
--- * Special instances
-
-instance Build x => Build (x:!:y) where
-  type Stack (x:!:y) = Stack x :!: y
-  build (x:!:y) = build x :!: y
-  {-# INLINE build #-}
-
diff --git a/ADP/Fusion/Empty.hs b/ADP/Fusion/Empty.hs
deleted file mode 100644
--- a/ADP/Fusion/Empty.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-module ADP.Fusion.Empty where
-
-import Data.Array.Repa.Index
-import Data.Strict.Maybe
-import Data.Strict.Tuple
-import Prelude hiding (Maybe(..))
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import Data.Array.Repa.Index.Subword
-
-import ADP.Fusion.Classes
-
-
-
-data Empty = Empty
-
-empty = Empty
-{-# INLINE empty #-}
-
-instance
-  ( ValidIndex ls Subword
-  ) => ValidIndex (ls :!: Empty) Subword where
-    validIndex (ls:!:Empty) abc ij@(Subword (i:.j)) = i==j && validIndex ls abc ij
-    {-# INLINE validIndex #-}
-
-instance Build Empty
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: Empty) Subword where
-  data Elm (ls :!: Empty) Subword = ElmEmpty !(Elm ls Subword) !() !Subword
-  type Arg (ls :!: Empty) = Arg ls :. ()
-  getArg !(ElmEmpty ls () _) = getArg ls :. ()
-  getIdx !(ElmEmpty _ _ i)   = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls:!:Empty) Subword where
-  mkStream !(ls:!:Empty) Outer !ij@(Subword (i:.j))
-    = S.map (\s -> ElmEmpty s () (subword i j))
-    $ S.filter (\_ -> i==j)
-    $ mkStream ls Outer ij
-  {-# INLINE mkStream #-}
-
diff --git a/ADP/Fusion/Examples/Palindrome.hs b/ADP/Fusion/Examples/Palindrome.hs
deleted file mode 100644
--- a/ADP/Fusion/Examples/Palindrome.hs
+++ /dev/null
@@ -1,118 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module ADP.Fusion.Examples.Palindrome where
-
-import Data.Vector.Fusion.Stream.Monadic (Stream (..))
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-import qualified Data.Vector as V
-import Data.Array.Repa.Index
-import Control.Monad
-import Control.Monad.Trans.Class
-import qualified Control.Monad.Trans.Writer.Lazy as W
-import qualified Control.Arrow as A
-
-import Data.PrimitiveArray as PA
-import Data.PrimitiveArray.Zero as PA
-
-import ADP.Fusion hiding (empty)
-import ADP.Fusion.Empty hiding (empty)
-import ADP.Fusion.Chr
-import ADP.Fusion.Table
-import Data.Array.Repa.Index.Subword
-import ADP.Fusion.TH
-
-
-
-data SignatureT m x r = Signature
-  { pair  :: Char -> x -> Char -> x
-  , empty :: () -> x
-  , h     :: Stream m x -> m r
-  }
-
--- makeAlgebraProduct ''SignatureT
-
-{-
-
--- gPalindrome :: Signature m x -> Empty -> Char -> tbl -> (tbl, Subword -> m x)
-
-gPalindrome Signature{..} e c s =
-  ( s, (  empty <<< e         |||
-          pair  <<< c % s % c ... h
-       )
-  )
-{-# INLINE gPalindrome #-}
-
-
-
-aPair :: Monad m => Signature m Int Int
-aPair = Signature
-  { pair = \l x r -> if l==r then (x+4983) else -999999
-  , empty = \() -> 4711
-  , h = S.foldl' max (-888888)
-  }
-{-# INLINE aPair #-}
-
-aPretty :: Monad m => Signature m String (Stream m String)
-aPretty = Signature
-  { pair = \l x r -> "(" ++ x ++ ")"
-  , empty = \() -> ""
-  , h = return . id
-  }
-
-(<**) :: (Monad m, CombElem x' x) => Signature m x x' -> Signature m y y' -> Signature m (x,Stream m y) y'
-(<**) x y = Signature
-  { pair = \l (zx,zy) r -> (pair x l zx r, S.map (\z -> pair y l z r) zy)
-  , empty = \() -> (empty x (), S.singleton $ empty y ())
-  , h = \zs -> do hfst <- h x $ S.map fst zs
-                  h y $ S.concatMap snd . S.filter (combElem hfst . fst) $ zs
-  }
-{-# INLINE (<**) #-}
-
-(***) :: (Monad m) => Signature m x x' -> Signature m y y' -> Signature m (x,y) (x',y')
-(***) x y = Signature
-  { pair = \l (zx,zy) r -> (pair x l zx r, pair y l zy r)
-  , empty = \() -> (empty x (), empty y ())
---  , h = \zs -> do hfst <- h x $ S.map fst zs
---                  let phfs = S.concatMap snd . S.filter (combElem hfst . fst) $ zs
---                  hsnd <- h y phfs
-  }
-{-# INLINE (***) #-}
-
-class CombElem x y where
-  combElem :: x -> y -> Bool
-
-instance (Eq x) => CombElem x x where
-  combElem = (==)
-
-instance (VU.Unbox x, Eq x) => CombElem (VU.Vector x) x where
-  combElem xs y = VU.elem y xs
-
-instance (Eq x) => CombElem (V.Vector x) x where
-  combElem xs y = V.elem y xs
-
-palindromeFill :: VU.Vector Char -> IO (PA.Unboxed (Z:.Subword) Int)
-palindromeFill inp = do
-  let n = VU.length inp
-  !t' <- newWithM (Z:.subword 0 0) (Z:.subword 0 n) 0
-  let t= mTblSw EmptyT t'
-  let b = chr inp
-  let e = Empty
-  fillTable $ gPalindrome aPair e b t
-  freeze t'
-{-# NOINLINE palindromeFill #-}
-
-fillTable (MTbl _ tbl, f) = do
-  let (_,Z:.Subword (0:.n)) = boundsM tbl
-  forM_ [n,n-1..0] $ \i -> forM_ [i..n] $ \j -> do
-    (f $ subword i j) >>= writeM tbl (Z:.subword i j)
-{-# INLINE fillTable #-}
-
--}
-
diff --git a/ADP/Fusion/Examples/TwoDim.hs b/ADP/Fusion/Examples/TwoDim.hs
deleted file mode 100644
--- a/ADP/Fusion/Examples/TwoDim.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeOperators #-}
-
--- | This is not really a working example, but rather to check the GHC-Core for
--- fusion.
-
---module ADP.Fusion.Examples.TwoDim where
-module Main where
-
-import Data.Vector.Fusion.Stream.Monadic (Stream (..))
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-import qualified Data.Vector as V
-import Data.Array.Repa.Index
-import Control.Monad
-import Control.Monad.Trans.Class
-import qualified Control.Monad.Trans.Writer.Lazy as W
-import qualified Control.Arrow as A
-import System.IO.Unsafe (unsafePerformIO)
-import Control.Applicative
-
-import Data.Array.Repa.Index.Points
-import Data.PrimitiveArray as PA
-import Data.PrimitiveArray.Zero as PA
-
-import ADP.Fusion hiding (empty)
-import ADP.Fusion.Empty hiding (empty)
-import ADP.Fusion.Chr
-import ADP.Fusion.Table
-import ADP.Fusion.Multi
-import Data.Array.Repa.Index.Subword
-import ADP.Fusion.TH
-
-
-
-main = do
-  ls <- lines <$> getContents
-  align ls
-
-align [] = return ()
-align [c] = error "single last line"
-align (a:b:xs) = do
-  putStrLn a
-  putStrLn b
-  print $ needlemanWunsch (VU.fromList a) (VU.fromList b)
-  align xs
-
-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
-  }
-
--- grammar :: Signature m x r c -> ???
-grammar Signature{..} a i1 i2 =
-  ( a, step_step <<< a % (T:!chr i1:!chr i2) |||
-       step_loop <<< a % (T:!chr i1:!None  ) |||
-       loop_step <<< a % (T:!None  :!chr i2) |||
-       nil_nil   <<< (T:!Empty:!Empty)       ... h
-  )
-{-# INLINE grammar #-}
-
-sScore :: Monad m => Signature m Int Int Char
-sScore = Signature
-  { step_step = \x (Z:.a:.b) -> if a==b then x+1 else x-1
-  , step_loop = \x _         -> x-1
-  , loop_step = \x _         -> x-1
-  , nil_nil   = const 0
-  , h = S.foldl' max 0
-  }
-{-# INLINE sScore #-}
-
-needlemanWunsch i1 i2 = (ws ! (Z:.pointL 0 n1:.pointL 0 n2), bt) where
-  ws = unsafePerformIO (forwardPhase i1 i2)
-  n1 = VU.length i1
-  n2 = VU.length i2
-  bt = [] :: String
-{-# NOINLINE needlemanWunsch #-}
-
-forwardPhase :: VU.Vector Char -> VU.Vector Char -> IO (PA.Unboxed (Z:.PointL:.PointL) Int)
-forwardPhase i1 i2 = do
-  let n1 = VU.length i1
-  let n2 = VU.length i2
-  !t' <- newWithM (Z:.pointL 0 0:.pointL 0 0) (Z:.pointL 0 n1:.pointL 0 n2) 0
-  let t= mTbl (Z:.EmptyT:.EmptyT) t'
-  fillTable $ grammar sScore t i1 i2
-  freeze t'
-{-# INLINE forwardPhase #-}
-
-fillTable (MTbl _ tbl, f) = do
-  let (_,Z:.PointL(0:.n1):.PointL(0:.n2)) = boundsM tbl
-  forM_ [0 .. n1] $ \k1 -> forM_ [0 .. n2] $ \k2 -> do
-    (f $ Z:.pointL 0 k1:.pointL 0 k2) >>= writeM tbl (Z:.pointL 0 k1:.pointL 0 k2)
-{-# INLINE fillTable #-}
-
diff --git a/ADP/Fusion/Multi.hs b/ADP/Fusion/Multi.hs
deleted file mode 100644
--- a/ADP/Fusion/Multi.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE UnicodeSyntax #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeOperators #-}
-
--- | The multi-tape extension of ADPfusion. Just re-exports everything.
-
-module ADP.Fusion.Multi
-  ( module ADP.Fusion.Multi.Classes
-  , module ADP.Fusion.Multi.Empty
-  , module ADP.Fusion.Multi.GChr
-  , module ADP.Fusion.Multi.None
-  ) where
-
-import ADP.Fusion.Multi.Classes
-import ADP.Fusion.Multi.None
-import ADP.Fusion.Multi.GChr
-import ADP.Fusion.Multi.Empty
-
-
-
-{-
-type instance TermOf (Term ts (ZeroOne r xs)) = TermOf ts :. Maybe r
-
-instance
-  ( TermValidIndex ts is
-  ) => TermValidIndex (Term ts (ZeroOne r xs)) (is:.PointL) where
-  termDimensionsValid (ts:!ZeroOne (gchr)) = termDimensionsValid (ts:!gchr)
-  {-
-  getTermParserRange (ts:!
-  -}
-
-
-
-
--- The experimental zero/one wrapper
-
-instance
-  ( Monad m
-  , TermElm m ts is
-  ) => TermElm m (Term ts (ZeroOne r xs)) (is:.PointL) where
-  termStream (ts:!(ZeroOne (GChr f xs))) (io:.o) (is:.ij@(PointL(i:.j)))
-    = doubleStream
-    . termStream (ts:!GChr f xs) (io:.o) (is:.ij)
-    where
-      {-# INLINE doubleStream #-}
-      doubleStream (S.Stream step sS n) = S.Stream sNew (Left sS) (2*n) where
-        {-# INLINE [1] sNew #-}
-        sNew (Left s) = do r <- step s
-                           case r of
-                             S.Yield (abc:!:(es:.e)) s' -> return $ S.Yield (abc:!:(es:.Just e)) (Right s')
-                             S.Skip                  s' -> return $ S.Skip                       (Left  s')
-                             S.Done                     -> return $ S.Done
-        sNew (Right s) = do r <- step s
-                            case r of
-                              S.Yield (abc:!:(es:.e)) s' -> return $ S.Yield (abc:!:(es:.Nothing)) (Left s')
---                              S.Skip                  s' -> return $ S.Skip                        (Left s')
---                              S.Done                     -> return $ S.Done
-  {-# INLINE termStream #-}
--}
-
-
--- Empty
-
diff --git a/ADP/Fusion/Multi/Classes.hs b/ADP/Fusion/Multi/Classes.hs
deleted file mode 100644
--- a/ADP/Fusion/Multi/Classes.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module ADP.Fusion.Multi.Classes where
-
-import Data.Array.Repa.Index
-import Data.Strict.Tuple
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import ADP.Fusion.Classes
-
-
-
--- | The zero-th dimension of every terminal parser.
-
-data TermBase = T
-
--- | Combine a terminal parser of dimension k in @a@ with a new 1-dim parser
--- @b@ generating a parser of dimension k+1.
-
-data Term a b = a :! b
-
--- | A 'termStream' extracts all terminal elements from a multi-dimensional
--- terminal symbol.
-
-class
-  ( Monad m
-  ) => TermElm m t ix where
-  termStream :: t -> InOut ix -> ix -> S.Stream m (ze :!: zix :!: ix) -> S.Stream m (ze :!: zix :!: ix :!: TermOf t)
-
--- |
-
-type family TermOf t :: *
-
--- | To calculate parser ranges and index validity we need an additional type
--- class that recurses over the individual 'Term' elements.
-
-class TermValidIndex t i where
-  termDimensionsValid :: t -> ParserRange i -> i -> Bool
-  getTermParserRange  :: t -> i -> ParserRange i -> ParserRange i
-  termInnerOuter :: t -> i -> InOut i -> InOut i
-  termLeftIndex :: t -> i -> i
-
-
-
--- * The instance declarations for generic @Term a b@ data ctors.
-
-instance Build (Term a b)
-
-instance
-  ( ValidIndex ls ix
-  , TermValidIndex (Term a b) ix
-  , Show ix
-  , Show (ParserRange ix)
-  ) => ValidIndex (ls :!: Term a b) ix where
-  validIndex (ls :!: t) abc ix =
-    termDimensionsValid t abc ix && validIndex ls abc ix
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: t) ix = getTermParserRange t ix (getParserRange ls ix)
-  {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls ix
-  ) => Elms (ls :!: Term a b) ix where
-    data Elm (ls :!: Term a b) ix = ElmTerm !(Elm ls ix) !(TermOf (Term a b)) !ix
-    type Arg (ls :!: Term a b) = Arg ls :. (TermOf (Term a b))
-    getArg !(ElmTerm ls x _) = getArg ls :. x
-    getIdx !(ElmTerm _ _ idx) = idx
-    {-# INLINE getArg #-}
-    {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , Elms ls ix
-  , MkStream m ls ix
-  , TermElm m (Term a b) ix
-  , TermValidIndex (Term a b) ix
-  ) => MkStream m (ls :!: Term a b) ix where
-  mkStream !(ls :!: t) !io !ij
-    = S.map (\(s:!:Z:!:zij:!:e) -> ElmTerm s e zij)
-    $ termStream t io ij
-    $ S.map (\s -> (s :!: Z :!: getIdx s))
-    $ mkStream ls (termInnerOuter t ij io) (termLeftIndex t ij)
-  {-# INLINE mkStream #-}
-
-
-
--- * Terminal stream of 'TermBase' with index 'Z'
-
-type instance TermOf TermBase = Z
-
-instance
-  ( Monad m
-  ) => TermElm m (TermBase) Z where
-  termStream T _ Z = S.map (\(zs:!:zix:!:Z) -> (zs:!:zix:!:Z:!:Z))
-  {-# INLINE termStream #-}
-
-instance TermValidIndex TermBase Z where
-  termDimensionsValid T Z Z = True
-  getTermParserRange  T Z Z = Z
-  termInnerOuter T Z Z = Z
-  termLeftIndex T Z = Z
-  {-# INLINE termDimensionsValid #-}
-  {-# INLINE getTermParserRange #-}
-  {-# INLINE termInnerOuter #-}
-  {-# INLINE termLeftIndex #-}
-
diff --git a/ADP/Fusion/Multi/Empty.hs b/ADP/Fusion/Multi/Empty.hs
deleted file mode 100644
--- a/ADP/Fusion/Multi/Empty.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeOperators #-}
-
-module ADP.Fusion.Multi.Empty where
-
-import Data.Array.Repa.Index
-import Data.Strict.Tuple
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import Data.Array.Repa.Index.Points
-
-import ADP.Fusion.Classes
-import ADP.Fusion.Empty
-import ADP.Fusion.Multi.Classes
-
-
-
-type instance TermOf (Term ts Empty) = TermOf ts :. ()
-
-instance
-  ( Monad m
-  , TermElm m ts is
-  ) => TermElm m (Term ts Empty) (is:.PointL) where
-  termStream (ts:!Empty) (io:.Outer) (is:.ij@(PointL(i:.j))) =
-    S.map (\(zs:!:(zix:.kl):!:zis:!:e) -> (zs:!:zix:!:(zis:.kl):!:(e:.())))
-    . S.filter (const (i==j))
-    . termStream ts io is
-    . S.map (\(zs:!:zix:!:(zis:.kl)) -> (zs:!:(zix:.kl):!:zis))
-  {-# INLINE termStream #-}
-
-instance
-  ( TermValidIndex ts is
-  ) => TermValidIndex (Term ts Empty) (is:.PointL) where
-  termDimensionsValid (ts:!Empty) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))
-    = termDimensionsValid ts prs is
-  getTermParserRange (ts:!Empty) (is:._) (prs:.(a:!:b:!:c))
-    = getTermParserRange ts is prs :. (a:!:b:!:c)
-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
-  termLeftIndex  (ts:!_) (is:.ij) = termLeftIndex ts is :. ij
-  {-# INLINE termDimensionsValid #-}
-  {-# INLINE getTermParserRange #-}
-  {-# INLINE termInnerOuter #-}
-  {-# INLINE termLeftIndex #-}
-
diff --git a/ADP/Fusion/Multi/GChr.hs b/ADP/Fusion/Multi/GChr.hs
deleted file mode 100644
--- a/ADP/Fusion/Multi/GChr.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeOperators #-}
-
-module ADP.Fusion.Multi.GChr where
-
-import Data.Array.Repa.Index
-import Data.Strict.Tuple
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Generic as VG
-
-import Data.Array.Repa.Index.Points
-import Data.Array.Repa.Index.Subword
-
-import ADP.Fusion.Chr
-import ADP.Fusion.Classes
-import ADP.Fusion.Multi.Classes
-
-
-type instance TermOf (Term ts (GChr r xs)) = TermOf ts :. r
-
-
-
--- * Multi-dim 'Subword's.
-
--- TODO we want to evaluate @f xs $ j-1@ just once before the stream is
--- generated. Unfortunately, this will evaluate cases like index (-1) as well,
--- which leads to crashes. The code below is safe but slower. We should
--- incorporate a version that performs and @outerCheck@ in the code.
-
-instance
-  ( Monad m
-  , TermElm m ts is
-  ) => TermElm m (Term ts (GChr r xs)) (is:.Subword) where
-  termStream (ts :! GChr f xs) (io:.Outer) (is:.ij@(Subword(i:.j)))
-    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.subword (j-1) j) :!: (e:.(f xs $ j-1))))
-    . termStream ts io is
-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
-  termStream (ts :! GChr f xs) (io:.Inner _ _) (is:.ij)
-    = S.map (\(zs :!: (zix:.kl@(Subword(k:.l))) :!: zis :!: e) -> let dta = f xs l in dta `seq` (zs :!: zix :!: (zis:.subword l (l+1)) :!: (e:.dta)))
-    . termStream ts io is
-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
-  {-# INLINE termStream #-}
-
-instance
-  ( TermValidIndex ts is
-  ) => TermValidIndex (Term ts (GChr r xs)) (is:.Subword) where
-  termDimensionsValid (ts:!GChr _ xs) (prs:.(a:!:b:!:c)) (is:.Subword(i:.j))
-    = i>=a && j<=VG.length xs -c && i+b<=j && termDimensionsValid ts prs is
-  getTermParserRange (ts:!GChr _ _) (is:._) (prs:.(a:!:b:!:c))
-    = getTermParserRange ts is prs :. (a:!:b+1:!:max 0 (c-1))
-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
-  termLeftIndex  (ts:!_) (is:.Subword (i:.j)) = termLeftIndex ts is :. subword i (j-1)
-  {-# INLINE termDimensionsValid #-}
-  {-# INLINE getTermParserRange #-}
-  {-# INLINE termInnerOuter #-}
-  {-# INLINE termLeftIndex #-}
-
-
-
--- * Multi-dim 'PointL's
-
--- | NOTE This instance is currently the only one using an "inline outer
--- check". If This behaves well, it could be possible to put checks for valid
--- indices inside the outerCheck function. (Currently disabled, as the compiler
--- chokes on four-way alignments).
-
-instance
-  ( Monad m
-  , TermElm m ts is
-  ) => TermElm m (Term ts (GChr r xs)) (is:.PointL) where
-  termStream (ts :! GChr f xs) (io:.Outer) (is:.ij@(PointL(i:.j)))
-    -- = outerCheck (j>0)
-    -- . let dta = (f xs $ j-1) in dta `seq` S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.pointL (j-1) j) :!: (e:.dta)))
-    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.pointL (j-1) j) :!: (e:.(f xs $ j-1))))
-    . termStream ts io is
-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
-  termStream (ts :! GChr f xs) (io:.Inner _ _) (is:.ij)
-    = S.map (\(zs :!: (zix:.kl@(PointL(k:.l))) :!: zis :!: e) -> let dta = f xs l in dta `seq` (zs :!: zix :!: (zis:.pointL l (l+1)) :!: (e:.dta)))
-    . termStream ts io is
-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
-  {-# INLINE termStream #-}
-
--- TODO auto-generated, check correctness
-
-instance
-  ( TermValidIndex ts is
-  ) => TermValidIndex (Term ts (GChr r xs)) (is:.PointL) where
-  termDimensionsValid (ts:!GChr _ xs) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))
-    = {- i>=a && j<=VG.length xs -c && i+b<=j && -} termDimensionsValid ts prs is
-  getTermParserRange (ts:!GChr _ _) (is:._) (prs:.(a:!:b:!:c))
-    = getTermParserRange ts is prs :. (a:!:b+1:!:max 0 (c-1))
-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
-  termLeftIndex  (ts:!_) (is:.PointL (i:.j)) = termLeftIndex ts is :. pointL i (j-1)
-  {-# INLINE termDimensionsValid #-}
-  {-# INLINE getTermParserRange #-}
-  {-# INLINE termInnerOuter #-}
-  {-# INLINE termLeftIndex #-}
-
diff --git a/ADP/Fusion/Multi/None.hs b/ADP/Fusion/Multi/None.hs
deleted file mode 100644
--- a/ADP/Fusion/Multi/None.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeOperators #-}
-
-module ADP.Fusion.Multi.None where
-
-import Data.Array.Repa.Index
-import Data.Strict.Tuple
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import Data.Array.Repa.Index.Points
-
-import ADP.Fusion.Classes
-import ADP.Fusion.Multi.Classes
-import ADP.Fusion.None
-
-
-
-type instance TermOf (Term ts None) = TermOf ts :. ()
-
-instance
-  ( Monad m
-  , TermElm m ts is
-  ) => TermElm m (Term ts None) (is:.PointL) where
-  termStream (ts :! None) (io:.Outer) (is:.ij@(PointL(i:.j))) =
-    S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.kl) :!: (e:.())))
-    . termStream ts io is
-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
-  termStream (ts :! None) (io:.Inner _ _) (is:.ij)
-    = S.map (\(zs :!: (zix:.kl) :!: zis :!: e) -> (zs :!: zix :!: (zis:.kl) :!: (e:.())))
-    . termStream ts io is
-    . S.map (\(zs :!: zix :!: (zis:.kl)) -> (zs :!: (zix:.kl) :!: zis))
-  {-# INLINE termStream #-}
-
--- TODO auto-gen'ed
-
-instance
-  ( TermValidIndex ts is
-  ) => TermValidIndex (Term ts None) (is:.PointL) where
-  termDimensionsValid (ts:!None) (prs:.(a:!:b:!:c)) (is:.PointL(i:.j))
-    = termDimensionsValid ts prs is
-  getTermParserRange (ts:!None) (is:._) (prs:.(a:!:b:!:c))
-    = getTermParserRange ts is prs :. (a:!:b:!:c)
-  termInnerOuter (ts:!_) (is:._) (ios:.io) = termInnerOuter ts is ios :. io
-  termLeftIndex  (ts:!_) (is:.ij) = termLeftIndex ts is :. ij
-  {-# INLINE termDimensionsValid #-}
-  {-# INLINE getTermParserRange #-}
-  {-# INLINE termInnerOuter #-}
-  {-# INLINE termLeftIndex #-}
-
diff --git a/ADP/Fusion/None.hs b/ADP/Fusion/None.hs
deleted file mode 100644
--- a/ADP/Fusion/None.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-module ADP.Fusion.None where
-
-import Data.Array.Repa.Index
-import Data.Strict.Maybe
-import Data.Strict.Tuple
-import Prelude hiding (Maybe(..))
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-
-import Data.Array.Repa.Index.Subword
-
-import ADP.Fusion.Classes
-
-
-
-data None = None
-
-none = None
-{-# INLINE none #-}
-
--- None is always valid
-
-instance
-  ( ValidIndex ls Subword
-  ) => ValidIndex (ls :!: None) Subword where
-    validIndex (ls:!:None) abc ij@(Subword (i:.j)) = validIndex ls abc ij
-    {-# INLINE validIndex #-}
-
-instance Build None
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: None) Subword where
-  data Elm (ls :!: None) Subword = ElmNone !(Elm ls Subword) !() !Subword
-  type Arg (ls :!: None) = Arg ls :. ()
-  getArg !(ElmNone ls () _) = getArg ls :. ()
-  getIdx !(ElmNone _ _ i)   = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls:!:None) Subword where
-  mkStream !(ls:!:None) Outer !ij@(Subword (i:.j))
-    = S.map (\s -> ElmNone s () (subword i j))
-    $ S.filter (\_ -> i==j)
-    $ mkStream ls Outer ij
-  {-# INLINE mkStream #-}
-
diff --git a/ADP/Fusion/QuickCheck.hs b/ADP/Fusion/QuickCheck.hs
deleted file mode 100644
--- a/ADP/Fusion/QuickCheck.hs
+++ /dev/null
@@ -1,531 +0,0 @@
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module ADP.Fusion.QuickCheck where
-
-import Control.Monad
-import Control.Applicative
-import Data.Array.Repa.Index
-import Data.Array.Repa.Shape
-import Data.Array.Repa.Arbitrary
-import Debug.Trace
-import qualified Data.Vector.Fusion.Stream as S
-import qualified Data.Vector.Fusion.Stream.Monadic as SM
-import qualified Data.Vector.Unboxed as VU
-import Test.QuickCheck
-import Test.QuickCheck.All
-import Test.QuickCheck.Monadic
-import Data.List ((\\))
-import System.IO.Unsafe
-
-import Data.Array.Repa.Index.Subword
-import Data.Array.Repa.Index.Point
-import Data.Array.Repa.Index.Points
-import qualified Data.PrimitiveArray as PA
-import qualified Data.PrimitiveArray.Zero as PA
-
-import ADP.Fusion
-import ADP.Fusion.Table
-import ADP.Fusion.Multi
-
-
--- | Check if a single region returns the correct result (namely a slice from
--- the input).
-
-prop_R sw@(Subword (i:.j)) = zs == ls where
-  zs = id <<< region xs ... S.toList $ sw
-  ls = [VU.slice i (j-i) xs | i>=0, j<=100]
-
--- | Two regions next to each other.
-
-prop_RR sw@(Subword (i:.j)) = zs == ls where
-  zs = (,) <<< region xs % region xs ... S.toList $ sw
-  ls = [(VU.slice i (k-i) xs, VU.slice k (j-k) xs) | k <- [i..j]]
-
--- | And finally, three regions (with smaller subword sizes only)
-
-prop_RRR sw@(Subword (i:.j)) = (j-i<=30) ==> zs == ls where
-  zs = (,,) <<< region xs % region xs % region xs ... S.toList $ sw
-  ls = [  ( VU.slice i (k-i) xs
-          , VU.slice k (l-k) xs
-          , VU.slice l (j-l) xs
-          ) | k <- [i..j], l <- [k..j]]
-
--- | Three sized regions (with smaller subword sizes only)
-
-prop_SSS sw@(Subword (i:.j)) = zs == ls where
-  zs = (,,) <<< sregion 3 10 xs % sregion 3 10 xs % sregion 3 10 xs ... S.toList $ sw
-  ls = [  ( VU.slice i (k-i) xs
-          , VU.slice k (l-k) xs
-          , VU.slice l (j-l) xs
-          ) | k <- [i..j], l <- [k..j], minimum [k-i,l-k,j-l] >=3, maximum [k-i,l-k,j-l] <= 10]
-
--- | Single-character parser.
-
-prop_C sw@(Subword (i:.j)) = zs == ls where
-  zs = id <<< chr xs ... S.toList $ sw
-  ls = [xs VU.! i | i+1==j, i>=0, j<=100]
-
--- | 2x Single-character parser.
-
-prop_CC sw@(Subword (i:.j)) = zs == ls where
-  zs = (,) <<< chr xs % chr xs ... S.toList $ sw
-  ls = [(xs VU.! i, xs VU.! (i+1)) | i+2==j]
-
--- ** Single character plus peeking
-
-prop_PlC sw@(Subword (i:.j)) = zs == ls where
-  zs = (,) <<< peekL xs % chr xs ... S.toList $ sw
-  ls = [(xs VU.! (j-2), xs VU.! (j-1)) | j>1, i+1==j]
-
-prop_PrC sw@(Subword (i:.j)) = zs == ls where
-  zs = (,) <<< peekR xs % chr xs ... S.toList $ sw
-  ls = [(xs VU.! (j-1), xs VU.! (j-1)) | i+1==j]
-
-prop_CPr sw@(Subword (i:.j)) = zs == ls where
-  zs = (,) <<< chr xs % peekR xs ... S.toList $ sw
-  ls = [(xs VU.! (j-1), xs VU.! j) | i>=0, j<=99,i+1==j]
-
-prop_CPl sw@(Subword (i:.j)) = zs == ls where
-  zs = (,) <<< chr xs % peekL xs ... S.toList $ sw
-  ls = [(xs VU.! (j-1), xs VU.! (j-1)) | i+1==j]
-
--- | 2x Single-character parser bracketing a single region.
-
-prop_CRC sw@(Subword (i:.j)) = zs == ls
-  where
-    zs = (,,) <<< chr xs % region xs % chr xs ... S.toList $ sw
-    ls = [(xs VU.! i, VU.slice (i+1) (j-i-2) xs , xs VU.! (j-1)) |i+2<=j]
-
--- | 2x Single-character parser bracketing regions.
-
-prop_CRRC sw@(Subword (i:.j)) = zs == ls
-  where
-    zs = (,,,) <<< chr xs % region xs % region xs % chr xs ... S.toList $ sw
-    ls = [ ( xs VU.! i
-           , VU.slice (i+1) (k-i-1) xs
-           , VU.slice k (j-k-1) xs
-           , xs VU.! (j-1)
-           ) | k <- [i+1 .. j-1]]
-
--- | complex behaviour with characters and regions
-
-prop_CRCRC sw@(Subword (i:.j)) = zs == ls where
-  zs = (,,,,) <<< chr xs % region xs % chr xs % region xs % chr xs ... S.toList $ sw
-  ls = [ ( xs VU.! i
-         , VU.slice (i+1) (k-i-1) xs
-         , xs VU.! k
-         , VU.slice (k+1) (j-k-2) xs
-         , xs VU.! (j-1)
-         ) | k <- [i+1 .. j-2] ]
-
--- | Interior-loop like structures.
-
-prop_Interior1 sw@(Subword (i:.j)) = zs == ls where
-  zs = (,,) <<< chr xs % peekR xs % sregion 1 5 xs ... S.toList $ sw
-  ls = [ ( xs VU.! i
-         , xs VU.! (i+1)
-         , VU.slice (i+1) (j-i-1) xs
-         ) | j-i>=2, j-i<=6
-       ]
-
-prop_Interior2 sw@(Subword (i:.j)) = zs == ls where
-  zs = (,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs ... S.toList $ sw
-  ls = [ ( xs VU.! i
-         , xs VU.! (i+1)
-         , VU.slice (i+1) (k-i-1) xs
-         , xs VU.! k
-         , VU.slice k (j-k) xs
-         ) | j-i>=4, j-i<=11, k <- [i+2 .. (min j $ i+6)], j-k>=2, j-k<=5
-       ]
-
-prop_Interior3 sw@(Subword (i:.j)) = zs == ls where
-  zs = (,,,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs ... S.toList $ sw
-  ls = [ ( xs VU.! i
-         , xs VU.! (i+1)
-         , VU.slice (i+1) (k-i-1) xs
-         , xs VU.! k
-         , VU.slice k (l-k) xs
-         , xs VU.! (l-1)
-         , VU.slice l (j-l) xs
-         ) | i>= 0
-           , j<= 100
-           , k <- [i..j]
-           , l <- [k..j]
-           , j-i>=5, j-i<=16
-           , k-i-1>=1, k-i-1<=5
-           , l-k>=2, l-k<=5
-           , j-l>=1, j-l<=5
-       ]
-
-prop_Interior4 sw@(Subword (i:.j)) = zs == ls where
-  zs = (,,,,,,,,) <<< chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs % peekL xs % chr xs ... S.toList $ sw
-  ls = [ ( xs VU.! i
-         , xs VU.! (i+1)
-         , VU.slice (i+1) (k-i-1) xs
-         , xs VU.! k
-         , VU.slice k (l-k) xs
-         , xs VU.! (l-1)
-         , VU.slice l (j-l-1) xs
-         , xs VU.! (j-2)
-         , xs VU.! (j-1)
-         ) | k <- [i..j]
-           , l <- [k..j]
-           , j-i>=6, j-i<=17
-           , k-i-1>=1, k-i-1<=5
-           , l-k>=2, l-k<=5
-           , j-l-1>=1, j-l-1<=5
-       ]
-
-prop_Interior5 sw@(Subword (i:.j)) = zs == ls where
-  zs = (,,,,,,,,,,) <<< peekL xs % chr xs % peekR xs % sregion 1 5 xs % peekR xs % sregion 2 5 xs % peekL xs % sregion 1 5 xs % peekL xs % chr xs % peekR xs ... S.toList $ sw
-  ls = [ ( xs VU.! (i-1)
-         , xs VU.! i
-         , xs VU.! (i+1)
-         , VU.slice (i+1) (k-i-1) xs
-         , xs VU.! k
-         , VU.slice k (l-k) xs
-         , xs VU.! (l-1)
-         , VU.slice l (j-l-1) xs
-         , xs VU.! (j-2)
-         , xs VU.! (j-1)
-         , xs VU.! j
-         ) | i>= 1
-           , j<= 99
-           , k <- [i..j]
-           , l <- [k..j]
-           , i>0, j-1 < VU.length xs
-           , j-i>=6, j-i<=17
-           , k-i-1>=1, k-i-1<=5
-           , l-k>=2, l-k<=5
-           , j-l-1>=1, j-l-1<=5
-       ]
-
--- | A single mutable table should return one result.
-
-prop_Mt sw@(Subword (i:.j)) = monadicIO $ do
-    mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
-    let mt = mTblSw EmptyT mxs
-    zs <- run $ id <<< mt ... SM.toList $ sw
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.sw)) | i<=j]
-    assert $ zs == ls
-
--- | table, then character.
-
-prop_MtC sw@(Subword (i:.j)) = monadicIO $ do
-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
-    let mt = mTblSw EmptyT mxs
-    zs <- run $ (,) <<< mt % chr xs ... SM.toList $ sw
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i (j-1))) >>= \a -> return (a,xs VU.! (j-1)) | i<j]
-    assert $ zs == ls
-
--- | Character, then table.
-
-prop_CMt sw@(Subword (i:.j)) = monadicIO $ do
-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
-    let mt = mTblSw EmptyT mxs
-    zs <- run $ (,) <<< chr xs % mt ... SM.toList $ sw
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword (i+1) j)) >>= \a -> return (xs VU.! i,a) | i<j]
-    assert $ zs == ls
-
--- | Two mutable tables. Basically like Region's.
-
-prop_MtMt sw@(Subword (i:.j)) = monadicIO $ do
-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
-    let mt = mTblSw EmptyT mxs
-    zs <- run $ (,) <<< mt % mt ... SM.toList $ sw
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i k)) >>= \a -> PA.readM mxs (Z:.subword k j) >>= \b -> return (a,b) | k <- [i..j]]
-    assert $ zs == ls
-
--- | Just to make it more interesting, sprinkle in some 'Chr' symbols.
-
-prop_CMtCMtC sw@(Subword (i:.j)) = monadicIO $ do
-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
-    let mt = mTblSw EmptyT mxs
-    zs <- run $ (,,,,) <<< chr xs % mt % chr xs % mt % chr xs ... SM.toList $ sw
-    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) k)) >>=
-                            \a -> PA.readM mxs (Z:.subword (k+1) (j-1)) >>=
-                            \b -> return ( xs VU.! i
-                                         , a
-                                         , xs VU.! k
-                                         , b
-                                         , xs VU.! (j-1)
-                                         )
-                           | k <- [i+1..j-2]]
-    assert $ zs == ls
-
--- | And now with non-empty tables.
-
-prop_CMnCMnC sw@(Subword (i:.j)) = monadicIO $ do
-    mxs :: (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int)) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ] -- (1 :: Int)
-    let mt = mTblSw NonEmptyT mxs
-    zs <- run $ (,,,,) <<< chr xs % mt % chr xs % mt % chr xs ... SM.toList $ sw
-    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) k)) >>=
-                            \a -> PA.readM mxs (Z:.subword (k+1) (j-1)) >>=
-                            \b -> return ( xs VU.! i
-                                         , a
-                                         , xs VU.! k
-                                         , b
-                                         , xs VU.! (j-1)
-                                         )
-                           | k <- [i+2..j-3]]
-    assert $ zs == ls
-
-{-
- - Currently not allowing 0-dim multi-tapes.
-
-prop_Tt ix@Z = zs == ls where
-  zs = id <<< T ... S.toList $ ix
-  ls = [ Z ]
--}
-
--- **
-
-prop_Tc ix@(Z:.Subword(i:.j)) = zs == ls where
-  zs = id <<< (T:!chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! i) | i>=0, j<= 100, i+1==j ]
-
-prop_Tcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where
-  zs = id <<< (T:!chr xs:!chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! i:.xs VU.! k) | i>=0, j<=100, k>=0, j<=100, i+1==j, k+1==l ]
-
--- **
-
-prop_TcTc ix@(Z:.Subword(i:.j)) = zs == ls where
-  zs = (,) <<< (T:!chr xs) % (T:!chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! i,Z:.xs VU.! (i+1)) | i>=0, j<= 100, i+2==j ]
-
-prop_TccTcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where
-  zs = (,) <<< (T:!chr xs:!chr xs) % (T:!chr xs:!chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! i:.xs VU.! k, Z:.xs VU.! (i+1):.xs VU.! (k+1)) | i>=0, j<=100, k>=0, j<=100, i+2==j, k+2==l ]
-
--- **
-
-prop_Mt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do
-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
-  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
-  zs <- run $ id <<< mt ... SM.toList $ ix
-  ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword i j)) | i>=0, j<=100, i<=j ]
-  assert $ zs == ls
-
-prop_MtMt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do
-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
-  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
-  zs <- run $ (,) <<< mt % mt ... SM.toList $ ix
-  ls <- run $ sequence $ [ liftM2 (,) (PA.readM mxs (Z:.subword i k)) (PA.readM mxs (Z:.subword k j)) | i>=0, j<=100, k<-[i..j] ]
-  assert $ zs == ls
-
-prop_MtMtMt2 ix@(Z:.Subword(i:.j)) = monadicIO $ do
-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
-  let mt = mTbl (Z:.EmptyT) mxs -- :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
-  zs <- run $ (,,) <<< mt % mt % mt ... SM.toList $ ix
-  ls <- run $ sequence $ [ liftM3 (,,) (PA.readM mxs (Z:.subword i k)) (PA.readM mxs (Z:.subword k l)) (PA.readM mxs (Z:.subword l j)) | i>=0, j<=100, k<-[i..j], l<-[k..j] ]
-  assert $ zs == ls
-
-prop_TcMtTc ix@(Z:.Subword(i:.j)) = monadicIO $ do
-  mxs :: PA.MutArr IO (PA.Unboxed (Z:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0) (Z:.subword 0 100) [0 ..]
-  let mt = mTbl (Z:.EmptyT) mxs :: MTbl (Z:.Subword) (PA.MutArr IO (PA.Unboxed (Z:.Subword) Int))
-  zs <- run $ (,,) <<< (T:!chr xs) % mt % (T:!chr xs) ... SM.toList $ ix
-  ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword (i+1) (j-1)) >>= \z -> return (Z:.xs VU.! i,z,Z:.xs VU.! (j-1))) | i>=0, j<=100, i+2<=j ]
-  assert $ zs == ls
-
-prop_2dim ix@(Z:.TinySubword(i:.j):.TinySubword(k:.l)) = monadicIO $ do
-  mxs <- run $ pure $ mxsSwSw
-  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs
-  zs <- run $ (,) <<< mt % mt ... SM.toList $ Z:.subword i j:.subword k l
-  ls <- run $ sequence $ [ liftM2 (,) (PA.readM mxs (Z:.subword i a:.subword k b)) (PA.readM mxs (Z:.subword a j:.subword b l)) | i>=0, j<=100, k>=0, l<=100, a<-[i..j], b<-[k..l] ]
-  assert $ zs==ls
-
-prop_2dimCMCMC ix@(Z:.TinySubword(i:.j):.TinySubword(k:.l)) = monadicIO $ do
-  mxs <- run $ pure $ mxsSwSw -- :: PA.MutArr IO (PA.Unboxed (Z:.Subword:.Subword) Int) <- run $ PA.fromListM (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 100:.subword 0 100) [0 ..]
-  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs
-  zs <- run $ (,,,,) <<< (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) ... SM.toList $ Z:.subword i j:.subword k l
-  ls <- run $ sequence $ [ liftM5 (,,,,) (pure $ Z:.xs VU.! i:.xs VU.! k)
-                                         (PA.readM mxs (Z:.subword (i+1) a:.subword (k+1) b))
-                                         (pure $ Z:.xs VU.! a:.xs VU.! b)
-                                         (PA.readM mxs (Z:.subword (a+1) (j-1):.subword (b+1) (l-1)))
-                                         (pure $ Z:.xs VU.! (j-1):.xs VU.! (l-1))
-                         | j-i>=3, l-k>=3, i>=0, j<=100, k>=0, l<=100, a<-[i+1..j-2], b<-[k+1..l-2] ]
-  assert $ zs==ls
-
--- * working on 'PointL's
-
-prop_P_Tt ix@(Z:.PointL (i:.j)) = zs == ls where
-  zs = id <<< (T:!chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! i) | i+1==j ]
-
-prop_P_CC ix@(Z:.PointL (i:.j)) = zs == ls where
-  zs = (,) <<< (T:!chr xs) % (T:!chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! i, Z:.xs VU.! (i+1)) | i+2==j ]
-
-prop_P_2dimCMCMC ix@(Z:.PointL(i:.j):.PointL(k:.l)) = monadicIO $ do
-  mxs <- run $ pure $ mxsPP
-  let mt = mTbl (Z:.EmptyT:.EmptyT) mxs
-  zs <- run $ (,,,,) <<< (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) % mt % (T:!chr xs:!chr xs) ... SM.toList $ ix
-  ls <- run $ sequence $ [ liftM5 (,,,,) (pure $ Z:.xs VU.! i:.xs VU.! k)
-                                         (PA.readM mxs (Z:.pointL (i+1) a:.pointL (k+1) b))
-                                         (pure $ Z:.xs VU.! a:.xs VU.! b)
-                                         (PA.readM mxs (Z:.pointL (a+1) (j-1):.pointL (b+1) (l-1)))
-                                         (pure $ Z:.xs VU.! (j-1):.xs VU.! (l-1))
-                         | j-i>=3, l-k>=3, i>=0, j<=100, k>=0, l<=100, a<-[i+1..j-2], b<-[k+1..l-2] ]
-  assert $ zs==ls
-
-{-
-prop_TcTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where
-  zs = (,) <<< Term (T:.Chr xs) % Term (T:.Chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | i>1 ]
-
--- deriving instance Show (Elm (None :. Term (T :. Chr Int)) (Z :. Point))
-
-prop_TpTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where
-  zs = (,) <<< Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... S.toList $ ix
-  ls = [ (Z:.f i, Z:.xs VU.! (i-1)) | i>0 ]
-  f i = if i>1 then xs VU.! (i-2) else (-1)
-
-prop_TcTpTc ix@(Z:.Point i) = {- traceShow (zs,ls) $ -} zs == ls where
-  zs = (,,) <<< Term (T:.Chr xs) % Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! (i-2), Z:.f i, Z:.xs VU.! (i-1)) | i>1 ]
-  f i = if i>1 then xs VU.! (i-2) else (-1)
-
-{-
-prop_Mt_Tc ix@(Z:.Subword(i:.j)) = monadicIO $ do
-    mxs :: (PA.MU IO (Z:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0)) (Z:. Subword (0:.100)) [0 .. ]
-    let mt = mtable mxs
-    zs <- run $ (,) <<< mt % Term (T:.Chr xs) ... SM.toList $ ix
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.subword i (j-1))) >>= \a -> return (a,Z:.xs VU.! (j-1)) | i<j ]
-    assert $ zs == ls
--}
-
-prop_P_Mt_Tt ix@(Z:.Point i) = monadicIO $ do
-    mxs :: (PA.MU IO (Z:.Point) Int) <- run $ PA.fromListM (Z:.Point 0) (Z:.Point 100) [0 .. ]
-    let mt = mtable mxs
-    zs <- run $ (,) <<< mt % Term (T:.Chr xs) ... SM.toList $ ix
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1))) >>= \a -> return (a,Z:.xs VU.! (i-1)) | i>0 ]
-    assert $ zs == ls
-
-prop_P_Mt_TpTc ix@(Z:.Point i) = monadicIO $ do
-    mxs :: (PA.MU IO (Z:.Point) Int) <- run $ PA.fromListM (Z:.Point 0) (Z:.Point 100) [0 .. ]
-    let mt = mtable mxs
-    let f i = if i>1 then xs VU.! (i-2) else (-1)
-    zs <- run $ (,,) <<< mt % Term (T:.Peek (-1) xs) % Term (T:.Chr xs) ... SM.toList $ ix
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1))) >>= \a -> return (a,Z:.f i,Z:.xs VU.! (i-1)) | i>0 ]
-    assert $ zs == ls
-
--- | and with 2-tape grammars
-
-prop_Tcc ix@(Z:.Subword(i:.j):.Subword(k:.l)) = zs == ls where
-  zs = id <<< Term (T:.Chr xs:.Chr xs) ... S.toList $ ix
-  ls = [ (  Z
-         :. xs VU.! i
-         :. xs VU.! k
-         ) | i+1==j, k+1==l ]
-
-prop_Mt_Tcc (Z:.TinySubword (i:.j):.TinySubword (k:.l)) = monadicIO $ do
-    let ix = Z :. subword i j :. subword k l
-    mxs :: (PA.MU IO (Z:.Subword:.Subword) Int) <- run $ PA.fromListM (Z:. Subword (0:.0):.Subword(0:.0)) (Z:. Subword (0:.j+1):.Subword (0:.k+1)) [0 .. ]
-    let mt = mtable mxs
-    zs <- run $ (,) <<< mt % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix
-    ls <- run $ sequence $ [ (PA.readM mxs (Z:.subword i (j-1):.subword k (l-1))) >>= \a -> return (a,Z:.xs VU.! (j-1):.xs VU.! (l-1)) | i<j,k<l ]
-    assert $ zs == ls
-
-prop_P_Ttt ix@(Z:.Point i:.Point j) = zs == ls where
-  zs = id <<< Term (T:.Chr xs:.Chr xs) ... S.toList $ ix
-  ls = [ (Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0, j>0 ]
-
-prop_P_Mt_Ttt ix@(Z:.Point i:.Point j) = monadicIO $ do
-    mxs :: (PA.MU IO (Z:.Point:.Point) Int) <- run $ PA.fromListM (Z:.Point 0:.Point 0) (Z:.Point 100:.Point 100) [0 .. ]
-    let mt = mtable mxs
-    zs <- run $ (,) <<< mt % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1):.Point (j-1))) >>= \a -> return (a,Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0,j>0 ]
-    assert $ zs == ls
-
-prop_P_Mt_Tpp_Ttt ix@(Z:.Point i:.Point j) = monadicIO $ do
-    mxs :: (PA.MU IO (Z:.Point:.Point) Int) <- run $ PA.fromListM (Z:.Point 0:.Point 0) (Z:.Point 100:.Point 100) [0 .. ]
-    let mt = mtable mxs
-    let f i j = Z:. (if i>1 then xs VU.! (i-2) else (-1)) :. (if j>1 then xs VU.! (j-2) else (-1))
-    zs <- run $ (,,) <<< mt % Term (T:.Peek (-1) xs:.Peek (-1) xs) % Term (T:.Chr xs:.Chr xs) ... SM.toList $ ix
-    ls <- run $ sequence $ [(PA.readM mxs (Z:.Point (i-1):.Point (j-1))) >>= \a -> return (a,f i j,Z:.xs VU.! (i-1):.xs VU.! (j-1)) | i>0,j>0 ]
-    -- traceShow (zs,ls) $
-    assert $ zs == ls
-
--- | and with 3-tape grammars
-
-prop_Tccc ix@(Z:.Subword(i:.j):.Subword(k:.l):.Subword(a:.b)) = zs == ls where
-  zs = id <<< Term (T:.Chr xs:.Chr xs:.Chr xs) ... S.toList $ ix
-  ls = [ (  Z
-         :. xs VU.! i
-         :. xs VU.! k
-         :. xs VU.! a
-         ) | i+1==j, k+1==l, a+1==b ]
-
--- * helper functions and stuff
-
--- | Helper function to create non-specialized regions
-
-region = Region Nothing Nothing
-
--- |
-
-mtable xs = MTable Eall xs
-
-{-
--- | A subword (i,j) should always produce an index in the allowed range
-
-prop_subwordIndex (Small n, Subword (i:.j)) = (n>j) ==> p where
-  p = n * (n+1) `div` 2 >= k
-  k = subwordIndex (subword 0 n) (subword i j)
--}
-
--}
-
--- | data set. Can be made fixed as the maximal subword size is statically known!
-
-xs = VU.fromList [0 .. 99 :: Int]
-
---
---
---TODO will break if PrimitiveArray assertions are active (need to fixe exact length of list)
-
-mxsSwSw = unsafePerformIO $ zzz where
-  zzz :: IO (PA.MutArr IO (PA.Unboxed (Z:.Subword:.Subword) Int))
-  zzz = PA.fromListM (Z:.subword 0 0:.subword 0 0) (Z:.subword 0 100:.subword 0 100) [0 ..]
-
-mxsPP = unsafePerformIO $ zzz where
-  zzz :: IO (PA.MutArr IO (PA.Unboxed (Z:.PointL:.PointL) Int))
-  zzz = PA.fromListM (Z:.pointL 0 0:.pointL 0 0) (Z:.pointL 0 100:.pointL 0 100) [0 ..]
-
--- * general quickcheck stuff
-
-options = stdArgs {maxSuccess = 1000}
-
-customCheck = quickCheckWithResult options
-
-allProps = $forAllProperties customCheck
-
-
-
-newtype Small = Small Int
-  deriving (Show)
-
-instance Arbitrary Small where
-  arbitrary = Small <$> choose (0,100)
-  shrink (Small i) = Small <$> shrink i
-
-newtype TinySubword = TinySubword (Int:.Int)
-  deriving (Show)
-
-instance Arbitrary TinySubword where
-  arbitrary = do a <- choose (0,20)
-                 b <- choose (0,20)
-                 return $ TinySubword $ min a b :. max a b
-  shrink (TinySubword (a:.b)) = [TinySubword (a:.b-1) | a<b]
-
-instance Arbitrary z => Arbitrary (z:.TinySubword) where
-  arbitrary = (:.) <$> arbitrary <*> arbitrary
-  shrink (z:.s) = (:.) <$> shrink z <*> shrink s
-
-
diff --git a/ADP/Fusion/QuickCheck/Common.hs b/ADP/Fusion/QuickCheck/Common.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/QuickCheck/Common.hs
@@ -0,0 +1,10 @@
+
+{-# Options_GHC -O0 #-}
+
+module ADP.Fusion.QuickCheck.Common where
+
+import Debug.Trace
+
+
+
+tr zs ls b = traceShow (zs," ",ls,length zs,length ls) b
diff --git a/ADP/Fusion/QuickCheck/Point.hs b/ADP/Fusion/QuickCheck/Point.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/QuickCheck/Point.hs
@@ -0,0 +1,293 @@
+
+{-# Options_GHC -O0 #-}
+
+module ADP.Fusion.QuickCheck.Point where
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.Strict.Tuple
+import           Data.Vector.Fusion.Util
+import           Debug.Trace
+import qualified Data.Vector.Fusion.Stream as S
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import qualified Data.Vector.Unboxed as VU
+import           System.IO.Unsafe
+import           Test.QuickCheck
+import           Test.QuickCheck.All
+import           Test.QuickCheck.Monadic
+
+import           Data.PrimitiveArray
+
+import ADP.Fusion
+
+
+
+-- * Epsilon cases
+
+prop_Epsilon ix@(PointL j) = zs == ls where
+  zs = (id <<< Epsilon ... S.toList) maxPL ix
+  ls = [ () | j == 0 ]
+
+prop_O_Epsilon ix@(O (PointL j)) = zs == ls where
+  zs = (id <<< Epsilon ... S.toList) (O maxPL) ix
+  ls = [ () | j == 100 ]
+
+prop_ZEpsilon ix@(Z:.PointL j) = zs == ls where
+  zs = (id <<< (M:|Epsilon) ... S.toList) (Z:.maxPL) ix
+  ls = [ Z:.() | j == 0 ]
+
+prop_O_ZEpsilon ix@(O (Z:.PointL j)) = zs == ls where
+  zs = (id <<< (M:|Epsilon) ... S.toList) (O (Z:.maxPL)) ix
+  ls = [ Z:.() | j == 100 ]
+
+prop_O_ZEpsilonEpsilon ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
+  zs = (id <<< (M:|Epsilon:|Epsilon) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
+  ls = [ Z:.():.() | j == 100, l == 100 ]
+
+
+
+-- * Deletion cases
+
+prop_O_ItNC ix@(O (PointL j)) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % Deletion % chr xs ... S.toList) (O $ maxPL) ix
+  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)
+         , ()
+         , xs VU.! (j+0)
+         ) | j >= 0, j <= 99 ]
+{-# Noinline prop_O_ItNC #-}
+
+prop_O_ZItNC ix@(O (Z:.PointL j)) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % (M:|Deletion) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
+  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+1)))
+         , Z:.()
+         , Z:.xs VU.! (j+0)
+         ) | j >= 0, j <= 99 ]
+
+prop_O_2dimIt_NC_CN ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
+  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+1):.PointL (l+1)))
+         , Z:.()           :.xs VU.! (l+0)
+         , Z:.xs VU.! (j+0):.()
+         ) | j>=0, l>=0, j<=99, l<=99 ]
+
+prop_2dimIt_NC_CN ix@(Z:.PointL j:.PointL l) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % (M:|Deletion:|chr xs) % (M:|chr xs:|Deletion) ... S.toList) (Z:.maxPL:.maxPL) ix
+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-1):.PointL (l-1))
+         , Z:.()           :.xs VU.! (l-1)
+         , Z:.xs VU.! (j-1):.()
+         ) | j>=1, l>=1, j<=100, l<=100 ]
+
+
+
+-- * terminal cases
+
+-- | A single character terminal
+
+prop_Tt ix@(Z:.PointL j) = zs == ls where
+  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.maxPL) ix
+  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]
+
+--prop_O_Tt ix@(Z:.O (PointL j)) = traceShow (j,zs,ls) $ zs == ls where
+--  zs = (id <<< (M:|chr xs) ... S.toList) (Z:.O maxPL) ix
+--  ls = [ (Z:.xs VU.! (j-1)) | 1==j ]
+
+-- | Two single-character terminals
+
+prop_CC ix@(Z:.PointL i) = zs == ls where
+  zs = ((,) <<< (M:|chr xs) % (M:|chr xs) ... S.toList) (Z:.maxPL) ix
+  ls = [ (Z:.xs VU.! (i-2), Z:.xs VU.! (i-1)) | 2==i ]
+
+-- | Just a table
+
+prop_It ix@(PointL j) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
+  zs = (id <<< t ... S.toList) maxPL ix
+  ls = [ unsafeIndex xsP ix | j>=0, j<=100 ]
+
+prop_O_It ix@(O (PointL j)) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
+  zs = (id <<< t ... S.toList) (O maxPL) ix
+  ls = [ unsafeIndex xsPo ix | j>=0, j<=100 ]
+
+prop_ZIt ix@(Z:.PointL j) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
+  zs = (id <<< t ... S.toList) (Z:.maxPL) ix
+  ls = [ unsafeIndex xsZP ix | j>=0, j<=100 ]
+
+prop_O_ZIt ix@(O (Z:.PointL j)) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
+  zs = (id <<< t ... S.toList) (O (Z:.maxPL)) ix
+  ls = [ unsafeIndex xsZPo ix | j>=0, j<=100 ]
+
+-- | Table, then single terminal
+
+prop_ItC ix@(PointL j) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
+  zs = ((,) <<< t % chr xs ... S.toList) maxPL ix
+  ls = [ ( unsafeIndex xsP (PointL $ j-1)
+         , xs VU.! (j-1)
+         ) | j>=1, j<=100 ]
+
+-- | @A^*_j -> A^*_{j+1} c_{j+1)@ !
+
+prop_O_ItC ix@(O (PointL j)) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
+  zs = ((,) <<< t % chr xs ... S.toList) (O $ maxPL) ix
+  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+1)
+         , xs VU.! (j+0)
+         ) | j >= 0, j < 100 ]
+
+prop_O_ItCC ix@(O (PointL j)) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsPo (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % chr xs % chr xs ... S.toList) (O $ maxPL) ix
+  ls = [ ( unsafeIndex xsPo (O $ PointL $ j+2)
+         , xs VU.! (j+0)
+         , xs VU.! (j+1)
+         ) | j >= 0, j <= 98 ]
+{-# Noinline prop_O_ItCC #-}
+
+prop_O_ZItCC ix@(O (Z:.PointL j)) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
+  ls = [ ( unsafeIndex xsZPo (O (Z:.PointL (j+2)))
+         , Z:.xs VU.! (j+0)
+         , Z:.xs VU.! (j+1)
+         ) | j >= 0, j <= 98 ]
+
+-- | synvar followed by a 2-tape character terminal
+
+prop_2dimItCC ix@(Z:.PointL j:.PointL l) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+  ls = [ ( unsafeIndex xsPP (Z:.PointL (j-2):.PointL (l-2))
+         , Z:.xs VU.! (j-2):.xs VU.! (l-2)
+         , Z:.xs VU.! (j-1):.xs VU.! (l-1)
+         ) | j>=2, l>=2, j<=100, l<=100 ]
+
+prop_O_2dimItCC ix@(O (Z:.PointL j:.PointL l)) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPPo (\ _ _ -> Id 1)
+  zs = ((,,) <<< t % (M:|chr xs:|chr xs) % (M:|chr xs:|chr xs) ... S.toList) (O (Z:.maxPL:.maxPL)) ix
+  ls = [ ( unsafeIndex xsPPo (O (Z:.PointL (j+2):.PointL (l+2)))
+         , Z:.xs VU.! (j+0):.xs VU.! (l+0)
+         , Z:.xs VU.! (j+1):.xs VU.! (l+1)
+         ) | j>=0, l>=0, j<=98, l<=98 ]
+
+-- * direct index tests
+
+xprop_O_ixZItCC ix@(O (Z:.PointL j)) = zs where
+  t = ITbl 0 0 (Z:.EmptyOk) xsZPo (\ _ _ -> Id 1)
+  zs = (id >>> t % (M:|chr xs) % (M:|chr xs) ... S.toList) (O (Z:.maxPL)) ix
+
+-- * 'Strng' tests
+
+-- ** Just the 'Strng' terminal
+
+prop_ManyS ix@(PointL j) = zs == ls where
+  zs = (id <<< manyS xs ... S.toList) maxPL ix
+  ls = [ (VU.slice 0 j xs) ]
+
+prop_SomeS ix@(PointL j) = zs == ls where
+  zs = (id <<< someS xs ... S.toList) maxPL ix
+  ls = [ (VU.slice 0 j xs) | j>0 ]
+
+prop_2dim_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where
+  zs = (id <<< (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) ]
+
+prop_2dim_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where
+  zs = (id <<< (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+  ls = [ (Z:.VU.slice 0 i xs:.VU.slice 0 j xs) | i > 0 && j > 0 ]
+
+-- ** Together with a syntactic variable.
+
+prop_Itbl_ManyS ix@(PointL i) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
+  zs = ((,) <<< t % manyS xs ... S.toList) maxPL ix
+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i] ]
+
+prop_Itbl_SomeS ix@(PointL i) = zs == ls where
+  t = ITbl 0 0 EmptyOk xsP (\ _ _ -> Id 1)
+  zs = ((,) <<< t % someS xs ... S.toList) maxPL ix
+  ls = [ (unsafeIndex xsP (PointL k), VU.slice k (i-k) xs) | k <- [0..i-1] ]
+
+prop_1dim_Itbl_ManyS ix@(Z:.PointL i) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
+  zs = ((,) <<< t % (M:|manyS xs) ... S.toList) (Z:.maxPL) ix
+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i] ]
+
+prop_1dim_Itbl_SomeS ix@(Z:.PointL i) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk) xsZP (\ _ _ -> Id 1)
+  zs = ((,) <<< t % (M:|someS xs) ... S.toList) (Z:.maxPL) ix
+  ls = [ (unsafeIndex xsZP (Z:.PointL k), Z:. VU.slice k (i-k) xs) | k <- [0..i-1] ]
+
+prop_2dim_Itbl_ManyS_ManyS ix@(Z:.PointL i:.PointL j) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
+  zs = ((,) <<< t % (M:|manyS xs:|manyS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i], l <- [0..j] ]
+
+prop_2dim_Itbl_SomeS_SomeS ix@(Z:.PointL i:.PointL j) = zs == ls where
+  t = ITbl 0 0 (Z:.EmptyOk:.EmptyOk) xsPP (\ _ _ -> Id 1)
+  zs = ((,) <<< t % (M:|someS xs:|someS xs) ... S.toList) (Z:.maxPL:.maxPL) ix
+  ls = [ (unsafeIndex xsPP (Z:.PointL k:.PointL l), Z:. VU.slice k (i-k) xs :. VU.slice l (j-l) xs) | k <- [0..i-1], l <- [0..j-1] ]
+
+
+
+
+infixl 8 >>>
+(>>>) f xs = \lu ij -> S.map f . mkStream (build xs) (initialContext ij) lu $ ij
+
+class GetIxs x i where
+  type R x i :: *
+  getIxs :: Elm x i -> R x i
+
+instance GetIxs S i where
+  type R S i = Z:.(i,i)
+  getIxs e = Z:.(getIdx e, getOmx e)
+
+instance GetIxs ls i => GetIxs (ls :!: Chr a b) i where
+  type R (ls :!: Chr a b) i = R ls i :. (i,i)
+  getIxs (ElmChr _ i o s) = getIxs s :. (i,o)
+
+instance GetIxs ls i => GetIxs (ls :!: ITbl m a i x) i where
+  type R (ls :!: ITbl m a i x) i = R ls i :. (i,i)
+  getIxs (ElmITbl _ i o s) = getIxs s :. (i,o)
+
+xsP :: Unboxed (PointL) Int
+xsP = fromList (PointL 0) maxPL [0 ..]
+
+xsZP :: Unboxed (Z:.PointL) Int
+xsZP = fromList (Z:.PointL 0) (Z:.maxPL) [0 ..]
+
+xsPo :: Unboxed (Outside (PointL)) Int
+xsPo = fromList (O $ PointL 0) (O $ maxPL) [0 ..]
+
+xsZPo :: Unboxed (Outside (Z:.PointL)) Int
+xsZPo = fromList (O (Z:.PointL 0)) (O (Z:.maxPL)) [0 ..]
+
+xsPP :: Unboxed (Z:.PointL:.PointL) Int
+xsPP = fromList (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]
+
+xsPPo :: Unboxed (Outside (Z:.PointL:.PointL)) Int
+xsPPo = fromList (O (Z:.PointL 0:.PointL 0)) (O (Z:.maxPL:.maxPL)) [0 ..]
+
+mxsPP = unsafePerformIO $ zzz where
+  zzz :: IO (MutArr IO (Unboxed (Z:.PointL:.PointL) Int))
+  zzz = fromListM (Z:.PointL 0:.PointL 0) (Z:.maxPL:.maxPL) [0 ..]
+
+maxPL = PointL 100
+
+xs = VU.fromList [0 .. 99 :: Int]
+
+-- * general quickcheck stuff
+
+options = stdArgs {maxSuccess = 1000}
+
+customCheck = quickCheckWithResult options
+
+return []
+allProps = $forAllProperties customCheck
+
diff --git a/ADP/Fusion/QuickCheck/Set.hs b/ADP/Fusion/QuickCheck/Set.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/QuickCheck/Set.hs
@@ -0,0 +1,248 @@
+
+{-# Options_GHC -O0 #-}
+
+module ADP.Fusion.QuickCheck.Set where
+
+import           Data.Bits
+import           Data.Vector.Fusion.Util
+import           Debug.Trace
+import qualified Data.List as L
+import qualified Data.Vector.Fusion.Stream as S
+import qualified Data.Vector.Unboxed as VU
+import           Test.QuickCheck hiding (NonEmpty)
+import           Test.QuickCheck.All
+import           Test.QuickCheck.Monadic
+
+import           Data.Bits.Ordered
+import           Data.PrimitiveArray
+
+import           ADP.Fusion
+import           ADP.Fusion.QuickCheck.Common
+
+
+
+-- * BitSets without interfaces
+
+-- ** Inside checks
+
+prop_b_ii ix@(BitSet _) = zs == ls where
+  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+  zs = ((,) <<< tia % tib ... S.toList) highestB ix
+  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
+       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
+       , let kk = popShiftL ix (BitSet k)
+       ]
+
+prop_b_ii_nn ix@(BitSet _) = zs == ls where
+  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+  zs = ((,) <<< tia % tib ... S.toList) highestB ix
+  ls = [ ( xsB ! kk , xsB ! (ix `xor` kk) )
+       | k <- VU.toList . popCntSorted $ popCount ix -- [ 0 .. 2^(popCount ix) -1 ]
+       , let kk = popShiftL ix (BitSet k)
+       , popCount kk > 0
+       , popCount (ix `xor` kk) > 0
+       ]
+
+prop_b_iii ix@(BitSet _) = zs == ls where
+  tia = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+  tib = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+  tic = ITbl 0 0 EmptyOk xsB (\ _ _ -> Id 1)
+  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix
+  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
+       | k <- VU.toList . popCntSorted $ popCount ix
+       , l <- VU.toList . popCntSorted $ popCount ix - popCount k
+       , let kk = popShiftL ix          (BitSet k)
+       , let ll = popShiftL (ix `xor` kk) (BitSet l)
+       , let mm = (ix `xor` (kk .|. ll))
+       ]
+
+prop_b_iii_nnn ix@(BitSet _) = zs == ls where
+  tia = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+  tib = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+  tic = ITbl 0 0 NonEmpty xsB (\ _ _ -> Id 1)
+  zs = ((,,) <<< tia % tib % tic ... S.toList) highestB ix
+  ls = [ ( xsB ! kk , xsB ! ll , xsB ! mm )
+       | k <- VU.toList . popCntSorted $ popCount ix
+       , l <- VU.toList . popCntSorted $ popCount ix - popCount k
+       , let kk = popShiftL ix          (BitSet k)
+       , let ll = popShiftL (ix `xor` kk) (BitSet l)
+       , let mm = (ix `xor` (kk .|. ll))
+       , popCount kk > 0, popCount ll > 0, popCount mm > 0
+       ]
+
+
+-- * Outside checks
+-- These checks are very similar to those in the @Subword@ module. We just
+-- need to be a bit more careful, as indexed sets have overlap.
+
+-- ** Two non-terminals.
+--
+-- @A_s -> B_(s\t) C_t    (s\t) ++ t == s@
+-- @s = 111 , s\t = 101, t = 010@
+--
+-- with @Z@ the full set.
+-- @Z = 1111@
+
+-- @B*_Z\(s\t) -> A*_Z\s C_t@
+-- @Z\(s\t) = 1010, Z\s = 1000, t = 010@
+
+
+
+
+-- * BitSets with two interfaces
+
+-- ** Inside checks
+
+prop_bii_i :: BS2I First Last -> Bool
+prop_bii_i ix@(s:>i:>j) = zs == ls where
+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+  zs = (id <<< tia ... S.toList) highestBII ix
+  ls = [ xsBII ! ix ]
+
+prop_bii_i_n :: BS2I First Last -> Bool
+prop_bii_i_n ix@(s:>i:>j) = zs == ls where
+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+  zs = (id <<< tia ... S.toList) highestBII ix
+  ls = [ xsBII ! ix | popCount s > 0 ]
+
+-- | Edges should never work as a single terminal element.
+
+prop_bii_e :: BS2I First Last -> Bool
+prop_bii_e ix@(s:>Iter i:>Iter j) = zs == ls where
+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+  zs = (id <<< e ... S.toList) highestBII ix
+  ls = [] :: [ (Int,Int) ]
+
+-- | Edges extend only in cases where in @i -> j@, @i@ actually happens to
+-- be a true interface.
+
+prop_bii_ie :: BS2I First Last -> Bool
+prop_bii_ie ix@(s:>i:>Iter j) = zs == ls where
+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+  zs = ((,) <<< tia % e ... S.toList) highestBII ix
+  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )
+       | let t = s `clearBit` j
+       , k <- activeBitsL t ]
+
+prop_bii_ie_n :: BS2I First Last -> Bool
+prop_bii_ie_n ix@(s:>i:>Iter j) = zs == ls where
+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+  zs = ((,) <<< tia % e ... S.toList) highestBII ix
+  ls = [ ( xsBII ! (t:>i:>(Iter k :: Interface Last)) , (k,j) )
+       | let t = s `clearBit` j
+       , popCount t >= 2
+       , k <- activeBitsL t
+       , k /= getIter i
+       ]
+
+prop_bii_iee :: BS2I First Last -> Bool
+prop_bii_iee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix
+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )
+       | let tmp = (s `clearBit` j)
+       , l <- activeBitsL tmp
+       , l /= getIter i
+       , let t = tmp `clearBit` l
+       , k <- activeBitsL t
+       , let kk = Iter k
+       ]
+
+prop_bii_ieee :: BS2I First Last -> Bool
+prop_bii_ieee ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
+  tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix
+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )
+       | let tmpM = (s `clearBit` j)
+       , m <- activeBitsL tmpM
+       , m /= getIter i
+       , let tmpL = (tmpM `clearBit` m)
+       , l <- activeBitsL tmpL
+       , l /= getIter i
+       , let t = tmpL `clearBit` l
+       , k <- activeBitsL t
+       , let kk = Iter k
+       ]
+
+prop_bii_iee_n :: BS2I First Last -> Bool
+prop_bii_iee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+  zs = ((,,) <<< tia % e % e ... S.toList) highestBII ix
+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,j) )
+       | let tmp = (s `clearBit` j)
+       , l <- activeBitsL tmp
+       , l /= getIter i
+       , let t = tmp `clearBit` l
+       , popCount t >= 2
+       , k <- activeBitsL t
+       , k /= getIter i
+       , let kk = Iter k
+       ]
+
+prop_bii_ieee_n :: BS2I First Last -> Bool
+prop_bii_ieee_n ix@(s:>i:>Iter j) = L.sort zs == L.sort ls where
+  tia = ITbl 0 0 NonEmpty xsBII (\ _ _ -> Id 1)
+  e   = Edge (\ i j -> (i,j)) :: Edge (Int,Int)
+  zs = ((,,,) <<< tia % e % e % e ... S.toList) highestBII ix
+  ls = [ ( xsBII ! (t:>i:>kk) , (k,l) , (l,m) , (m,j) )
+       | let tmpM = (s `clearBit` j)
+       , m <- activeBitsL tmpM
+       , m /= getIter i
+       , let tmpL = (tmpM `clearBit` m)
+       , l <- activeBitsL tmpL
+       , l /= getIter i
+       , let t = tmpL `clearBit` l
+       , popCount t >= 2
+       , k <- activeBitsL t
+       , k /= getIter i
+       , let kk = Iter k
+       ]
+
+-- prop_bii_ii (ix@(s:>i:>j) :: (BitSet:>Interface First:>Interface Last)) = tr zs ls $ zs == ls where
+--   tia = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+--   tib = ITbl 0 0 EmptyOk xsBII (\ _ _ -> Id 1)
+--   zs = ((,) <<< tia % tib ... S.toList) highestBII ix
+--   ls = [ ( xsBII ! kk , xsBII ! ll )
+--        | k  <- VU.toList . popCntSorted $ popCount s
+--        , ki <- if k==0 then [0] else activeBitsL k
+--        , kj <- if | k==0 -> [0] | popCount k==1 -> [ki] | otherwise -> activeBitsL (k `clearBit` ki)
+--        , let kk = (BitSet k:>Iter ki:>Iter kj)
+--        , let l  = s `xor` BitSet k
+--        , li <- if l==0 then [0] else activeBitsL l
+--        , lj <- if | l==0 -> [0] | popCount l==1 -> [li] | otherwise -> activeBitsL (l `clearBit` li)
+--        , let ll = (l:>Iter li:>Iter lj)
+--        ]
+
+
+
+-- * Helper functions
+
+highBit = fromIntegral arbitraryBitSetMax -- should be the same as the highest bit in Index.Set.arbitrary
+highestB = BitSet $ 2^(highBit+1) -1
+highestBII = highestB :> Iter (highBit-1) :> Iter (highBit-1) -- assuming @highBit >= 1@
+
+xsB :: Unboxed BitSet Int
+xsB = fromList (BitSet 0) highestB [ 0 .. ]
+
+xoB :: Unboxed (Outside BitSet) Int
+xoB = fromList (O (BitSet 0)) (O highestB) [ 0 .. ]
+
+xsBII :: Unboxed (BitSet:>Interface First:>Interface Last) Int
+xsBII = fromList (BitSet 0:>Iter 0:>Iter 0) highestBII [ 0 .. ]
+
+-- * general quickcheck stuff
+
+options = stdArgs {maxSuccess = 1000}
+
+customCheck = quickCheckWithResult options
+
+return []
+allProps = $forAllProperties customCheck
+
diff --git a/ADP/Fusion/QuickCheck/Subword.hs b/ADP/Fusion/QuickCheck/Subword.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/QuickCheck/Subword.hs
@@ -0,0 +1,171 @@
+
+{-# Options_GHC -O0 #-}
+
+module ADP.Fusion.QuickCheck.Subword where
+
+import           Test.QuickCheck
+import           Test.QuickCheck.All
+import           Test.QuickCheck.Monadic
+import qualified Data.Vector.Fusion.Stream as S
+import           Data.Vector.Fusion.Util
+import           Debug.Trace
+import qualified Data.List as L
+import qualified Data.Vector.Unboxed as VU
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion
+import           ADP.Fusion.QuickCheck.Common
+
+
+
+-- * Outside checks
+
+-- ** two non-terminals on the r.h.s.
+--
+-- A_ij -> B_ik C_kj
+--
+-- B*_ik -> A*_ij C_kj
+-- C*_kj -> B_ik  A*_ij
+
+prop_sv_OI ox@(O (Subword (i:.k))) = zs == ls where
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  zs = ((,) <<< toa % tic ... S.toList) (O $ subword 0 highest) ox
+  ls = [ ( unsafeIndex xoS (O $ subword i j)
+         , unsafeIndex xsS (    subword k j) )
+       | j <- [ k .. highest ] ]
+
+prop_sv_IO ox@(O (Subword (k:.j))) = zs == ls where
+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  zs = ((,) <<< tib % toa ... S.toList) (O $ subword 0 highest) ox
+  ls = [ ( unsafeIndex xsS (    subword i k)
+         , unsafeIndex xoS (O $ subword i j) )
+       | j <= highest, i <- [ 0 .. k ] ]
+
+-- ** three non-terminals on the r.h.s. (this provides situations where two
+-- syntactic terminals are on the same side)
+--
+-- A_ij -> B_ik C_kl D_lj
+--
+-- B*_ik -> A*_ij C_kl  D_lj
+-- C*_kl -> B_ik  A*_ij D_lj
+-- D*_lj -> B_ik  C_kl  A*_ij
+
+prop_sv_OII ox@(O (Subword (i:.k))) = zs == ls where
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  zs = ((,,) <<< toa % tic % tid ... S.toList) (O $ subword 0 highest) ox
+  ls = [ ( unsafeIndex xoS (O $ subword i j)
+         , unsafeIndex xsS (    subword k l)
+         , unsafeIndex xsS (    subword l j) )
+       | j <- [ k .. highest ], l <- [ k .. j ] ]
+
+prop_sv_IOI ox@(O (Subword (k:.l))) = zs == ls where
+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  tid = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  zs = ((,,) <<< tib % toa % tid ... S.toList) (O $ subword 0 highest) ox
+  ls = [ ( unsafeIndex xsS (    subword i k)
+         , unsafeIndex xoS (O $ subword i j)
+         , unsafeIndex xsS (    subword l j) )
+       | i <- [ 0 .. k ], j <- [ l .. highest ] ]
+
+prop_sv_IIO ox@(O (Subword (l:.j))) = zs == ls where
+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  zs = ((,,) <<< tib % tic % toa ... S.toList) (O $ subword 0 highest) ox
+  ls = [ ( unsafeIndex xsS (    subword i k)
+         , unsafeIndex xsS (    subword k l)
+         , unsafeIndex xoS (O $ subword i j) )
+       | j <= highest, i <- [ 0 .. l ], k <- [ i .. l ] ]
+
+-- ** four non-terminals on the r.h.s. ?
+
+-- ** five non-terminals on the r.h.s. ?
+
+-- ** Non-terminal and terminal combinations
+
+prop_cOc ox@(O( Subword (i:.j))) = zs == ls where
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  zs  = ((,,) <<< chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox
+  ls  = [ ( csS VU.! (i-1)
+          , unsafeIndex xoS (O $ subword (i-1) (j+1))
+          , csS VU.! (j  ) )
+        | i > 0 && j < highest ]
+
+prop_ccOcc ox@(O(Subword (i:.j))) = zs == ls where
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  zs  = ((,,,,) <<< chr csS % chr csS % toa % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox
+  ls  = [ ( csS VU.! (i-2)
+          , csS VU.! (i-1)
+          , unsafeIndex xoS (O $ subword (i-2) (j+2))
+          , csS VU.! (j  )
+          , csS VU.! (j+1) )
+        | i > 1 && j < highest -1 ]
+
+prop_cOccc ox@(O(Subword (i:.j))) = zs == ls where
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  zs  = ((,,,,) <<< chr csS % toa % chr csS % chr csS % chr csS ... S.toList) (O $ subword 0 highest) ox
+  ls  = [ ( csS VU.! (i-1)
+          , unsafeIndex xoS (O $ subword (i-1) (j+3))
+          , csS VU.! (j  )
+          , csS VU.! (j+1)
+          , csS VU.! (j+2) )
+        | i > 0 && j < highest -2 ]
+
+-- ** Terminals, syntactic terminals, and non-terminals
+
+prop_cOcIc ox@(O (Subword (i:.k))) = zs == ls where
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  tic = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  zs = ((,,,,) <<< chr csS % toa % chr csS % tic % chr csS ... S.toList) (O $ subword 0 highest) ox
+  ls = [ ( csS VU.! (i-1)
+         , unsafeIndex xoS (O $ subword (i-1)  j    )
+         , csS VU.! (k  )
+         , unsafeIndex xsS (    subword (k+1) (j-1) )
+         , csS VU.! (j-1) )
+       | i > 0, j <- [ k+2 .. highest ] ]
+
+prop_cIcOc ox@(O (Subword (k:.j))) = zs == ls where
+  tib = ITbl 0 0 EmptyOk xsS (\ _ _ -> Id (1,1))
+  toa = ITbl 0 0 EmptyOk xoS (\ _ _ -> Id (1,1))
+  zs = ((,,,,) <<< chr csS % tib % chr csS % toa % chr csS ... S.toList) (O $ subword 0 highest) ox
+  ls = [ ( csS VU.! (i  )
+         , unsafeIndex xsS (    subword (i+1) (k-1))
+         , csS VU.! (k-1)
+         , unsafeIndex xoS (O $ subword  i    (j+1))
+         , csS VU.! (j  ) )
+       | j+1 <= highest, k>1, i <- [ 0 .. k-2 ] ]
+
+-- ** Epsilonness
+
+prop_Epsilon ox@(O (Subword (i:.j))) = zs == ls where
+  zs = (id <<< Epsilon ... S.toList) (O $ subword 0 highest) ox
+  ls = [ () | i==0 && j==highest ]
+
+
+
+highest = 2
+
+csS :: VU.Vector (Int,Int)
+csS = VU.fromList [ (i,i+1) | i <- [0 .. highest] ] -- this should be @highest -1@, we should die if we see @(highest,highest+1)@
+
+xsS :: Unboxed Subword (Int,Int)
+xsS = fromList (subword 0 0) (subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]
+
+xoS :: Unboxed (Outside Subword) (Int,Int)
+xoS = fromList (O $ subword 0 0) (O $ subword 0 highest) [ (i,j) | i <- [ 0 .. highest ] , j <- [ i .. highest ] ]
+
+-- * general quickcheck stuff
+
+options = stdArgs {maxSuccess = 10000}
+
+customCheck = quickCheckWithResult options
+
+return []
+allProps = $forAllProperties customCheck
+
diff --git a/ADP/Fusion/Region.hs b/ADP/Fusion/Region.hs
deleted file mode 100644
--- a/ADP/Fusion/Region.hs
+++ /dev/null
@@ -1,148 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-module ADP.Fusion.Region where
-
-import Data.Array.Repa.Index
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Size
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-import Data.Strict.Maybe
-import Prelude hiding (Maybe(..))
-
-import Data.Array.Repa.Index.Subword
-
-import ADP.Fusion.Classes
-
-import Control.Exception (assert)
-import Debug.Trace
-
-
-
--- * Regions of unlimited size
-
-data Region x = Region !(VU.Vector x)
-
-instance Build (Region x)
-
-instance
-  ( ValidIndex ls Subword
-  , VU.Unbox xs
-  ) => ValidIndex (ls :!: Region xs) Subword where
-  validIndex (ls :!: Region xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: Region xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b:!:c)
-  {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: Region x) Subword where
-  data Elm (ls :!: Region x) Subword = ElmRegion !(Elm ls Subword) !(VU.Vector x) !Subword
-  type Arg (ls :!: Region x)         = Arg ls :. VU.Vector x
-  getArg !(ElmRegion ls xs _) = getArg ls :. xs
-  getIdx !(ElmRegion _ _   i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , VU.Unbox x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls:!:Region x) Subword where
-  mkStream !(ls:!:Region xs) Outer !ij@(Subword (i:.j))
-    = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmRegion s (VU.unsafeSlice l (j-l) xs) (subword l j))
-    $ mkStream ls (Inner Check Nothing) ij
-  mkStream !(ls:!:Region xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
-      mk !s = let (Subword (k:.l)) = getIdx s
-                  l' = case szd of Nothing -> l
-                                   Just z  -> max l (j-z)
-              in  return (s :!: l :!: l')
-      step !(s :!: k :!: l)
-        | l > j     =  return S.Done
-        | otherwise = return $ S.Yield (ElmRegion s (VU.unsafeSlice k (l-k) xs) (subword k l)) (s :!: k :!: l+1)
-  {-# INLINE mkStream #-}
-
-region :: VU.Vector x -> Region x
-region = Region
-{-# INLINE region #-}
-
-
-
--- * Regions of unlimited size
-
-data SRegion x = SRegion !Int !Int !(VU.Vector x)
-
-instance Build (SRegion x)
-
-instance
-  ( ValidIndex ls Subword
-  , VU.Unbox xs
-  ) => ValidIndex (ls :!: SRegion xs) Subword where
-  validIndex (ls :!: SRegion lb ub xs) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-    i>=a && j<=VU.length xs -c && i+b<=j && validIndex ls abc ij
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: SRegion lb ub xs) ix = let (a:!:b:!:c) = getParserRange ls ix in (a:!:b+lb:!:max 0 (c-lb))
-  {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: SRegion x) Subword where
-  data Elm (ls :!: SRegion x) Subword = ElmSRegion !(Elm ls Subword) !(VU.Vector x) !Subword
-  type Arg (ls :!: SRegion x)         = Arg ls :. VU.Vector x
-  getArg !(ElmSRegion ls xs _) = getArg ls :. xs
-  getIdx !(ElmSRegion _ _   i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
--- |
---
--- TODO Check that all inner / outer sized calculations are correct
---
--- NOTE mkStream/Inner gives a size hint of Nothing, as in purely inner cases,
--- min/max boundaries are determined solely from the running rightmost index
--- from the next inner component.
---
--- NOTE the filter in mkStream/Outer is still necessary to check for
--- lowerbound>0 conditions. We /could/ send the lower bound down with another
--- size hint, but this only makes sense if you have use cases, where the lower
--- bound is a lot higher than "0". Otherwise the current code is simpler.
---
--- TODO use drop instead of filter: still condition, but large lower bounds are captured
---
--- TODO remove mkStream/Outer : filter and test if one condition less gives
--- much better runtimes.
-
-instance
-  ( Monad m
-  , VU.Unbox x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls:!:SRegion x) Subword where
-  mkStream !(ls:!:SRegion lb ub xs) Outer !ij@(Subword (i:.j))
-    = S.map (\s -> let (Subword (k:.l)) = getIdx s in assert (l>=0 && j-i>=0) $ ElmSRegion s (VU.slice l (j-l) xs) (subword l j))
-    $ S.filter (\s -> let (Subword (k:.l)) = getIdx s in (j-l >= lb && j-l <= ub))
-    $ mkStream ls (Inner Check (Just ub)) ij
-  mkStream !(ls:!:SRegion lb ub xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
-      mk !s = let (Subword (k:.l)) = getIdx s
-                  l' = case szd of Nothing -> l+lb
-                                   Just z  -> max (l+lb) (j-z)
-              in  return (s :!: l :!: l')
-      step !(s :!: k :!: l)
-        | l>j || l-k>ub =  return S.Done
-        | otherwise     = return $ assert (k>=0 && l-k>=0) $ S.Yield (ElmSRegion s (VU.slice k (l-k) xs) (subword k l)) (s :!: k :!: l+1)
-  {-# INLINE mkStream #-}
-
--- |
-sregion :: Int -> Int -> VU.Vector x -> SRegion x
-sregion = SRegion
-{-# INLINE sregion #-}
-
diff --git a/ADP/Fusion/SynVar.hs b/ADP/Fusion/SynVar.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar.hs
@@ -0,0 +1,17 @@
+
+-- | 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
+  ) 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
+
diff --git a/ADP/Fusion/SynVar/Array.hs b/ADP/Fusion/SynVar/Array.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Array.hs
@@ -0,0 +1,292 @@
+
+module ADP.Fusion.SynVar.Array
+  ( module ADP.Fusion.SynVar.Array.Type
+  , module ADP.Fusion.SynVar.Array.Point
+  , module ADP.Fusion.SynVar.Array.Set
+  , module ADP.Fusion.SynVar.Array.Subword
+  ) where
+
+import ADP.Fusion.SynVar.Array.Point
+import ADP.Fusion.SynVar.Array.Set
+import ADP.Fusion.SynVar.Array.Subword
+import ADP.Fusion.SynVar.Array.Type
+
+{-
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE RankNTypes #-}
+
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternGuards #-}
+
+-- | Tables in ADPfusion memoize results of parses. In the forward phase, table
+-- cells are filled by a table-filling method from @Data.PrimitiveArray@. In
+-- the backtracking phase, grammar rules are associated with tables to provide
+-- efficient backtracking.
+--
+-- TODO multi-dim tables with 'OnlyZero' need a static check!
+--
+-- TODO PointL , PointR need sanity checks for boundaries
+--
+-- TODO the sanity checks are acutally a VERY BIG TODO since currently we do
+-- not protect against stupidity at all!
+--
+-- TODO have boxed tables for top-down parsing.
+--
+-- TODO combine forward and backward phases to simplify the external interface
+-- to the programmer.
+--
+-- TODO include the notion of @interfaces@ into tables. With Outside
+-- grammars coming up now, we need this.
+
+module ADP.Fusion.Table.Array
+--  ( MTbl      (..)
+--  , BtTbl     (..)
+  ( ITbl      (..)
+--  , Backtrack (..)
+  , ToBT (..)
+  ) where
+
+import           Control.Exception(assert)
+import           Control.Monad.Primitive (PrimMonad)
+import           Data.Vector.Fusion.Stream.Size (Size(Unknown))
+import qualified Data.Vector as V
+import qualified Data.Vector.Generic as VG
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Unboxed as VU
+import           GHC.Exts
+import           Data.Bits
+
+import           Data.PrimitiveArray -- (Z(..), (:.)(..), Subword(..), subword, PointL(..), pointL, PointR(..), pointR,topmostIndex, Outside(..))
+import qualified Data.PrimitiveArray as PA
+
+import           ADP.Fusion.Classes
+import           ADP.Fusion.Multi.Classes
+import           ADP.Fusion.Table.Axiom
+import           ADP.Fusion.Table.Backtrack
+import           ADP.Fusion.Table.Indices
+
+import           Debug.Trace
+
+
+
+-- ** Mutable fill-phase tables.
+
+-- | The backtracking version.
+
+
+
+
+
+-- TODO empty table @ms@ stuff
+
+instance
+  ( Monad m
+  , Element ls (BS2I First Last)
+  , PA.PrimArrayOps arr (BS2I First Last) x
+  , MkStream m ls (BS2I First Last)
+  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where
+  -- outermost case. Grab inner indices, calculate the remainder of the
+  -- set, return value
+  mkStream (ls :!: ITbl c t _) Static s (BitSet b:>Interface i:>Interface j)
+    = S.map (\z -> let (BitSet zb:>_:>Interface zj) = getIdx z  -- the bitset we get from the guy before us
+                       here = (BitSet (b `xor` zb .|. zj):>Interface zj:>Interface j) -- everything missing, set common interface
+                   in  ElmITbl (t PA.! here) here z
+            )
+    $ mkStream ls (Variable Check Nothing) s (BitSet (clearBit b j):>Interface i:>Interface j)
+  -- generate all possible subsets of the index. With A @Variable
+  -- _ Nothing@, there is something to the right that will fill up the set.
+  mkStream (ls :!: ITbl c t _) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
+    = S.flatten mk step Unknown
+    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
+    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)
+          step (_,Nothing) = return $ S.Done
+          step (z,Just s ) = return $ S.Yield (ElmITbl (t PA.! s) s z) (z,succSet full s)
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  -- generate only those indices with the requested number of set bits
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , Element ls (BS2I First Last)
+  , PA.PrimArrayOps arr (BS2I First Last) x
+  , MkStream mB ls (BS2I First Last)
+  ) => MkStream mB (ls :!: BT (ITbl mF arr (BS2I First Last) x) mF mB r) (BS2I First Last) where
+  mkStream (ls :!: BtITbl c arr bt) Static full (BitSet b:>Interface i:>Interface j)
+    = S.map (\z -> let (BitSet zb:>Interface zi:>Interface zj) = getIdx z
+                       here = BitSet (clearBit b j):>Interface i:>Interface zj
+                       d = arr PA.! here
+                   in ElmBtITbl' d (bt full here) here z)
+    $ mkStream ls (Variable Check Nothing) full (BitSet (clearBit b j):>Interface i:>Interface (-1))
+  mkStream (ls :!: BtITbl c arr bt) (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
+    = S.flatten mk step Unknown
+    $ mkStream ls (Variable Check Nothing) full (BitSet b:>Interface i:>Interface j)
+    where mk z = return (z,Just $ BitSet 0:>Interface 0:>Interface 0)
+          step (_,Nothing) = return $ S.Done
+          step (z,Just s ) = return $ S.Yield (ElmBtITbl' (arr PA.! s) (bt full s) s z) (z,succSet full s)
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , Element ls (Outside PointL)
+  , PA.PrimArrayOps arr (Outside PointL) x
+  , MkStream m ls (Outside PointL)
+  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where
+  mkStream (ls :!: ITbl c t _) Static lu (O (PointL (i:.j)))
+    = let ms = minSize c in seq ms $ seq t $
+    S.mapM (\s -> let O (PointL (h:.k)) = getIdx s
+                  in  return $ ElmITbl (t PA.! O (pointL k j)) (O $ pointL k j) s)
+    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)
+--  mkStream _ _ _ _ = error "mkStream / ITbl / Outside PointL not implemented"
+  {-# INLINE mkStream #-}
+
+instance
+  ( Monad mB
+  , Element ls (Outside PointL)
+  , PA.PrimArrayOps arr (Outside PointL) x
+  , MkStream mB ls (Outside PointL)
+  ) => MkStream mB (ls :!: BT (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where
+  mkStream (ls :!: BtITbl c arr bt) Static lu (O (PointL (i:.j)))
+    = let ms = minSize c in ms `seq`
+    S.map (\s -> let O (PointL (h:.k)) = getIdx s
+                     ix                = O $ pointL k j
+                     d                 = arr PA.! ix
+                 in ElmBtITbl' d (bt lu ix) ix s)
+    $ mkStream ls (Variable Check Nothing) lu (O . pointL i $ j + ms)
+--  mkStream _ _ _ _ = error "mkStream / BT ITbl / Outside PointL not implemented"
+  {-# INLINE mkStream #-}
+
+-- | TODO As soon as we don't do static checking on @EmptyOk/NonEmpty@
+-- anymore, this works! If we check @c@, we immediately have fusion
+-- breaking down!
+
+{-
+instance
+  ( Monad m
+  , Element ls Subword
+  , PA.PrimArrayOps arr Subword x
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where
+  mkStream (ls :!: ITbl c t _) Static lu (Subword (i:.j))
+    = let ms = minSize c in ms `seq`
+      S.mapM (\s -> let Subword (_:.l) = getIdx s
+                    in  return $ ElmITbl (t PA.! subword l j) (subword l j) s)
+    $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms) -- - minSize c)
+  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (Subword (i:.j))
+    = let ms = minSize c
+          {- data PBI a = PBI !a !(Int#)
+          mk s = let (Subword (_:.l)) = getIdx s ; !(I# jlm) = j-l-ms in return $ PBI s jlm
+          step !(PBI s z) | 1# <- z >=# 0# = do let (Subword (_:.k)) = getIdx s
+                                                return $ S.Yield (ElmITbl (t PA.! subword k (j-(I# z))) (subword k $ j-(I# z)) s) (PBI s (z -# 1#))
+                          | otherwise = return S.Done
+          -}
+          {-
+          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)
+          step (s:.z) | 1# <- z' >=# 0# = do let (Subword (_:.k)) = getIdx s
+                                             return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)
+                      | otherwise = return S.Done
+                      where !(I# z') = z
+          -}
+          mk s = let (Subword (_:.l)) = getIdx s in return (s :. j - l - ms)
+          step (s:.z) | z>=0 = do let (Subword (_:.k)) = getIdx s
+                                  return $ S.Yield (ElmITbl (t PA.! subword k (j-z)) (subword k $ j-z) s) (s:.z-1)
+                      | otherwise = return S.Done
+          {-# INLINE [1] mk #-}
+          {-# INLINE [1] step #-}
+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
+  {-# INLINE mkStream #-}
+-}
+
+{-
+instance
+  ( Monad mB
+  , Element ls Subword
+  , MkStream mB ls Subword
+  , PA.PrimArrayOps arr Subword x
+  ) => MkStream mB (ls :!: BT (ITbl mF arr Subword x) mF mB r) Subword where
+  mkStream (ls :!: BtITbl c arr bt)  Static lu (Subword (i:.j))
+    = let ms = minSize c in ms `seq`
+      S.map (\s -> let (Subword (_:.l)) = getIdx s
+                       ix               = subword l j
+                       d                = arr PA.! ix
+                   in  ElmBtITbl' d (bt lu ix) ix s)
+      $ mkStream ls (Variable Check Nothing) lu (subword i $ j - ms)
+  mkStream (ls :!: BtITbl c arr bt) (Variable _ Nothing) lu (Subword (i:.j))
+    = let ms = minSize c
+          mk s = let (Subword (_:.l)) = getIdx s in return (s:.j-l-ms)
+          step (s:.z)
+            | z>=0      = do let (Subword (_:.k)) = getIdx s
+                                 ix               = subword k (j-z)
+                                 d                = arr PA.! ix
+                             return $ S.Yield (ElmBtITbl' d (bt lu ix) ix s) (s:.z-1)
+            | otherwise = return $ S.Done
+          {-# INLINE [1] mk   #-}
+          {-# INLINE [1] step #-}
+      in  ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (subword i j)
+  {-# INLINE mkStream #-}
+-}
+
+{-
+instance
+  ( Monad m
+  , Element ls (Outside Subword)
+  , PA.PrimArrayOps arr Subword x
+  , MkStream m ls (Outside Subword)
+  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where
+  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))
+    = let ms = minSize c in ms `seq`
+      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s
+                    in  return $ ElmITbl (t PA.! (subword l j)) (O $ subword l j) s)
+    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)
+  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))
+    = let ms = minSize c
+          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)
+          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s
+                                  return $ S.Yield (ElmITbl (t PA.! (subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)
+                      | otherwise = return S.Done
+          {-# INLINE [1] mk #-}
+          {-# INLINE [1] step #-}
+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)
+  {-# INLINE mkStream #-}
+-}
+
+{-
+instance
+  ( Monad m
+  , Element ls (Outside Subword)
+  , PA.PrimArrayOps arr (Outside Subword) x
+  , MkStream m ls (Outside Subword)
+  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where
+  mkStream (ls :!: ITbl c t _) Static lu (O (Subword (i:.j)))
+    = let ms = minSize c in ms `seq`
+      S.mapM (\s -> let (O (Subword (_:.l))) = getIdx s
+                    in  return $ ElmITbl (t PA.! (O $ subword l j)) (O $ subword l j) s)
+    $ mkStream ls (Variable Check Nothing) lu (O $ subword i $ j - ms) -- - minSize c)
+  mkStream (ls :!: ITbl c t _) (Variable _ Nothing) lu (O (Subword (i:.j)))
+    = let ms = minSize c
+          mk s = let (O( Subword (_:.l))) = getIdx s in return (s :. j - l - ms)
+          step (s:.z) | z>=0 = do let (O (Subword (_:.k))) = getIdx s
+                                  return $ S.Yield (ElmITbl (t PA.! (O $ subword k (j-z))) (O . subword k $ j-z) s) (s:.z-1)
+                      | otherwise = return S.Done
+          {-# INLINE [1] mk #-}
+          {-# INLINE [1] step #-}
+      in ms `seq` S.flatten mk step Unknown $ mkStream ls (Variable NoCheck Nothing) lu (O $ subword i j)
+  {-# INLINE mkStream #-}
+-}
+
+
+
+
+-- * Axiom for backtracking
+
+-}
+
diff --git a/ADP/Fusion/SynVar/Array/Point.hs b/ADP/Fusion/SynVar/Array/Point.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Array/Point.hs
@@ -0,0 +1,79 @@
+
+module ADP.Fusion.SynVar.Array.Point where
+
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Monadic
+import Data.Vector.Fusion.Stream.Size
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import Prelude hiding (map,mapM)
+--import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import           Data.PrimitiveArray hiding (map)
+
+import           ADP.Fusion.Base
+import           ADP.Fusion.SynVar.Array.Type
+import           ADP.Fusion.SynVar.Backtrack
+
+
+
+instance
+  ( Monad m
+  , Element ls PointL
+  , PrimArrayOps arr PointL x
+  , MkStream m ls PointL
+  ) => MkStream m (ls :!: ITbl m arr PointL x) PointL where
+  mkStream (ls :!: ITbl _ _ c t _) (IStatic d) u j@(PointL pj)
+    = let ms = minSize c in ms `seq`
+    map (ElmITbl (t!j) j (PointL 0))
+    $ mkStream ls (IVariable d) u (PointL $ pj - ms)
+  -- We can't really make sure that this is the only time we access the
+  -- ITbl, so the user should know what they are doing.
+  mkStream (ls :!: ITbl _ _ c t _) (IVariable d) u j@(PointL pj)
+    = flatten mk step Unknown $ mkStream ls (IVariable d) u (delay_inline PointL $! pj - ms)
+    where mk s = let PointL k = getIdx s in return (s :. k)
+          step (s :. k)
+            | k+ms>pj   = return $ Done
+            | otherwise = return $ Yield (ElmITbl (t!PointL k) (PointL k) (PointL 0) s) (s :. k+1)
+          !ms = minSize c
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , Element ls PointL
+  , PrimArrayOps arr PointL x
+  , MkStream mB ls PointL
+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr PointL x) mF mB r) PointL where
+  mkStream (ls :!: BtITbl c t bt) (IStatic d) u j@(PointL pj)
+    = let ms = minSize c in ms `seq`
+    mapM (\s -> bt u j >>= \bb -> return $ ElmBtITbl (t!j) (bb {-bt u j-}) j (PointL 0) s)
+    $ mkStream ls (IVariable d) u (PointL $ pj - ms)
+  {-# INLINE mkStream #-}
+
+instance
+  ( Monad m
+  , Element ls (Outside PointL)
+  , PrimArrayOps arr (Outside PointL) x
+  , MkStream m ls (Outside PointL)
+  ) => MkStream m (ls :!: ITbl m arr (Outside PointL) x) (Outside PointL) where
+  mkStream (ls :!: ITbl _ _ c t _) (OStatic d) u (O (PointL pj))
+    = let ms = minSize c in ms `seq`
+    map (\z -> let o = getOmx z
+                 in  ElmITbl (t ! o) o o z)
+    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , Element ls (Outside PointL)
+  , PrimArrayOps arr (Outside PointL) x
+  , MkStream mB ls (Outside PointL)
+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside PointL) x) mF mB r) (Outside PointL) where
+  mkStream (ls :!: BtITbl c t bt) (OStatic d) u (O (PointL pj))
+    = let ms = minSize c in ms `seq`
+    mapM (\s -> let o = getOmx s in bt u o >>= \bb -> return $ ElmBtITbl (t!o) (bb{-bt u o-}) o o s)
+    $ mkStream ls (OFirstLeft d) u (O $ PointL $ pj - ms)
+  {-# INLINE mkStream #-}
+
diff --git a/ADP/Fusion/SynVar/Array/Set.hs b/ADP/Fusion/SynVar/Array/Set.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Array/Set.hs
@@ -0,0 +1,164 @@
+
+module ADP.Fusion.SynVar.Array.Set where
+
+import Data.Bits
+import Data.Bits.Extras
+import Data.Bits.Ordered
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Monadic
+import Data.Vector.Fusion.Stream.Size
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import Prelude hiding (map)
+import Control.Applicative ((<$>))
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Array.Type
+import ADP.Fusion.SynVar.Backtrack
+
+
+
+-- * Bitsets without any interfaces.
+
+-- NOTE that we have to give as the filled index elements all bits that are
+-- set in total, not just those we set right here. Otherwise the next
+-- element will try a wrong set of indices.
+--
+-- NOTE even in the @IStatic@ case, we need to use flatten. If a node
+-- requested a reserved bit, we need to free each reserved bit at least
+-- once.
+
+instance
+  ( Monad m
+  , Element ls BitSet
+  , PrimArrayOps arr BitSet x
+  , MkStream m ls BitSet
+  ) => MkStream m (ls :!: ITbl m arr BitSet x) BitSet where
+  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u s
+    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable $ rp - csize) u s
+    where !csize | c==EmptyOk  = 0
+                 | c==NonEmpty = 1
+          mk z
+            | cm < csize = return (z , mask , Nothing)
+            | otherwise  = return (z , mask , Just k )
+            where k  = (BitSet $ 2^cm-1)
+                  cm = popCount mask - rp
+                  mask = s `xor` (getIdx z)
+          step (_,_,Nothing) = return $ Done
+          step (z,mask,Just k)
+            | pk > popCount s - rp = return $ Done
+            | otherwise            = let kk = popShiftL mask k
+                                     in  return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,setSucc (BitSet 0) (2^pk -1) k)
+            where pk = popCount k
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  mkStream (ls :!: ITbl _ _ c t _) (IVariable rp) u s
+    = flatten mk step Unknown $ mkStream ls (IVariable rp) u s
+    where mk z
+            | c==EmptyOk  = return (z , mask , cm , Just 0 )
+            | cm == 0     = return (z , mask , cm , Nothing) -- we are non-empty but have no free bits left
+            | c==NonEmpty = return (z , mask , cm , Just 1 )
+            where mask = s `xor` (getIdx z) -- bits that are still free
+                  cm   = popCount mask
+          step (z,mask,cm,Nothing) = return $ Done
+          step (z,mask,cm,Just k )
+            | popCount s < popCount (kk .|. getIdx z) + rp = return $ Done
+            | otherwise = return $ Yield (ElmITbl (t!kk) (kk .|. getIdx z) (BitSet 0) z) (z,mask,cm,setSucc (BitSet 0) (2^cm -1) k)
+            where kk = popShiftL mask k
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
+
+
+-- * Bitsets with two interfaces.
+--
+-- NOTE These are annoying to get right, if you also want to have good
+-- performance.
+
+instance
+  ( Monad m
+  , Element ls (BS2I First Last)
+  , PrimArrayOps arr (BS2I First Last) x
+  , MkStream m ls (BS2I First Last)
+  , Show x
+  ) => MkStream m (ls :!: ITbl m arr (BS2I First Last) x) (BS2I First Last) where
+  mkStream (ls :!: ITbl _ _ c t _) (IStatic rp) u sij@(s:>i:>j@(Iter jj))
+    = flatten mk step Unknown $ mkStream ls (delay_inline IVariable rpn) u (delay_inline id $ tij)
+          -- calculate new index. if we don't know the right-most interface
+          -- anymore, than someone has taken it already. Also, if this
+          -- synvar may be empty, do not modify the index. Otherwise, if
+          -- @j@ is still known, remove it from the index set.
+    where tij | jj == -1       = sij
+              | c  == EmptyOk  = sij
+              | c  == NonEmpty = s `clearBit` jj :> i :> Iter (-1)
+          -- In case we do not know the rightmost interface, we instead
+          -- increase the number of reserved bits.
+          rpn | jj == -1
+              && c == NonEmpty = rp+1
+              | otherwise      = rp
+          nec | c == NonEmpty = 1
+              | c == EmptyOk  = 0
+          mk z
+            -- in case we have a non-empty synvar but not enough bits, we
+            -- shall have nothing. We only need one extra mask bit, because
+            -- @j@ is still known.
+            | popCount mask < 1 && c == NonEmpty && j >= 0 = return $ Naught
+            -- If @j@ is not known we need two bits to be non-empty.
+            | popCount mask < 2 && c == NonEmpty && j <  0 = return $ Naught
+            -- Not enough bits to reserve.
+            | popCount mask - rp < 0                       = return $ Naught
+            -- @j@ is still known, just create the sets ending in @j@
+            | j >= 0                                       = return $ This (z,mask)
+            -- @j@ is not known, we have a lot of work to do. Create the
+            -- required @bits@ and prepare a @mask@ which will set the
+            -- correct bits.
+            | j <  0                                       = return $ That (z,mask,Just bits,maybeLsb bits)
+            -- we somehow ended up with an improper state
+            | otherwise                                    = error $ show (sij,mask,bits)
+            where (zs:>_:>Iter zk) = getIdx z
+                  mask             = s `xor` zs
+                  bits             = BitSet $ 2 ^ (popCount mask - rp - nec) - 1
+          step Naught          = return $ Done
+          -- In case @j@ is known, we calculate the bits @msk@ that are not
+          -- filled yet. We grab the previous right interface @zk@ and use
+          -- it as the new left interface. We also use @j@ as the right
+          -- interface. @ix@ holds everything that is now covered, withe
+          -- the interface @i@ and @j@.
+          step (This (z,mask)) = return $ Yield (ElmITbl (t!(msk:>k:>j)) ix undefbs2i z) Naught
+            where (zs:>_:>zk) = getIdx z
+                  k           = Iter $ getIter zk
+                  ix          = (zs .|. msk) :> i :> j
+                  msk         = if popCount mask == 0 then mask else mask `setBit` getIter k `setBit` jj
+          -- whenever there is nothing more to do in the variable case.
+          step (That (z,mask,Nothing,_)) = return $ Done
+          -- We need to permute our population a bit. Once done, we grab
+          -- the lowest significant bit.
+          step (That (z,mask,Just bits,Nothing)) = return $ Skip (That (z,mask,nbts, maybeLsb =<< nbts))
+            where nbts = popPermutation (popCount mask) bits
+          -- The variable case.
+          step (That (z,mask,Just bits,Just y))
+            -- we do not have enough bits to be non-empty.
+            |  popCount bb < 2 && c == NonEmpty
+            -- our two interfaces are the same, but we are non-empty in
+            -- which case this shouldn't happen.
+            || getIter kk == getIter yy && c == NonEmpty
+            -- our pop-count plus reserved count doesn't match up with the
+            -- mask. We skip this as well.
+            || popCount bb + rp /= popCount mask = return $ Skip (That (z,mask,Just bits, maybeNextActive y bits))
+            -- finally, we can create the index for the current stuff
+            -- @bb:>kk:>yy@ and prepare the full index, going from @i@ to
+            -- @yy@, because someone grabbed @j@ already. Must have been
+            -- an @Edge@ or s.th. similar.
+            | otherwise = return $ Yield (ElmITbl (t!(bb:>kk:>yy)) ((zs .|. bb):>i:>yy) undefbs2i z)
+                                                                 (That (z,mask,Just bits, maybeNextActive y bits))
+            where (zs:>_:>zk) = getIdx z
+                  kk          = Iter $ getIter zk
+                  yy          = Iter . lsb $ popShiftL mask (bit y)
+                  bb          = popShiftL mask bits `setBit` getIter kk `setBit` getIter yy
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
diff --git a/ADP/Fusion/SynVar/Array/Subword.hs b/ADP/Fusion/SynVar/Array/Subword.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Array/Subword.hs
@@ -0,0 +1,174 @@
+
+module ADP.Fusion.SynVar.Array.Subword where
+
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Size
+import Data.Vector.Fusion.Util (delay_inline)
+import Data.Vector.Fusion.Stream.Monadic
+import Debug.Trace
+import Prelude hiding (map,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Array.Type
+import ADP.Fusion.SynVar.Backtrack
+
+
+
+
+-- TODO delay inline @(subword i $ j - minSize c)@ or face fusion-breakage.
+-- Can we just have @Inline [0] subword@ to fix this?
+
+instance
+  ( Monad m
+  , Element ls Subword
+  , PrimArrayOps arr Subword x
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: ITbl m arr Subword x) Subword where
+  mkStream (ls :!: ITbl _ _ c t _) (IStatic ()) hh (Subword (i:.j))
+    = map (\s -> let (Subword (_:.l)) = getIdx s
+                 in  ElmITbl (t ! subword l j) (subword l j) (subword 0 0) s)
+    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
+  mkStream (ls :!: ITbl _ _ c t _) (IVariable ()) hh (Subword (i:.j))
+    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
+    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)
+          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
+                                        l              = j - z
+                                        kl             = subword k l
+                                    return $ Yield (ElmITbl (t ! kl) kl (subword 0 0) s) (s:. z-1)
+                      | otherwise = return $ Done
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , Element ls Subword
+  , MkStream mB ls Subword
+  , PrimArrayOps arr Subword x
+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr Subword x) mF mB r) Subword where
+  mkStream (ls :!: BtITbl c t bt) (IStatic ()) hh ij@(Subword (i:.j))
+    = mapM (\s -> let Subword (_:.l) = getIdx s
+                      lj             = subword l j
+                  in  bt hh lj >>= \ ~bb -> return $ ElmBtITbl (t ! lj) (bb {-bt hh lj-}) lj (subword 0 0) s)
+    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
+  mkStream (ls :!: BtITbl c t bt) (IVariable ()) hh ij@(Subword (i:.j))
+    = flatten mk step Unknown $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j - minSize c))
+    where mk s = let Subword (_:.l) = getIdx s in return (s :. j - l - minSize c)
+          step (s:.z) | z >= 0 = do let Subword (_:.k) = getIdx s
+                                        l              = j - z
+                                        kl             = subword k l
+                                    bt hh kl >>= \ ~bb -> return $ Yield (ElmBtITbl (t ! kl) (bb {-bt hh kl-}) kl (subword 0 0) s) (s:.z-1)
+                      | otherwise = return $ Done
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
+
+instance
+  ( Monad m
+  , Element ls (Outside Subword)
+  , PrimArrayOps arr (Outside Subword) x
+  , MkStream m ls (Outside Subword)
+  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Outside Subword) where
+  -- TODO what about @c / minSize@
+  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
+    = map (\s -> let O (Subword (k:._)) = getOmx s
+                     kj = O $ Subword (k:.j+dj)
+                 in  ElmITbl (t ! kj) (O $ Subword (i:.j+dj)) kj s) -- @ij@ or s.th. else shouldn't matter?
+    $ mkStream ls (OFirstLeft (di:.dj)) u ij
+  mkStream (ls :!: ITbl _ _ c t _) (ORightOf (di:.dj)) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
+    = flatten mk step Unknown $ mkStream ls (OFirstLeft (di:.dj)) u ij
+      where mk s = return (s:.j+dj)
+            step (s:.l) | l <= h = do let (O (Subword (k:._))) = getIdx s
+                                          kl = O $ Subword (k:.l)
+                                      return $ Yield (ElmITbl (t ! kl) (O (Subword (j+dj:.j+dj))) kl s) (s:.l+1)
+                        | otherwise = return $ Done
+            {-# Inline [0] mk   #-}
+            {-# Inline [0] step #-}
+  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft d) u ij = error "Array/Outside Subword : OFirstLeft : should never be reached!"
+  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij = error "Array/Outside Subword : OLeftOf : should never be reached!"
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( Monad m
+  , Element ls (Outside Subword)
+  , PrimArrayOps arr Subword x
+  , MkStream m ls (Outside Subword)
+  ) => MkStream m (ls :!: ITbl m arr Subword x) (Outside Subword) where
+  -- TODO what about @c / minSize@
+  mkStream (ls :!: ITbl _ _ c t _) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
+    = map (\s -> let O (Subword (_:.k))     = getIdx s
+                     o@(O (Subword (_:.l))) = getOmx s
+                     kl = Subword (k-dj:.l-dj)
+                 in ElmITbl (t ! kl) (O (Subword (k:.l))) o s)
+    $ mkStream ls (ORightOf (di:.dj)) u ij
+  mkStream (ls :!: ITbl _ _ c t _) (ORightOf d) u@(O (Subword (_:.h))) ij@(O (Subword (i:.j)))
+    = flatten mk step Unknown $ mkStream ls (ORightOf d) u ij
+    where mk s = let O (Subword (_:.l)) = getIdx s
+                 in  return (s :.l:.l + minSize c)
+          step (s:.k:.l)
+            | let O (Subword (_:.o)) = getOmx s
+            , l <= o = do let kl = Subword (k:.l)
+                          return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.k:.l+1)
+            | otherwise = return $ Done
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  mkStream (ls :!: ITbl _ _ c t _) (OFirstLeft (di:.dj)) u ij@(O (Subword (i:.j)))
+    = map (\s -> let O (Subword (l:._)) = getOmx s
+                     O (Subword (_:.k)) = getIdx s
+                     kl = Subword (k:.i-di)
+                 in  ElmITbl (t ! kl) (O kl) (getOmx s) s)
+    $ mkStream ls (OLeftOf (di:.dj)) u ij
+  mkStream (ls :!: ITbl _ _ c t _) (OLeftOf d) u ij@(O (Subword (i:.j)))
+    = flatten mk step Unknown $ mkStream ls (OLeftOf d) u ij
+    where mk s = let O (Subword (_:.l)) = getIdx s in return (s:.l)
+          step (s:.l) | l <= i = do let O (Subword (_:.k)) = getIdx s
+                                        kl = Subword (k:.l)
+                                    return $ Yield (ElmITbl (t ! kl) (O kl) (getOmx s) s) (s:.l+1)
+                      | otherwise = return $ Done
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , Element ls (Complement Subword)
+  , PrimArrayOps arr Subword x
+  , MkStream m ls (Complement Subword)
+  ) => MkStream m (ls :!: ITbl m arr Subword x) (Complement Subword) where
+  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
+    = map (\s -> let (C ix) = getIdx s
+                 in  ElmITbl (t ! ix) (C ix) (getOmx s) s)
+    $ mkStream ls Complemented u ij
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , Element ls (Complement Subword)
+  , PrimArrayOps arr (Outside Subword) x
+  , MkStream m ls (Complement Subword)
+  ) => MkStream m (ls :!: ITbl m arr (Outside Subword) x) (Complement Subword) where
+  mkStream (ls :!: ITbl _ _ c t _) Complemented u ij
+    = map (\s -> let (C ox) = getOmx s      -- TODO shouldn't this be @getIdx@ as well? on the count of everything being terminals in Complement?
+                 in  ElmITbl (t ! (O ox)) (getIdx s) (C ox) s)
+    $ mkStream ls Complemented u ij
+  {-# Inline mkStream #-}
+
+
+
+instance ModifyConstraint (ITbl m arr Subword x) where
+  toNonEmpty (ITbl b l _ arr f) = ITbl b l NonEmpty arr f
+  toEmpty    (ITbl b l _ arr f) = ITbl b l EmptyOk  arr f
+  {-# Inline toNonEmpty #-}
+  {-# Inline toEmpty #-}
+
+instance ModifyConstraint (Backtrack (ITbl mF arr Subword x) mF mB r) where
+  toNonEmpty (BtITbl _ arr bt) = BtITbl NonEmpty arr bt
+  toEmpty    (BtITbl _ arr bt) = BtITbl EmptyOk  arr bt
+  {-# Inline toNonEmpty #-}
+  {-# Inline toEmpty #-}
+
diff --git a/ADP/Fusion/SynVar/Array/Type.hs b/ADP/Fusion/SynVar/Array/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Array/Type.hs
@@ -0,0 +1,144 @@
+
+module ADP.Fusion.SynVar.Array.Type where
+
+import Data.Strict.Tuple hiding (uncurry,snd)
+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM)
+import Debug.Trace
+import Prelude hiding (map,head,mapM)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Backtrack
+import ADP.Fusion.SynVar.Axiom
+import ADP.Fusion.SynVar.Indices
+
+
+
+-- | Immutable table.
+
+data ITbl m arr i x where
+  ITbl :: { iTblBigOrder    :: !Int
+          , iTblLittleOrder :: !Int
+          , iTblConstraint  :: !(TblConstraint i)
+          , iTblArray       :: !(arr i x)
+          , iTblFun         :: !(i -> i -> m x)
+          } -> ITbl m arr i x
+
+instance Build (ITbl m arr i x)
+
+instance GenBacktrackTable (ITbl mF arr i x) mF mB r where
+  data Backtrack (ITbl mF arr i x) mF mB r = BtITbl !(TblConstraint i) !(arr i x) (i -> i -> mB [r])
+  type BacktrackIndex (ITbl mF arr i x) = i
+  toBacktrack (ITbl _ _ c arr _) _ bt = BtITbl c arr bt
+  {-# Inline toBacktrack #-}
+
+instance
+  ( Monad m
+  , PrimArrayOps arr i x
+  , IndexStream i
+  ) => Axiom (ITbl m arr i x) where
+  type AxiomStream (ITbl m arr i x) = m x
+  axiom (ITbl _ _ c arr _) = do
+    k <- (head . uncurry streamDown) $ bounds arr
+    return $ arr ! k
+  {-# Inline axiom #-}
+
+instance
+  ( Monad mB
+  , PrimArrayOps arr i x
+  , IndexStream i
+  ) => Axiom (Backtrack (ITbl mF arr i x) mF mB r) where
+  type AxiomStream (Backtrack (ITbl mF arr i x) mF mB r) = mB [r]
+  axiom (BtITbl c arr bt) = do
+    h <- (head . uncurry streamDown) $ bounds arr
+    bt (snd $ bounds arr) h
+  {-# Inline axiom #-}
+
+instance Element ls i => Element (ls :!: ITbl m arr j x) i where
+  data Elm (ls :!: ITbl m arr j x) i = ElmITbl !x !i !i !(Elm ls i)
+  type Arg (ls :!: ITbl m arr j x)   = Arg ls :. x
+  getArg (ElmITbl x _ _ ls) = getArg ls :. x
+  getIdx (ElmITbl _ i _ _ ) = i
+  getOmx (ElmITbl _ _ o _ ) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+deriving instance (Show i, Show (Elm ls i), Show x) => Show (Elm (ls :!: ITbl m arr j x) i)
+
+instance Element ls i => Element (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i where
+  data Elm (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i = ElmBtITbl !x [r] !i !i !(Elm ls i)
+  type Arg (ls :!: (Backtrack (ITbl mF arr i x) mF mB r))   = Arg ls :. (x, [r])
+  getArg (ElmBtITbl x s _ _ ls) = getArg ls :. (x,s)
+  getIdx (ElmBtITbl _ _ i _ _ ) = i
+  getOmx (ElmBtITbl _ _ _ o _ ) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+instance (Show x, Show i, Show (Elm ls i)) => Show (Elm (ls :!: (Backtrack (ITbl mF arr i x) mF mB r)) i) where
+  show (ElmBtITbl x _ i o s) = show (x,i,o) ++ " " ++ show s
+
+instance
+  ( Monad m
+  , Element ls (is:.i)
+  , TableStaticVar (is:.i)
+  , TableIndices (is:.i)
+  , MkStream m ls (is:.i)
+  , PrimArrayOps arr (is:.i) x
+  ) => MkStream m (ls :!: ITbl m arr (is:.i) x) (is:.i) where
+  mkStream (ls :!: ITbl _ _ c t _) vs lu is
+    = map (\(S5 s _ _ i o) -> ElmITbl (t ! i) i o s)
+    . tableIndices c vs is
+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
+    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , Element ls (is:.i)
+  , TableStaticVar (is:.i)
+  , TableIndices (is:.i)
+  , MkStream mB ls (is:.i)
+  , PrimArrayOps arr (is:.i) x
+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (is:.i) x) mF mB r) (is:.i) where
+  mkStream (ls :!: BtITbl c t bt) vs us is
+    = mapM (\(S5 s _ _ i o) -> bt us i >>= \ ~bb -> return $ ElmBtITbl (t ! i) (bb {-bt us i-}) i o s)
+    . tableIndices c vs is
+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
+    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , Element ls (Outside (is:.i))
+  , TableStaticVar (Outside (is:.i))
+  , TableIndices (Outside (is:.i))
+  , MkStream m ls (Outside (is:.i))
+  , PrimArrayOps arr (Outside (is:.i)) x
+  , Show (is:.i)
+  ) => MkStream m (ls :!: ITbl m arr (Outside (is:.i)) x) (Outside (is:.i)) where
+  mkStream (ls :!: ITbl _ _ c t _) vs lu is
+    = map (\(S5 s _ _ i o) -> ElmITbl (t ! o) i o s)
+    . tableIndices c vs is
+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
+    $ mkStream ls (tableStaticVar vs is) lu (tableStreamIndex c vs is)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad mB
+  , Element ls (Outside (is:.i))
+  , TableStaticVar (Outside (is:.i))
+  , TableIndices (Outside (is:.i))
+  , MkStream mB ls (Outside (is:.i))
+  , PrimArrayOps arr (Outside (is:.i)) x
+  , Show (is:.i)
+  ) => MkStream mB (ls :!: Backtrack (ITbl mF arr (Outside (is:.i)) x) mF mB r) (Outside (is:.i)) where
+  mkStream (ls :!: BtITbl c t bt) vs us is
+    = mapM (\(S5 s _ _ i o) -> bt us o >>= \bb -> return $ ElmBtITbl (t ! o) (bb {-bt us o-}) i o s)
+    . tableIndices c vs is
+    . map (\s -> S5 s Z Z (getIdx s) (getOmx s))
+    $ mkStream ls (tableStaticVar vs is) us (tableStreamIndex c vs is)
+  {-# Inline mkStream #-}
+
diff --git a/ADP/Fusion/SynVar/Axiom.hs b/ADP/Fusion/SynVar/Axiom.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Axiom.hs
@@ -0,0 +1,14 @@
+
+-- | The 'axiom' runs a backtracking algebra. The name comes from Robert
+-- Giegerichs @ADP@ where @axiom@ runs the fully formed algorithm.
+
+module ADP.Fusion.SynVar.Axiom where
+
+-- | The Axiom type class
+
+class Axiom t where
+  -- | The corresponding stream being returned by 'axiom'
+  type AxiomStream t :: *
+  -- | Given a table, run the axiom
+  axiom :: t -> AxiomStream t
+
diff --git a/ADP/Fusion/SynVar/Backtrack.hs b/ADP/Fusion/SynVar/Backtrack.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Backtrack.hs
@@ -0,0 +1,28 @@
+
+-- | Wrap forward tables in such a way as to allow backtracking via
+-- algebras.
+
+module ADP.Fusion.SynVar.Backtrack where
+
+import Data.Vector.Fusion.Stream.Monadic (Stream)
+
+import ADP.Fusion.Base
+
+
+
+-- |
+--
+-- TODO this should go into @ADP.Fusion.Table.Backtrack@, more than just
+-- tabulated syntactic vars are going to use it.
+--
+-- NOTE You probably need to give the @monad morphism@ between @mF@ and
+-- @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 :: *
+  type BacktrackIndex t :: *
+  toBacktrack :: t -> (forall a . mF a -> mB a) -> (BacktrackIndex t -> BacktrackIndex t -> mB [r]) -> Backtrack t mF mB r
+
+instance Build (Backtrack t mF mB r)
+
diff --git a/ADP/Fusion/SynVar/Fill.hs b/ADP/Fusion/SynVar/Fill.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Fill.hs
@@ -0,0 +1,180 @@
+
+module ADP.Fusion.SynVar.Fill where
+
+import           Control.Monad.Morph (hoist, MFunctor (..))
+import           Control.Monad.Primitive (PrimMonad (..))
+import           Control.Monad.ST
+import           Control.Monad.Trans.Class (lift, MonadTrans (..))
+import           Data.Vector.Fusion.Util (Id(..))
+import           GHC.Exts (inline)
+import qualified Data.Vector.Fusion.Stream.Monadic as SM
+import           System.IO.Unsafe
+import           Control.Monad (when,forM_)
+import           Data.List (nub,sort)
+import qualified Data.Vector.Unboxed as VU
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.SynVar.Array -- TODO we want to keep only classes in here, move instances to the corresponding modules
+
+import           Debug.Trace
+
+
+
+-- * Specialized table-filling wrapper for 'MTbl's
+--
+-- TODO table-filling does /not/ work for single-dimensional stuff
+
+-- | Run and freeze 'MTbl's. Since actually running the table-filling part
+-- is usually the last thing to do, we can freeze as well.
+
+runFreezeMTbls ts = do
+    unsafeRunFillTables $ expose ts
+    freezeTables        $ onlyTables ts
+{-# INLINE runFreezeMTbls #-}
+
+
+
+-- * Expose inner mutable tables
+
+-- | Expose the actual mutable table with an 'MTbl'. (Should be temporary
+-- until 'MTbl's get a more thorough treatment for auto-filling.
+
+class ExposeTables t where
+    type TableFun t   :: *
+    type OnlyTables t :: *
+    expose     :: t -> TableFun t
+    onlyTables :: t -> OnlyTables t
+
+instance ExposeTables Z where
+    type TableFun Z   = Z
+    type OnlyTables Z = Z
+    expose     Z = Z
+    onlyTables Z = Z
+    {-# INLINE expose #-}
+    {-# INLINE onlyTables #-}
+
+-- Thanks to the table being a gadt we now the internal types
+--
+-- TODO move to Table/Array.hs
+
+--instance (ExposeTables ts) => ExposeTables (ts:.(MTbl m arr i x)) where
+--    type TableFun   (ts:. MTbl m arr i x) = TableFun   ts :. (PA.MutArr m (arr i x), i -> m x)
+--    type OnlyTables (ts:. MTbl m arr i x) = OnlyTables ts :. (PA.MutArr m (arr i x))
+--    expose     (ts:.MTbl _ t f) = expose ts :. (t,f)
+--    onlyTables (ts:.MTbl _ t _) = onlyTables ts :. t
+--    {-# INLINE expose #-}
+--    {-# INLINE onlyTables #-}
+
+
+
+-- * Unsafely mutate 'ITbls' and similar tables in the forward phase.
+
+-- | Mutate a cell in a stack of syntactic variables.
+--
+-- TODO generalize to monad morphism via @mmorph@ package. This will allow
+-- more interesting @mrph@ functions that can, for example, track some
+-- state in the forward phase. (Note that this can be dangerous, we do
+-- /not/ want to have this state influence forward results, unless that can
+-- be made deterministic, or we'll break Bellman)
+
+class MutateCell (s :: *) (im :: * -> *) (om :: * -> *) i where
+  mutateCell :: Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om ()
+
+-- |
+
+class MutateTables (s :: *) (im :: * -> *) (om :: * -> *) where
+  mutateTables :: (forall a . im a -> om a) -> s -> om s
+
+class TableOrder (s :: *) where
+  tableLittleOrder :: s -> [Int]
+  tableBigOrder :: s -> [Int]
+
+instance TableOrder Z where
+  tableLittleOrder Z = []
+  tableBigOrder Z = []
+  {-# Inline tableLittleOrder #-}
+  {-# Inline tableBigOrder #-}
+
+instance (TableOrder ts) => TableOrder (ts:.ITbl im arr i x) where
+  tableLittleOrder (ts:.ITbl _ tlo _ _ _) = tlo : tableLittleOrder ts
+  tableBigOrder    (ts:.ITbl tbo _ _ _ _) = tbo : tableBigOrder ts
+  {-# Inline tableLittleOrder #-}
+  {-# Inline tableBigOrder #-}
+
+-- ** individual instances for filling a *single cell*
+
+instance
+  ( PrimArrayOps  arr i x
+  , MPrimArrayOps arr i x
+  , MutateCell ts im om i
+  , PrimMonad om
+  , Show x, Show i
+  ) => MutateCell (ts:.ITbl im arr i x) im om i where
+  mutateCell bo lo mrph (ts:.ITbl tbo tlo c arr f) lu i = do
+    mutateCell bo lo mrph ts lu i
+    when (bo==tbo && lo==tlo) $ do
+      marr <- unsafeThaw arr
+      z <- (inline mrph) $ f lu i
+      writeM marr i z
+  {-# INLINE mutateCell #-}
+
+{-
+instance
+  ( MutateCell ts im om i
+  ) => MutateCell (ts:.IRec im i x) im om i where
+  mutateCell mrph (ts:.IRec (!c) _ _ f) lu i = do
+    mutateCell mrph ts lu i
+  {-# INLINE mutateCell #-}
+-}
+
+-- ** individual instances for filling a complete table and extracting the
+-- bounds
+
+instance
+  ( Monad om
+  , MutateCell (ts:.ITbl im arr i x) im om i
+  , PrimArrayOps arr i x
+  , Show i
+  , IndexStream i
+  , TableOrder (ts:.ITbl im arr i x)
+  ) => MutateTables (ts:.ITbl im arr i x) im om where
+  mutateTables mrph tt@(_:.ITbl _ _ _ arr _) = do
+    let (from,to) = bounds arr
+    -- TODO (1) find the set of orders for the synvars
+    let !tbos = VU.fromList . nub . sort $ tableBigOrder tt
+    let !tlos = VU.fromList . nub . sort $ tableLittleOrder tt
+    VU.forM_ tbos $ \bo ->
+      flip SM.mapM_ (streamUp from to) $ \k ->
+        VU.forM_ tlos $ \lo ->
+          mutateCell bo lo (inline mrph) tt to k
+    return tt
+  {-# INLINE mutateTables #-}
+
+{-
+instance
+  ( Monad om
+  , MutateCell (ts:.IRec im i x) im om i
+  , IndexStream i
+  ) => MutateTables (ts:.IRec im i x) im om where
+  mutateTables mrph tt@(_:.IRec _ from to _) = do
+    -- SM.mapM_ (mutateCell (inline mrph) tt to) $ PA.rangeStream from to
+    SM.mapM_ (mutateCell (inline mrph) tt to) $ PA.streamUp from to
+    return tt
+  {-# INLINE mutateTables #-}
+-}
+
+instance
+  ( Monad om
+  ) => MutateCell Z im om i where
+  mutateCell _ _ _ Z _ _ = return ()
+  {-# INLINE mutateCell #-}
+
+-- | Default table filling, assuming that the forward monad is just @IO@.
+--
+-- TODO generalize to @MonadIO@ or @MonadPrim@.
+
+mutateTablesDefault :: MutateTables t Id IO => t -> t
+mutateTablesDefault t = unsafePerformIO $ mutateTables (return . unId) t
+{-# INLINE mutateTablesDefault #-}
+
diff --git a/ADP/Fusion/SynVar/Indices.hs b/ADP/Fusion/SynVar/Indices.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Indices.hs
@@ -0,0 +1,109 @@
+
+-- | 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 where
+
+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:.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/Recursive.hs b/ADP/Fusion/SynVar/Recursive.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Recursive.hs
@@ -0,0 +1,74 @@
+
+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/Point.hs b/ADP/Fusion/SynVar/Recursive/Point.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Recursive/Point.hs
@@ -0,0 +1,3 @@
+
+module ADP.Fusion.SynVar.Recursive.Point where
+
diff --git a/ADP/Fusion/SynVar/Recursive/Subword.hs b/ADP/Fusion/SynVar/Recursive/Subword.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Recursive/Subword.hs
@@ -0,0 +1,13 @@
+
+module ADP.Fusion.SynVar.Recursive.Subword where
+
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Monadic
+import Data.Vector.Fusion.Stream.Size
+import Data.Vector.Fusion.Util (delay_inline)
+import Debug.Trace
+import Prelude hiding (map)
+
+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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/SynVar/Recursive/Type.hs
@@ -0,0 +1,80 @@
+
+module ADP.Fusion.SynVar.Recursive.Type where
+
+import Data.Strict.Tuple ((:!:)(..))
+import Data.Vector.Fusion.Stream.Monadic (Stream,head)
+import Prelude hiding (head)
+
+import Data.PrimitiveArray hiding (map)
+
+import ADP.Fusion.Base
+import ADP.Fusion.SynVar.Backtrack
+import ADP.Fusion.SynVar.Axiom
+
+
+
+data IRec m i x where
+  IRec :: { iRecConstraint  :: !(TblConstraint i)
+          , iRecFrom        :: !i
+          , iRecTo          :: !i
+          , iRecFun         :: !(i -> i -> m x)
+          } -> IRec m i x
+
+
+
+instance Build (IRec m i x)
+
+instance GenBacktrackTable (IRec mF i x) mF mB r where
+  data Backtrack (IRec mF i x) mF mB r = BtIRec !(TblConstraint i) !i !i (i -> i -> mB x) (i -> i -> mB [r]) -- (Stream mB r))
+  type BacktrackIndex (IRec mF i x)         = i
+  toBacktrack (IRec c iF iT f) mrph bt = BtIRec c iF iT (\lu i -> mrph $ f lu i) bt
+  {-# INLINE toBacktrack #-}
+
+
+
+instance
+  ( Monad m
+  , IndexStream i
+  ) => Axiom (IRec m i x) where
+  type AxiomStream (IRec m i x) = m x
+  axiom (IRec c l h fun) = do
+    k <- (head . uncurry streamDown) (l,h)
+    fun h k
+  {-# Inline axiom #-}
+
+instance
+  ( Monad mB
+  , IndexStream i
+  ) => Axiom (Backtrack (IRec mF i x) mF mB r) where
+  type AxiomStream (Backtrack (IRec mF i x) mF mB r) = mB [r] -- (Stream mB r)
+  axiom (BtIRec c l h fun btfun) = do
+    k <- (head . uncurry streamDown) (l,h)
+    btfun h k
+  {-# Inline axiom #-}
+
+
+
+instance Element ls i => Element (ls :!: IRec m i x) i where
+  data Elm (ls :!: IRec m i x) i = ElmIRec !x !i !i !(Elm ls i)
+  type Arg (ls :!: IRec m i x)   = Arg ls :. x
+  getArg (ElmIRec x _ _ ls) = getArg ls :. x
+  getIdx (ElmIRec _ i _ _ ) = i
+  getOmx (ElmIRec _ _ o _ ) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+instance Element ls i => Element (ls :!: (Backtrack (IRec mF i x) mF mB r)) i where
+  data Elm (ls :!: (Backtrack (IRec mF i x) mF mB r)) i = ElmBtIRec !x !(mB (Stream mB r)) !i !i !(Elm ls i)
+  type Arg (ls :!: (Backtrack (IRec mF i x) mF mB r))   = Arg ls :. (x, mB (Stream mB r))
+  getArg (ElmBtIRec x s _ _ ls) = getArg ls :. (x,s)
+  getIdx (ElmBtIRec _ _ i _ _ ) = i
+  getOmx (ElmBtIRec _ _ _ o _ ) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+
+
+-- TODO write multi-tape instances
+
diff --git a/ADP/Fusion/TH.hs b/ADP/Fusion/TH.hs
--- a/ADP/Fusion/TH.hs
+++ b/ADP/Fusion/TH.hs
@@ -1,46 +1,76 @@
-{-# LANGUAGE TemplateHaskell #-}
 
-module ADP.Fusion.TH where
+-- | 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@
 
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax
-import Data.List
+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 = makeBacktrackingProductInstance
+
+{-
 -- | 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.
 
-makeAlgebraProduct :: Name -> Q [Dec]
-makeAlgebraProduct nm = do
+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
-        -- find the objective function type (we crash if the user has more than
-        -- one)
-        let [oF] = filter (isObjectiveF . sel3) fs
-        error $ unlines $ intersperse "\n" $ map show fs
+      [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"
 
-sel3 (a,b,c) = c
+-- | Creates a class for each type of product and instances for each
+-- signature.
 
-zzz :: VarStrictType -> String
-zzz (nm,s,t) = show (nm,s,t)
+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 []
+-}
 
-isObjectiveF :: Type -> Bool
-isObjectiveF (AppT (AppT ArrowT (AppT (AppT (ConT s) _) _)) (AppT _ _)) | s == ''SM.Stream = True
-isObjectiveF _ = False
 
--- AppT (AppT ArrowT
---            (AppT (AppT (ConT Data.Vector.Fusion.Stream.Monadic.Stream)
---                        (VarT m_1627401654)
---                  )
---            (VarT x_1627401655)
---            )
---      )
---      (AppT (VarT m_1627401654) (VarT r_1627401656))
diff --git a/ADP/Fusion/TH/Backtrack.hs b/ADP/Fusion/TH/Backtrack.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/TH/Backtrack.hs
@@ -0,0 +1,262 @@
+
+-- | 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           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 qualified Data.Vector.Mutable as VM
+import qualified Data.Vector.Generic.Mutable as VGM
+import qualified Data.Vector as V
+import qualified Data.Vector.Generic as VG
+import           Control.Monad.Primitive (PrimState, PrimMonad)
+import           Data.Vector.Fusion.Stream.Monadic (Stream(..))
+import           Debug.Trace
+
+import           ADP.Fusion.TH.Common
+
+
+
+-- | The type class of algebra products. We have the forward signature
+-- @sigF@ and the backtracking signature @sigB@. Combined via @(<||)@ we
+-- have a new signature @SigR@.
+
+class BacktrackingProduct sigF sigB where
+  type SigR sigF sigB :: *
+  (<||) :: sigF -> sigB -> SigR sigF sigB
+
+makeBacktrackingProductInstance :: Name -> Q [Dec]
+makeBacktrackingProductInstance 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"
+          mR <- newName "mR"
+          xR <- newName "xR"
+          rR <- newName "rR"
+          let lType    = buildLeftType  tyconName (m', x, r) (mL, xL)        args
+          let rType    = buildRightType tyconName (m', x, r) (mR, xR, rR)    args
+          let sigRType = buildSigRType  tyconName (m', x, r) xL (mR, xR, rR) args
+          let (fs,hs) = partition ((`notElem` [h]) . sel1) funs
+          Clause ps (NormalB b) ds <- genClauseBacktrack dataconName funs fs hs
+          i <- [d| instance (Monad $(varT mL), Monad $(varT mR), Eq $(varT xL), $(varT mL) ~ $(varT mR)) => BacktrackingProduct $(return lType) $(return rType) where
+                     type SigR $(return lType) $(return rType) = $(return sigRType)
+                     (<||) = $(return $ LamE ps $ LetE ds b)
+                     {-# Inline (<||) #-}
+               |]
+          return i
+
+-- | 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
+
+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 (KindedTV 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 s              = error $ "buildLeftType: " ++ show s
+
+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 (KindedTV z _)
+          | z == m    = mR
+          | z == x    = xR
+          | z == r    = rR
+          | otherwise = z
+
+buildSigRType :: Name -> (Name, Name, Name) -> (Name) -> (Name, Name, Name) -> [TyVarBndr] -> Type
+buildSigRType tycon (m, x, r) (xL) (mR, xR, rR) = foldl AppT (ConT tycon) . map go
+  where go (KindedTV z _)
+          | z == m    = VarT mR
+          | z == x    = (AppT (AppT (TupleT 2) (VarT xL)) (AppT ListT (VarT xR)))
+          | z == r    = VarT rR
+          | otherwise = VarT z
+
+-- |
+
+genClauseBacktrack
+  :: Name
+  -> [VarStrictType]
+  -> [VarStrictType]
+  -> [VarStrictType]
+  -> Q Clause
+genClauseBacktrack 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
+  -- TODO automate discovery of choice functions?
+  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) (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
+
+-- |
+
+genChoiceFunction
+  :: Name
+  -> Name
+  -> VarStrictType
+  -> Q (Name,Exp)
+genChoiceFunction hL hR (name,_,t) = do
+  exp <- buildBacktrackingChoice hL hR
+  return (name,exp)
+
+
+-- |
+--
+-- 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 t) -- @init@ since we don't want the result as a parameter
+  let exp = LamE lamPat $ TupE [funL,funR]
+  return (name,exp)
+
+-- |
+
+recBuildLamPat :: [Name] -> Name -> Name -> [Name] -> 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]
+  let buildLfun f (TupP [VarP v,_]) = appE f (varE v)
+      buildLfun f (VarP v         ) = appE f (varE v)
+  lfun <- foldl buildLfun (varE fL') ps
+  rfun <- buildRns (VarE fR') ps
+  return (ps, lfun, rfun)
+
+
+-- |
+--
+-- NOTE
+--
+-- @
+-- [ f x | x <- xs ]
+-- CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
+-- @
+
+buildRns
+  :: Exp
+--  -> [Name]
+  -> [Pat]
+  -> ExpQ
+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)
+
+-- | 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 :: Name -> Name -> Q Exp
+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
+  |]
+
+-- | Transform a monadic stream monadically into a vector.
+
+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.
+
+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 :: Type -> [Name]
+getRuleSynVarNames t' = go t' where
+  go t
+    | VarT x <- t = [x]
+    | AppT (AppT ArrowT (VarT x  )) y <- t = x : go y   -- this is a syntactic variable, return the name that the incoming data is bound to
+    | 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'
+
diff --git a/ADP/Fusion/TH/Common.hs b/ADP/Fusion/TH/Common.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/TH/Common.hs
@@ -0,0 +1,19 @@
+
+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/Table.hs b/ADP/Fusion/Table.hs
deleted file mode 100644
--- a/ADP/Fusion/Table.hs
+++ /dev/null
@@ -1,563 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-module ADP.Fusion.Table where
-
-import Control.Monad.Primitive
-import Data.Array.Repa.Index
-import Data.Array.Repa.Shape
-import Data.Strict.Tuple
-import Data.Vector.Fusion.Stream.Size
-import qualified Data.Vector.Fusion.Stream.Monadic as S
-import qualified Data.Vector.Unboxed as VU
-import Data.Strict.Maybe
-import Prelude hiding (Maybe(..))
-
-import Data.Array.Repa.Index.Subword
-import Data.Array.Repa.Index.Points
-import Data.Array.Repa.ExtShape
-import qualified Data.PrimitiveArray as PA
-import qualified Data.PrimitiveArray.Zero as PA
-
-import ADP.Fusion.Classes
-
-import Debug.Trace
-
-
-
--- * Mutable table with adaptive storage.
-
-data MTbl i xs = MTbl !(ENZ i) !xs -- (PA.MutArr m (arr i x))
-
-mTblSw :: ENE -> PA.MutArr m (arr (Z:.Subword) x) -> MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))
-mTblSw = MTbl
-{-# INLINE mTblSw #-}
-
-mTbl :: ENZ i -> PA.MutArr m (arr i x) -> MTbl i (PA.MutArr m (arr i x))
-mTbl = MTbl
-{-# INLINE mTbl #-}
-
--- | Generate the list of indices for use in table lookup.
---
--- Don't touch stuff in greek! ζ is the interior stack of arguments, α the
--- stack of saved indices
-
-class TableIndices i where
-  tableIndices :: Monad m => InOut i -> ENZ i -> i -> S.Stream m (ζ:!:α:!:i) -> S.Stream m (ζ:!:α:!:i)
-
-
-
--- * Instances
-
-instance TableIndices Z where
-  tableIndices Z Z Z = id
-  {-# INLINE tableIndices #-}
-
-instance TableIndices Subword where
-  -- | These actually don't make sense in 1-dim settings, we keep the code as a
-  -- reminder how things should look like: @tableIndices Outer ZeroT
-  -- (Subword(i:.j)) = S.map (:!:subword j j)@
-  tableIndices _ ZeroT _ = error "TableIndices Subword/ZeroT does not make sense"
-  tableIndices Outer _ (Subword(i:.j)) = S.map (\(ζ:!:α:!:Subword(k:.l)) -> (ζ:!:α:!:subword l j))
-  tableIndices (Inner _ szd) ene (Subword(i:.j)) = S.flatten mk step Unknown where
-    mk (ζ:!:α:!:kl@(Subword(k:.l))) =
-      let le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1 }
-          l' = case szd of { Nothing -> le ; Just z -> max le (j-z) }
-      in  return (ζ:!:α:!:l:!:l')
-    step (ζ:!:α:!:k:!:l)
-      | i>j = return S.Done
-      | otherwise = return $ S.Yield (ζ:!:α:!:subword k l) (ζ:!:α:!:k:!:l+1)
-  {-# INLINE tableIndices #-}
-
-instance TableIndices is => TableIndices (is:.Subword) where
-  tableIndices (os:.Outer) (es:._) (is:.Subword(i:.j))
-    = S.map (\(ζ:!:(α:!:Subword(_:.l)):!:is) -> (ζ:!:α:!:(is:.subword l j))) -- extend index to the end
-    . tableIndices os es is -- extend the @is@ part
-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is)) -- move topmost index to α for safekeeping
-  -- tables annotated with zero-width have zero width @l--l@
-  -- This also reduces the number of "running indices"
-  --
-  -- TODO consider returning "def"ault elements here, instead of data from
-  -- zero-length subword? Or does 'ZeroT' actually mean to extract (a/the)
-  -- zero-length subword?
-  --
-  tableIndices (os:.Inner _ szd) (es:.ZeroT) (is:.Subword(i:.j))
-    = S.map (\(ζ:!:(α:.Subword(k:.l)):!:is) -> (ζ:!:α:!:(is:.subword l l)))
-    . tableIndices os es is
-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
-  -- the default case, where we need to create indices
-  tableIndices (os:.Inner _ szd) (es:.e) (is:.Subword(i:.j))
-    = S.flatten mk step Unknown
-    . tableIndices os es is
-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
-    where mk (ζ:!:(α:.Subword (k:.l)):!:is) =
-            let le = l + case e of { EmptyT -> 0 ; NonEmptyT -> 1 }
-                l' = case szd of { Nothing -> le ; Just z -> max le (j-z) }
-            in  return (ζ:!:α:!:is:!:l:!:l')
-          step (ζ:!:α:!:is:!:k:!:l)
-            | l > j = return $ S.Done
-            | otherwise = return $ S.Yield (ζ:!:α:!:(is:.subword k l)) (ζ:!:α:!:is:!:k:!:l+1)
-  {-#  INLINE tableIndices #-}
-
-instance TableIndices is => TableIndices (is:.PointL) where
-  tableIndices (os:.Outer) (es:._) (is:.PointL(i:.j))
-    = S.map (\(ζ:!:(α:!:PointL(_:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l j))) -- extend index to the end
-    . tableIndices os es is -- extend the @is@ part
-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:!:i):!:is)) -- move topmost index to α for safekeeping
-  tableIndices (os:.Inner _ szd) (es:.ZeroT) (is:.PointL(i:.j))
-    = S.map (\(ζ:!:(α:.PointL(k:.l)):!:is) -> (ζ:!:α:!:(is:.pointL l l)))  -- does @l==lower bound@ have to be true here?
-    . tableIndices os es is
-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
-  -- the default case, where we need to create indices
-  tableIndices (os:.Inner _ szd) (es:.e) (is:.PointL(i:.j))
-    = S.flatten mk step Unknown
-    . tableIndices os es is
-    . S.map (\(ζ:!:α:!:(is:.i)) -> (ζ:!:(α:.i):!:is))
-    where mk (ζ:!:(α:.PointL (k:.l)):!:is) =
-            let le = l + case e of { EmptyT -> 0 ; NonEmptyT -> 1 }
-                l' = case szd of { Nothing -> le ; Just z -> max le (j-z) }
-            in  return (ζ:!:α:!:is:!:l:!:l')
-          step (ζ:!:α:!:is:!:k:!:l)
-            | l > j = return $ S.Done
-            | otherwise = return $ S.Yield (ζ:!:α:!:(is:.pointL k l)) (ζ:!:α:!:is:!:k:!:l+1)
-  {-#  INLINE tableIndices #-}
-
-instance Build (MTbl i x)
-
--- ** Subword
-
-instance
-  ( ValidIndex ls Subword
-  , Monad m
-  , PA.MPrimArrayOps arr (Z:.Subword) x
-  ) => ValidIndex (ls:!:MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where
-  validIndex (_  :!: MTbl ZeroT _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"
-  validIndex (ls :!: MTbl ene tbl) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-    let (_,Z:.Subword (0:.n)) = PA.boundsM tbl
-        minsize = max b (if ene==EmptyT then 0 else 1)
-    in  i>=a && i+minsize<=j && j<=n-c && validIndex ls abc ij
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: MTbl ene _) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)
-  {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where
-  data Elm (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword = ElmMTblSw !(Elm ls Subword) !x !Subword -- ElmBtTbl !(Elm ls Subword) !x !(m (S.Stream m b)) !Subword
-  type Arg (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) = Arg ls :. x
-  getArg !(ElmMTblSw ls x _) = getArg ls :. x
-  getIdx !(ElmMTblSw _  _ i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , PrimMonad m
-  , Elms ls Subword
-  , MkStream m ls Subword
-  , PA.MPrimArrayOps arr (Z:.Subword) x
-  ) => MkStream m (ls :!: MTbl Subword (PA.MutArr m (arr (Z:.Subword) x))) Subword where
-  mkStream !(ls:!:MTbl ene tbl) Outer !ij@(Subword (i:.j))
-    = S.mapM (\s -> let (Subword (_:.l)) = getIdx s in PA.readM tbl (Z:.subword l j) >>= \z -> return $ ElmMTblSw s z (subword l j))
-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NonEmptyT -> j-1 })
-  mkStream !(ls:!:MTbl ene tbl) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
-    mk !s = let (Subword (_:.l)) = getIdx s
-                le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1}
-                l' = case szd of Nothing -> le
-                                 Just z  -> max le (j-z)
-            in return (s :!: l :!: l')
-    {-# INLINE [0] mk #-}
-    step !(s :!: k :!: l)
-      | l > j = return S.Done
-      | otherwise = PA.readM tbl (Z:.subword k l) >>= \z -> return $ S.Yield (ElmMTblSw s z (subword k l)) (s :!: k :!: l+1)
-    {-# INLINE [0] step #-}
-  {-# INLINE mkStream #-}
-
--- ** multi-dim indices
-
-instance
-  ( Elms ls (is:.i)
-  ) => Elms (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where
-  data Elm (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) = ElmMTbl !(Elm ls (is:.i)) !x !(is:.i)
-  type Arg (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) = Arg ls :. x
-  getArg !(ElmMTbl ls x _) = getArg ls :. x
-  getIdx !(ElmMTbl _ _  i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , PrimMonad m
-  , PA.MPrimArrayOps arr (is:.i) x
-  , Elms ls (is:.i)
-  , NonTermValidIndex (is:.i)
-  , TableIndices (is:.i)
-  , MkStream m ls (is:.i)
-  ) => MkStream m (ls:!:MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where
-  mkStream (ls :!: MTbl enz tbl) os is
-    = S.mapM (\(s:!:Z:!:β) -> PA.readM tbl β >>= \z -> return $ ElmMTbl s z β) -- extract data using β index
-    . tableIndices os enz is -- generate indices for multiple dimensions
-    . S.map (\s -> (s:!:Z:!:getIdx s)) -- extract the right-most current index
-    $ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz) -- TODO fix os is!
-  {-# INLINE mkStream #-}
-
-instance
-  ( ValidIndex ls (is:.i)
-  , PA.MPrimArrayOps arr (is:.i) x
-  , NonTermValidIndex (is:.i)
-  ) => ValidIndex (ls :!: MTbl (is:.i) (PA.MutArr m (arr (is:.i) x))) (is:.i) where
-  validIndex (ls :!: MTbl es tbl) abc isi =
-    let (_,rght) = PA.boundsM tbl
-    in  nonTermValidIndex es rght abc isi && validIndex ls abc isi
-  getParserRange (ls :!: MTbl es _) ix = getNonTermParserRange es ix $ getParserRange ls ix
-  {-# INLINE validIndex #-}
-  {-# INLINE getParserRange #-}
-
-class NonTermValidIndex i where
-  nonTermValidIndex :: ENZ i -> i -> ParserRange i -> i -> Bool
-  getNonTermParserRange :: ENZ i -> i -> ParserRange i -> ParserRange i
-  nonTermInnerOuter :: i -> InOut i -> InOut i
-  nonTermLeftIndex :: i -> InOut i -> ENZ i -> i
-
-instance NonTermValidIndex Z where
-  nonTermValidIndex Z Z Z Z = True
-  getNonTermParserRange Z Z Z = Z
-  nonTermInnerOuter Z Z = Z
-  nonTermLeftIndex Z Z Z = Z
-  {-# INLINE nonTermValidIndex #-}
-  {-# INLINE getNonTermParserRange #-}
-  {-# INLINE nonTermInnerOuter #-}
-  {-# INLINE nonTermLeftIndex #-}
-
-instance NonTermValidIndex is => NonTermValidIndex (is:.Subword) where
-  nonTermValidIndex (es:.e) (ns:.Subword(_:.n)) (abc:.(a:!:b:!:c)) (is:.Subword(i:.j)) =
-    let minsize = max b (if e==EmptyT then 0 else 1)
-    in  i>=a && i+minsize<=j && j<=n-c && nonTermValidIndex es ns abc is
-  getNonTermParserRange (es:.e) (is:._) (abc:.(a:!:b:!:c)) =
-    let b' = b + if e==EmptyT then 0 else 1
-    in  getNonTermParserRange es is abc :. (a:!:b':!:c)
-  nonTermInnerOuter (is:._) (os:.Outer) = nonTermInnerOuter is os :. Inner Check Nothing
-  nonTermInnerOuter (is:._) (os:.Inner _ _) = nonTermInnerOuter is os :. Inner NoCheck Nothing
-  nonTermLeftIndex (is:.Subword(i:.j)) (os:.o) (es:.e)
-    | o==Outer && e==NonEmptyT = nonTermLeftIndex is os es :. subword i (j-1)
-    | otherwise                = nonTermLeftIndex is os es :. subword i j
-  {-# INLINE nonTermValidIndex #-}
-  {-# INLINE getNonTermParserRange #-}
-  {-# INLINE nonTermInnerOuter #-}
-  {-# INLINE nonTermLeftIndex #-}
-
--- TODO autogenerated, check correctness
-
-instance NonTermValidIndex is => NonTermValidIndex (is:.PointL) where
-  nonTermValidIndex (es:.e) (ns:.PointL(_:.n)) (abc:.(a:!:b:!:c)) (is:.PointL(i:.j)) =
-    let minsize = max b (if e==EmptyT then 0 else 1)
-    in  i>=a && i+minsize<=j && j<=n-c && nonTermValidIndex es ns abc is
-  getNonTermParserRange (es:.e) (is:._) (abc:.(a:!:b:!:c)) =
-    let b' = b + if e==EmptyT then 0 else 1
-    in  getNonTermParserRange es is abc :. (a:!:b':!:c)
-  nonTermInnerOuter (is:._) (os:.Outer) = nonTermInnerOuter is os :. Inner Check Nothing
-  nonTermInnerOuter (is:._) (os:.Inner _ _) = nonTermInnerOuter is os :. Inner NoCheck Nothing
-  nonTermLeftIndex (is:.PointL(i:.j)) (os:.o) (es:.e)
-    | o==Outer && e==NonEmptyT = nonTermLeftIndex is os es :. pointL i (j-1)
-    | otherwise                = nonTermLeftIndex is os es :. pointL i j
-  {-# INLINE nonTermValidIndex #-}
-  {-# INLINE getNonTermParserRange #-}
-  {-# INLINE nonTermInnerOuter #-}
-  {-# INLINE nonTermLeftIndex #-}
-
-
-
-data BtTbl i xs f = BtTbl !(ENZ i) !xs !f -- (i -> m (S.Stream m b))
-
-btTbl :: ENZ i -> xs -> f -> BtTbl i xs f --(i -> m (S.Stream m b)) -> BtTbl m i xs b
-btTbl = BtTbl
-{-# INLINE btTbl #-}
-
-type DefBtTbl m isi x b = BtTbl isi (PA.Unboxed isi x) (isi -> m (S.Stream m b))
-type SwBtTbl m x b = BtTbl Subword (PA.Unboxed (Z:.Subword) x) (Subword -> m (S.Stream m b))
-
-instance Build (BtTbl i xs f)
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: SwBtTbl m x b) Subword where
-  data Elm (ls :!: SwBtTbl m x b) Subword = ElmSwBtTbl !(Elm ls Subword) !(x,m (S.Stream m b)) !Subword
-  type Arg (ls :!: SwBtTbl m x b) = Arg ls :. (x,m (S.Stream m b))
-  getArg !(ElmSwBtTbl ls x _) = getArg ls :. x
-  getIdx !(ElmSwBtTbl _ _  i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , Elms ls Subword
-  , VU.Unbox x
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: SwBtTbl m x b) Subword where
-  mkStream !(ls:!:BtTbl ene tbl f) Outer !ij@(Subword (i:.j))
-    = S.mapM (\s -> let (Subword (_:.l)) = getIdx s in return $ ElmSwBtTbl s (tbl PA.! (Z:.subword l j), f $ subword l j) (subword l j))
-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NonEmptyT -> j-1 })
-  mkStream !(ls:!:BtTbl ene tbl f) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
-    mk !s = let (Subword (_:.l)) = getIdx s
-                le = l + case ene of { EmptyT -> 0 ; NonEmptyT -> 1}
-                l' = case szd of Nothing -> le
-                                 Just z  -> max le (j-z)
-            in return (s :!: l :!: l')
-    step !(s :!: k :!: l)
-      | l > j = return S.Done
-      | otherwise = return $ S.Yield (ElmSwBtTbl s (tbl PA.! (Z:.subword k l), f $ subword k l) (subword k l)) (s :!: k :!: l+1)
-  {-# INLINE mkStream #-}
-
-instance
-  ( ValidIndex ls Subword
-  , VU.Unbox x
-  ) => ValidIndex (ls :!: SwBtTbl m x b) Subword where
-  validIndex (_  :!: BtTbl ZeroT _ _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"
-  validIndex (ls :!: BtTbl ene tbl _) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-    let (_,Z:.Subword (0:.n)) = PA.bounds tbl
-        minsize = max b (if ene==EmptyT then 0 else 1)
-    in  i>=a && i+minsize<=j && j<=n-c && validIndex ls abc ij
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: BtTbl ene _ f) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)
-  {-# INLINE getParserRange #-}
-
-instance
-  ( Elms ls (is:.i)
-  ) => Elms (ls :!: DefBtTbl m (is:.i) x b) (is:.i) where
-  data Elm (ls :!: DefBtTbl m (is:.i) x b) (is:.i) = ElmBtTbl !(Elm ls (is:.i)) !(x,m (S.Stream m b)) !(is:.i)
-  type Arg (ls :!: DefBtTbl m (is:.i) x b) = Arg ls :. (x,m (S.Stream m b))
-  getArg !(ElmBtTbl ls x _) = getArg ls :. x
-  getIdx !(ElmBtTbl _ _  i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , Elms ls (is:.i)
-  , ExtShape (is:.i)
-  , Shape (is:.i)
-  , VU.Unbox x
-  , NonTermValidIndex (is:.i)
-  , TableIndices (is:.i)
-  , MkStream m ls (is:.i)
-  ) => MkStream m (ls:!:DefBtTbl m (is:.i) x b) (is:.i) where
-  mkStream (ls :!: BtTbl enz tbl f) os is
-    = S.map (\(s:!:Z:!:β) -> ElmBtTbl s (tbl PA.! β,f β) β) -- extract data using β index
-    . tableIndices os enz is -- generate indices for multiple dimensions
-    . S.map (\s -> (s:!:Z:!:getIdx s)) -- extract the right-most current index
-    $ mkStream ls (nonTermInnerOuter is os) (nonTermLeftIndex is os enz) -- TODO fix os is!
-  {-# INLINE mkStream #-}
-
-instance
-  ( ValidIndex ls (is:.i)
-  , Shape (is:.i)
-  , ExtShape (is:.i)
-  , VU.Unbox x
-  , NonTermValidIndex (is:.i)
-  ) => ValidIndex (ls :!: DefBtTbl m (is:.i) x b) (is:.i) where
-  validIndex (ls :!: BtTbl es tbl f) abc isi =
-    let (_,rght) = PA.bounds tbl
-    in  nonTermValidIndex es rght abc isi && validIndex ls abc isi
-  getParserRange (ls :!: BtTbl es _ _) ix = getNonTermParserRange es ix $ getParserRange ls ix
-  {-# INLINE validIndex #-}
-  {-# INLINE getParserRange #-}
-
-
-
-class EmptyTable x where
-  toEmptyT :: x -> x
-  toNonEmptyT :: x -> x
-
-instance (EmptyENZ (ENZ i)) => EmptyTable (MTbl i xs) where
-  toEmptyT    (MTbl enz xs) = MTbl (toEmptyENZ    enz) xs
-  toNonEmptyT (MTbl enz xs) = MTbl (toNonEmptyENZ enz) xs
-  {-# INLINE toEmptyT #-}
-  {-# INLINE toNonEmptyT #-}
-
-instance (EmptyENZ (ENZ i)) => EmptyTable (BtTbl i xs f) where
-  toEmptyT    (BtTbl enz xs f) = BtTbl (toEmptyENZ    enz) xs f
-  toNonEmptyT (BtTbl enz xs f) = BtTbl (toNonEmptyENZ enz) xs f
-  {-# INLINE toEmptyT #-}
-  {-# INLINE toNonEmptyT #-}
-
-
-
-
-{-
-
--- * Backtracking tables.
-
-data BtTbl m x b = BtTbl ENE !(PA.Unboxed (Z:.Subword) x) !(Subword -> m (S.Stream m b))
-
-instance Build (BtTbl m x b)
-
-instance
-  ( Monad m
-  , Elms ls Subword
-  ) => Elms (ls :!: BtTbl m x b) Subword where
-  data Elm (ls :!: BtTbl m x b) Subword = ElmBtTbl !(Elm ls Subword) !x !(m (S.Stream m b)) !Subword
-  type Arg (ls :!: BtTbl m x b) = Arg ls :. (x,m (S.Stream m b))
-  getArg !(ElmBtTbl ls x b _) = getArg ls :. (x,b)
-  getIdx !(ElmBtTbl _  _ _ i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , VU.Unbox x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls :!: BtTbl m x b) Subword where
-  mkStream !(ls:!:BtTbl ene xs f) Outer !ij@(Subword (i:.j))
-    = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmBtTbl s (xs PA.! (Z:.subword l j)) (f $ subword l j) (subword l j))
-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NoEmptyT -> j-1 })
-  mkStream !(ls:!:BtTbl ene xs f) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
-    mk !s = let (Subword (k:.l)) = getIdx s
-                le = l + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}
-                l' = case szd of Nothing -> le
-                                 Just z  -> max le (j-z)
-            in  return (s:!:l:!: l')
-    step !(s:!:k:!:l)
-      | l > j     = return $ S.Done
-      | otherwise = return $ S.Yield (ElmBtTbl s (xs PA.! (Z:.subword k l)) (f $ subword k l) (subword k l)) (s:!:k:!:l+1)
-  {-# INLINE mkStream #-}
-
-
-
--- * Unboxed mutable table for the forward phase in one dimension.
-
-data MTbl xs = MTbl !ENE !xs
-
-instance
-  ( ValidIndex ls Subword
-  , Monad m
-  , PA.MPrimArrayOps arr (Z:.Subword) x
-  ) => ValidIndex (ls:!:MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword where
-  validIndex (_  :!: MTbl ZeroT _) _ _ = error "table with ZeroT found, there is no reason (actually: no implementation) for 1-dim ZeroT tables"
-  validIndex (ls :!: MTbl ene tbl) abc@(a:!:b:!:c) ij@(Subword (i:.j)) =
-    let (_,Z:.Subword (0:.n)) = PA.boundsM tbl
-        minsize = max b (if ene==EmptyT then 0 else 1)
-    in  i>=a && i+minsize<=j && j<=n-c && validIndex ls abc ij
-  {-# INLINE validIndex #-}
-  getParserRange (ls :!: MTbl ene _) ix = let (a:!:b:!:c) = getParserRange ls ix in if ene==EmptyT then (a:!:b:!:c) else (a:!:b+1:!:c)
-  {-# INLINE getParserRange #-}
-
-instance Build (MTbl xs)
-
-instance
-  ( Monad m
-  , Elms ls Subword
-  ) => Elms (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword where
-  data Elm (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword = ElmMTbl !(Elm ls Subword) !x !Subword
-  type Arg (ls :!: MTbl (PA.MutArr m (arr (Z:.Subword) x))) = Arg ls :. x
-  getArg !(ElmMTbl ls x _) = getArg ls :. x
-  getIdx !(ElmMTbl _ _ i) = i
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( PrimMonad m
-  , PA.MPrimArrayOps arr (Z:.Subword) x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls:!:MTbl (PA.MutArr m (arr (Z:.Subword) x))) Subword where
-  mkStream !(ls:!:MTbl ene tbl) Outer !ij@(Subword (i:.j))
-    = S.mapM (\s -> let (Subword (_:.l)) = getIdx s in PA.readM tbl (Z:.subword l j) >>= \z -> return $ ElmMTbl s z (subword l j))
-    $ mkStream ls (Inner Check Nothing) (subword i $ case ene of { EmptyT -> j ; NoEmptyT -> j-1 })
-  mkStream !(ls:!:MTbl ene tbl) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
-    mk !s = let (Subword (_:.l)) = getIdx s
-                le = l + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}
-                l' = case szd of Nothing -> le
-                                 Just z  -> max le (j-z)
-            in return (s :!: l :!: l')
-    step !(s :!: k :!: l)
-      | l > j = return S.Done
-      | otherwise = PA.readM tbl (Z:.subword k l) >>= \z -> return $ S.Yield (ElmMTbl s z (subword k l)) (s :!: k :!: l+1)
-  {-# INLINE mkStream #-}
-
-
-
-{-
-
--- ** multi-tape generalization: empty / nonempty
-
-instance
-  ( ValidIndex ls (is:.i)
-  , Monad m
-  , PA.MPrimArrayOps arr (is:.i) x
-  ) => ValidIndex (ls :!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where
-    validIndex (ls :!: MTbl ene tbl) (is:.i) =
-      let
-      in  undefined
-
-instance
-  ( Monad m
-  ) => Elms (ls :!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where
-
-instance
-  ( Monad m
-  ) => MkStream m (ls:!: MTbl (PA.MutArr m (arr (is:.i) x))) (is:.i) where
-  mkStream !(ls:!:MTbl ene tbl) io is
-    = undefined
-
-
-
-{-
-data GMtbl i x = forall m . GMtbl (ENEdim i) (PA.MutArr m (Storage i x))
-
--}
-
--}
-
--}
-
-
-{-
-
--- * Immutable tables.
-
-data Tbl x = Tbl !(PA.Unboxed (Z:.Subword) x)
-
-instance Build (Tbl x)
-
-instance
-  ( Elms ls Subword
-  ) => Elms (ls :!: Tbl x) Subword where
-  data Elm (ls :!: Tbl x) Subword = ElmTbl !(Elm ls Subword) !x !Subword
-  type Arg (ls :!: Tbl x) = Arg ls :. x
-  getArg !(ElmTbl ls x _) = getArg ls :. x
-  getIdx !(ElmTbl _ _ idx) = idx
-  {-# INLINE getArg #-}
-  {-# INLINE getIdx #-}
-
-instance
-  ( Monad m
-  , VU.Unbox x
-  , Elms ls Subword
-  , MkStream m ls Subword
-  ) => MkStream m (ls:!:Tbl x) Subword where
-  mkStream !(ls:!:Tbl xs) Outer !ij@(Subword (i:.j)) = S.map (\s -> let (Subword (k:.l)) = getIdx s in ElmTbl s (xs PA.! (Z:.subword l j)) (subword l j)) $ mkStream ls (Inner Check Nothing) ij
-  mkStream !(ls:!:Tbl xs) (Inner _ szd) !ij@(Subword (i:.j)) = S.flatten mk step Unknown $ mkStream ls (Inner NoCheck Nothing) ij where
-    mk !s = let (Subword (k:.l)) = getIdx s
-                le = l -- TODO need to add ENE here ! -- + case ene of { EmptyT -> 0 ; NoEmptyT -> 1}
-                l' = case szd of Nothing -> le
-                                 Just z  -> max le (j-z)
-            in  return (s :!: l :!: l')
-    step !(s :!: k :!: l)
-      | l > j = return S.Done
-      | otherwise = return $ S.Yield (ElmTbl s (xs PA.! (Z:.subword k l)) (subword k l)) (s :!: k :!: l+1)
-  {-# INLINE mkStream #-}
-
-
--}
-
-
diff --git a/ADP/Fusion/Term.hs b/ADP/Fusion/Term.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term.hs
@@ -0,0 +1,17 @@
+
+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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Chr.hs
@@ -0,0 +1,197 @@
+
+module ADP.Fusion.Term.Chr
+  ( module ADP.Fusion.Term.Chr.Type
+  , module ADP.Fusion.Term.Chr.Point
+  , module ADP.Fusion.Term.Chr.Subword
+  ) where
+
+import ADP.Fusion.Term.Chr.Point
+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<u) $
+      let !z = f xs j
+      in  S.map (ElmChr z (O . pointL j $ j+1))
+          $ mkStream ls Static lu (O . pointL i $ j+1)
+--  mkStream _ _ _ _ = error "mkStream / Chr / Outside PointL not implemented"
+  {-# INLINE mkStream #-}
+-}
+
+
+-- ** @Subword@ single-dim instances
+
+{-
+instance
+  ( Monad m
+  , Element ls Subword
+  , MkStream m ls Subword
+  ) => 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<u) $
+      let !z = f xs j
+      in S.map (ElmChr z (O $ subword j (j+1)))
+         $ mkStream ls Static lu (O $ subword i $ j+1)
+  -- In the variable case, (i) we set @i@ to @i-1@ going further down. (ii) On
+  -- going back up, we extract the rightmost index of the left symbol @l@ --
+  -- which could be @i-1@ but need not be.
+  mkStream (ls :!: Chr f xs) v lu ij@(O (Subword (i:.j)))
+    = S.map (\s -> 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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Chr/Point.hs
@@ -0,0 +1,91 @@
+
+module ADP.Fusion.Term.Chr.Point where
+
+import           Data.Strict.Tuple
+import           Debug.Trace
+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.Chr.Type
+
+
+instance
+  ( Monad m
+  , Element ls PointL
+  , MkStream m ls PointL
+  ) => MkStream m (ls :!: Chr r x) PointL where
+  mkStream (ls :!: Chr f xs) (IStatic d) (PointL u) (PointL i)
+    = staticCheck (i>0 && i<=u && i<= VG.length xs)
+    $ S.map (ElmChr (f xs $ i-1) (PointL $ i) (PointL 0))
+    $ mkStream ls (IStatic d) (PointL u) (PointL $ i-1)
+  mkStream _ _ _ _ = error "mkStream / Chr / PointL can only be implemented for IStatic"
+  {-# 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) (OStatic d) (O (PointL u)) (O (PointL i))
+    = S.map (\z -> let (O (PointL k)) = getOmx z in ElmChr (f xs $ k-d-1) (O . PointL $ k-d) (getOmx z) z)
+    $ mkStream ls (OStatic $ d+1) (O $ PointL u) (O $ PointL i)
+  mkStream _ _ _ _ = error "Chr.Point / mkStream / Chr / Outside.PointL can only be implemented for OStatic"
+  {-# Inline mkStream #-}
+
+-- TODO @Inline [0]@ ???
+
+instance TermStaticVar (Chr r x) PointL where
+  termStaticVar   _ sv _                = sv
+  termStreamIndex _ _  (PointL j) = PointL $ j-1
+  {-# Inline termStaticVar #-}
+  {-# Inline termStreamIndex #-}
+
+instance TermStaticVar (Chr r x) (Outside PointL) where
+  termStaticVar   _ (OStatic d) _ = OStatic (d+1) 
+  termStreamIndex _ _           j = j
+  {-# Inline termStaticVar #-}
+  {-# Inline termStreamIndex #-}
+
+instance
+  ( Monad m
+  , TerminalStream m a is
+  ) => TerminalStream m (TermSymbol a (Chr r x)) (is:.PointL) where
+  terminalStream (a:|Chr f (!v)) (sv:.IStatic _) (is:.i@(PointL j))
+    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.f v (j-1)))
+    . iPackTerminalStream a sv (is:.i)
+    {-
+    . terminalStream a sv is
+    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
+    -}
+  terminalStream (a:|Chr f (!v)) (sv:._) (is:.i@(PointL _))
+    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1)))
+    . iPackTerminalStream a sv (is:.i)
+    {-
+    . terminalStream a sv is
+    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
+    -}
+  {-# INLINE terminalStream #-}
+
+instance
+  ( Monad m
+  , TerminalStream m a (Outside is)
+  , Context (Outside (is:.PointL)) ~ (Context (Outside is) :. OutsideContext Int)
+  ) => TerminalStream m (TermSymbol a (Chr r x)) (Outside (is:.PointL)) where
+  terminalStream (a:|Chr f (!v)) (sv:.OStatic d) (O (is:.i))
+    = S.map (\(S6 s (zi:._) (zo:.(PointL k)) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.f v (k-d-1)))
+    . oPackTerminalStream a sv (O (is:.i))
+    {-
+    . terminalStream a sv (O is)
+    . S.map (\(S5 s zi zo (O (is:.i)) (O (os:.o))) -> S5 s (zi:.i) (zo:.o) (O is) (O os))
+    -}
+  {-
+  terminalStream (a:|Chr f (!v)) (sv:._) (is:.PointL i)
+    = S.map (\(S6 s (zi:.PointL k) (zo:.PointL l) is os e) -> S6 s zi zo (is:.PointL (k+1)) (os:.PointL 0) (e:.f v (l-1)))
+    . terminalStream a sv is
+    . S.map (\(S5 s zi zo (is:.i) (os:.o)) -> S5 s (zi:.i) (zo:.o) is os)
+  -}
+  {-# INLINE terminalStream #-}
+
diff --git a/ADP/Fusion/Term/Chr/Subword.hs b/ADP/Fusion/Term/Chr/Subword.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Chr/Subword.hs
@@ -0,0 +1,61 @@
+
+module ADP.Fusion.Term.Chr.Subword where
+
+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
+  ( Monad m
+  , Element ls Subword
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: Chr r x) Subword where
+  mkStream (ls :!: Chr f xs) (IStatic ()) hh (Subword (i:.j))
+    = staticCheck (i>=0 && i<j && j<= VG.length xs)
+    $ map (ElmChr (f xs $ j-1) (subword (j-1) j) (subword 0 0))
+    $ mkStream ls (IStatic ()) hh (delay_inline Subword (i:.j-1))
+  mkStream (ls :!: Chr f xs) (IVariable ()) hh (Subword (i:.j))
+    = map (\s -> let Subword (_:.l) = getIdx s
+                 in  ElmChr (f xs l) (subword l (l+1)) (subword 0 0) s)
+    $ mkStream ls (IVariable ()) hh (delay_inline Subword (i:.j-1))
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( Monad m
+  , Element ls (Outside Subword)
+  , MkStream m ls (Outside Subword)
+  ) => MkStream m (ls :!: Chr r x) (Outside Subword) where
+  mkStream (ls :!: Chr f xs) (OStatic (di:.dj)) u ij@(O (Subword (i:.j)))
+    = id -- staticCheck ( j < h ) -- TODO any check possible?
+    $ map (\s -> let (O (Subword (_:.k'))) = getIdx s
+                     k = k'-dj-1
+                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)
+    $ mkStream ls (OStatic (di:.dj+1)) u ij
+  mkStream (ls :!: Chr f xs) (ORightOf (di:.dj)) u ij
+    = map (\s -> let (O (Subword (_:.k'))) = getIdx s
+                     k = k'-dj-1
+                 in  ElmChr (f xs k) (O $ subword (k'-1) k') (getOmx s) s)
+    $ mkStream ls (ORightOf (di:.dj+1)) u ij
+  mkStream (ls :!: Chr f xs) (OFirstLeft (di:.dj)) u ij
+    = id
+    $ map (\s -> let (O (Subword (_:.k))) = getIdx s
+                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)
+    $ mkStream ls (OFirstLeft (di+1:.dj)) u ij
+  mkStream (ls :!: Chr f xs) (OLeftOf (di:.dj)) u ij
+    = map (\s -> let (O (Subword (_:.k))) = getIdx s
+                 in  ElmChr (f xs k) (O $ subword k (k+1)) (getOmx s) s)
+    $ mkStream ls (OLeftOf (di+1:.dj)) u ij
+  {-# Inline mkStream #-}
+
diff --git a/ADP/Fusion/Term/Chr/Type.hs b/ADP/Fusion/Term/Chr/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Chr/Type.hs
@@ -0,0 +1,57 @@
+
+module ADP.Fusion.Term.Chr.Type where
+
+import           Data.Strict.Tuple
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Base
+
+
+-- | A generic Character parser that reads a single character but allows
+-- passing additional information.
+--
+--  'Chr' expects a function to retrieve @r@ at index position, followed by
+--  the actual generic vector with data.
+
+data Chr r x where
+  Chr :: VG.Vector v x
+      => !(v x -> Int -> r)
+      -> !(v x)
+      -> Chr r x
+
+-- | smart constructor for regular 1-character parsers
+
+--chr xs = Chr VG.unsafeIndex xs
+chr xs = Chr (VG.unsafeIndex) xs
+--chr xs = Chr (VG.!) xs
+{-# Inline chr #-}
+
+-- | Smart constructor for Maybe Peeking, followed by a character.
+
+chrLeft xs = Chr f xs where
+  f xs k = ( xs VG.!? (k-1)
+           , VG.unsafeIndex xs k
+           )
+  {-# Inline [0] f #-}
+{-# Inline chrLeft #-}
+
+instance Build (Chr r x)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Chr r x) i where
+    data Elm (ls :!: Chr r x) i = ElmChr !r !i !i !(Elm ls i)
+    type Arg (ls :!: Chr r x)   = Arg ls :. r
+    getArg (ElmChr x _ _ ls) = getArg ls :. x
+    getIdx (ElmChr _ i _ _ ) = i
+    getOmx (ElmChr _ _ o _ ) = o
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+    {-# Inline getOmx #-}
+
+deriving instance (Show i, Show r, Show (Elm ls i)) => Show (Elm (ls :!: Chr r x) i)
+
+type instance TermArg (TermSymbol a (Chr r x)) = TermArg a :. r
+
diff --git a/ADP/Fusion/Term/Deletion.hs b/ADP/Fusion/Term/Deletion.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Deletion.hs
@@ -0,0 +1,76 @@
+
+module ADP.Fusion.Term.Deletion
+  ( module ADP.Fusion.Term.Deletion.Type
+  , module ADP.Fusion.Term.Deletion.Point
+  ) where
+
+import ADP.Fusion.Term.Deletion.Point
+import ADP.Fusion.Term.Deletion.Type
+
+
+{-
+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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Deletion/Point.hs
@@ -0,0 +1,62 @@
+
+module ADP.Fusion.Term.Deletion.Point where
+
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Base
+import           ADP.Fusion.Term.Deletion.Type
+
+
+
+instance
+  ( Monad m
+  , MkStream m ls PointL
+  ) => MkStream m (ls :!: Deletion) PointL where
+  mkStream (ls :!: Deletion) (IStatic d) (PointL u) (PointL i)
+    = S.map (ElmDeletion (PointL i) (PointL 0))
+    $ mkStream ls (IStatic d) (PointL u) (PointL i)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , Element ls (Outside PointL)
+  , MkStream m ls (Outside PointL)
+  ) => MkStream m (ls :!: Deletion) (Outside PointL) where
+  mkStream (ls :!: Deletion) (OStatic d) (O (PointL u)) (O (PointL i))
+    = S.map (\z -> ElmDeletion (O $ PointL i) (getOmx z) z)
+    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)
+  {-# Inline mkStream #-}
+
+instance TermStaticVar Deletion PointL where
+  termStaticVar _ sv _ = sv
+  termStreamIndex _ _ (PointL j) = PointL j
+  {-# Inline termStaticVar #-}
+  {-# Inline termStreamIndex #-}
+
+instance TermStaticVar Deletion (Outside PointL) where
+  termStaticVar   _ (OStatic d) _ = OStatic d
+  termStreamIndex _ _           j = j
+  {-# Inline termStaticVar #-}
+  {-# Inline termStreamIndex #-}
+
+instance
+  ( Monad m
+  , TerminalStream m a is
+  ) => TerminalStream m (TermSymbol a Deletion) (is:.PointL) where
+  terminalStream (a:|Deletion) (sv:.IStatic _) (is:.i@(PointL j))
+    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))
+    . iPackTerminalStream a sv (is:.i)
+  {-# Inline terminalStream #-}
+
+instance
+  ( Monad m
+  , TerminalStream m a (Outside is)
+  ) => TerminalStream m (TermSymbol a Deletion) (Outside (is:.PointL)) where
+  terminalStream (a:|Deletion) (sv:.OStatic d) (O (is:.i))
+    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))
+    . oPackTerminalStream a sv (O (is:.i))
+  {-# Inline terminalStream #-}
+
diff --git a/ADP/Fusion/Term/Deletion/Type.hs b/ADP/Fusion/Term/Deletion/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Deletion/Type.hs
@@ -0,0 +1,27 @@
+
+module ADP.Fusion.Term.Deletion.Type where
+
+import Data.Strict.Tuple
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Base
+
+
+
+data Deletion = Deletion
+
+instance Build Deletion
+
+instance (Element ls i) => Element (ls :!: Deletion) i where
+  data Elm (ls :!: Deletion) i = ElmDeletion !i !i !(Elm ls i)
+  type Arg (ls :!: Deletion)   = Arg ls :. ()
+  getArg (ElmDeletion _ _ l) = getArg l :. ()
+  getIdx (ElmDeletion i _ _) = i
+  getOmx (ElmDeletion _ o _) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+type instance TermArg (TermSymbol a Deletion) = TermArg a :. ()
+
diff --git a/ADP/Fusion/Term/Edge.hs b/ADP/Fusion/Term/Edge.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Edge.hs
@@ -0,0 +1,64 @@
+
+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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Edge/Set.hs
@@ -0,0 +1,73 @@
+
+module ADP.Fusion.Term.Edge.Set where
+
+import Data.Bits
+import Data.Strict.Tuple
+import Data.Vector.Fusion.Stream.Monadic
+import Data.Vector.Fusion.Stream.Size
+import 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 (BS2I First Last)
+  , MkStream m ls (BS2I First Last)
+  ) => MkStream m (ls :!: Edge e) (BS2I First Last) where
+  mkStream (ls :!: Edge f) (IStatic rp) u sij@(s:>i:>j)
+    = flatten mk step Unknown $ mkStream ls (IStatic rpn) u tik
+    where rpn | j >= 0    = rp
+              | otherwise = rp+1
+          tik | j >= 0    = s `clearBit` (getIter j) :> i :> undefi
+              | otherwise = sij
+          mk z
+            | j >= 0 && popCount s >= 2 = return $ This z
+            | j <  0 && popCount s >= 2 = return $ That (z,bits,maybeLsb bits)
+            | popCount s <= max 1 rp    = return $ Naught
+            | otherwise                 = error $ show ("Edge",s,i,j)
+            where (zs:>_:>zk) = getIdx z
+                  bits        = s `xor` zs
+          step Naught   = return Done
+          step (This z)
+            | popCount zs == 0 = return $ Done
+            | otherwise = return $ Yield (ElmEdge (f (getIter zk) (getIter j)) sij undefbs2i z) Naught
+            where (zs:>_:>zk) = getIdx z
+          step (That (z,bits,Nothing)) = return $ Done
+          step (That (z,bits,Just j')) = let (zs:>_:>Iter zk) = getIdx z
+                                             tij'            = (zs .|. bit j') :> Iter zk :> Iter j'
+                                         in  return $ Yield (ElmEdge (f zk j') tij' undefbs2i z) (That (z,bits,maybeNextActive j' bits))
+          {-# Inline [0] mk   #-}
+          {-# Inline [0] step #-}
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( Monad m
+  , Element ls    (Outside (BS2I First Last))
+  , MkStream m ls (Outside (BS2I First Last))
+  ) => MkStream m (ls :!: Edge f) (Outside (BS2I First Last)) where
+  mkStream (ls :!: Edge f) (OStatic ()) u sij
+    = map undefined
+    $ mkStream ls (undefined) u sij
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( Monad m
+  , Element ls    (Complement (BS2I First Last))
+  , MkStream m ls (Complement (BS2I First Last))
+  ) => MkStream m (ls :!: Edge f) (Complement (BS2I First Last)) where
+  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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Edge/Type.hs
@@ -0,0 +1,32 @@
+
+module ADP.Fusion.Term.Edge.Type where
+
+import Data.Strict.Tuple
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Base
+
+
+
+data Edge e where
+  Edge :: (Int -> Int -> e) -> Edge e
+
+instance Build (Edge e)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Edge e) i where
+    data Elm (ls :!: Edge e) i = ElmEdge !e !i !i (Elm ls i)
+    type Arg (ls :!: Edge e)   = Arg ls :. e
+    getArg (ElmEdge e _ _ ls) = getArg ls :. e
+    getIdx (ElmEdge _ i _ _ ) = i
+    getOmx (ElmEdge _ _ o _ ) = o
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+    {-# Inline getOmx #-}
+
+deriving instance (Show i, Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i)
+
+type instance TermArg (TermSymbol a (Edge e)) = TermArg a :. e
+
diff --git a/ADP/Fusion/Term/Epsilon.hs b/ADP/Fusion/Term/Epsilon.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Epsilon.hs
@@ -0,0 +1,116 @@
+
+module ADP.Fusion.Term.Epsilon
+  ( module ADP.Fusion.Term.Epsilon.Type
+  , module ADP.Fusion.Term.Epsilon.Point
+  , module ADP.Fusion.Term.Epsilon.Subword
+  ) where
+
+import ADP.Fusion.Term.Epsilon.Point
+import ADP.Fusion.Term.Epsilon.Subword
+import ADP.Fusion.Term.Epsilon.Type
+
+{-
+
+{-# 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
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Epsilon/Point.hs
@@ -0,0 +1,62 @@
+
+module ADP.Fusion.Term.Epsilon.Point where
+
+import           Data.Strict.Tuple
+import qualified Data.Vector.Fusion.Stream.Monadic as S
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Base
+import           ADP.Fusion.Term.Epsilon.Type
+
+
+
+instance
+  ( Monad m
+  , MkStream m ls PointL
+  ) => MkStream m (ls :!: Epsilon) PointL where
+  mkStream (ls :!: Epsilon) (IStatic d) (PointL u) (PointL i)
+    = S.map (ElmEpsilon (PointL i) (PointL 0))
+    $ mkStream ls (IStatic d) (PointL u) (PointL i)
+  {-# Inline mkStream #-}
+
+instance
+  ( Monad m
+  , Element ls (Outside PointL)
+  , MkStream m ls (Outside PointL)
+  ) => MkStream m (ls :!: Epsilon) (Outside PointL) where
+  mkStream (ls :!: Epsilon) (OStatic d) (O (PointL u)) (O (PointL i))
+    = S.map (\z -> ElmEpsilon (O $ PointL i) (getOmx z) z)
+    $ mkStream ls (OStatic d) (O $ PointL u) (O $ PointL i)
+  {-# Inline mkStream #-}
+
+instance TermStaticVar Epsilon PointL where
+  termStaticVar _ sv _ = sv
+  termStreamIndex _ _ (PointL j) = PointL j
+  {-# Inline termStaticVar #-}
+  {-# Inline termStreamIndex #-}
+
+instance TermStaticVar Epsilon (Outside PointL) where
+  termStaticVar   _ (OStatic d) _ = OStatic d
+  termStreamIndex _ _           j = j
+  {-# Inline termStaticVar #-}
+  {-# Inline termStreamIndex #-}
+
+instance
+  ( Monad m
+  , TerminalStream m a is
+  ) => TerminalStream m (TermSymbol a Epsilon) (is:.PointL) where
+  terminalStream (a:|Epsilon) (sv:.IStatic _) (is:.i@(PointL j))
+    = S.map (\(S6 s (zi:._) (zo:._) is os e) -> S6 s zi zo (is:.PointL j) (os:.PointL 0) (e:.()))
+    . iPackTerminalStream a sv (is:.i)
+  {-# Inline terminalStream #-}
+
+instance
+  ( Monad m
+  , TerminalStream m a (Outside is)
+  ) => TerminalStream m (TermSymbol a Epsilon) (Outside (is:.PointL)) where
+  terminalStream (a:|Epsilon) (sv:.OStatic d) (O (is:.i))
+    = S.map (\(S6 s (zi:._) (zo:.PointL k) (O is) (O os) e) -> S6 s zi zo (O (is:.(PointL $ k-d))) (O (os:.PointL k)) (e:.()))
+    . oPackTerminalStream a sv (O (is:.i))
+  {-# Inline terminalStream #-}
+
diff --git a/ADP/Fusion/Term/Epsilon/Subword.hs b/ADP/Fusion/Term/Epsilon/Subword.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Epsilon/Subword.hs
@@ -0,0 +1,37 @@
+
+module ADP.Fusion.Term.Epsilon.Subword where
+
+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
+
+--import Data.Vector.Fusion.Util
+
+
+
+instance
+  ( Monad m
+  , MkStream m ls Subword
+  ) => MkStream m (ls :!: Epsilon) Subword where
+  mkStream (ls :!: Epsilon) (IStatic ()) hh ij@(Subword (i:.j))
+    = staticCheck (i==j)
+    $ map (ElmEpsilon (subword i j) (subword 0 0))
+    $ mkStream ls (IStatic ()) hh ij
+  {-# Inline mkStream #-}
+
+
+
+instance
+  ( Monad m
+  , MkStream m ls (Outside Subword)
+  ) => MkStream m (ls :!: Epsilon) (Outside Subword) where
+  mkStream (ls :!: Epsilon) (OStatic d) u ij@(O (Subword (i:.j)))
+    = map (ElmEpsilon (O $ subword i j) (O $ subword i j))
+    $ mkStream ls (OStatic d) u ij
+  {-# Inline mkStream #-}
+
diff --git a/ADP/Fusion/Term/Epsilon/Type.hs b/ADP/Fusion/Term/Epsilon/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Epsilon/Type.hs
@@ -0,0 +1,27 @@
+
+module ADP.Fusion.Term.Epsilon.Type where
+
+import Data.Strict.Tuple
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Base
+
+
+
+data Epsilon = Epsilon
+
+instance Build Epsilon
+
+instance (Element ls i) => Element (ls :!: Epsilon) i where
+  data Elm (ls :!: Epsilon) i = ElmEpsilon !i !i !(Elm ls i)
+  type Arg (ls :!: Epsilon)   = Arg ls :. ()
+  getArg (ElmEpsilon _ _ l) = getArg l :. ()
+  getIdx (ElmEpsilon i _ _) = i
+  getOmx (ElmEpsilon _ o _) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+type instance TermArg (TermSymbol a Epsilon) = TermArg a :. ()
+
diff --git a/ADP/Fusion/Term/PeekIndex/Subword.hs b/ADP/Fusion/Term/PeekIndex/Subword.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/PeekIndex/Subword.hs
@@ -0,0 +1,24 @@
+
+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 (Complement Subword)
+  , MkStream m ls (Complement Subword)
+  ) => MkStream m (ls :!: PeekIndex (Complement Subword)) (Complement Subword) where
+  mkStream (ls :!: PeekIndex) Complemented h ij
+    = map (\s -> ElmPeekIndex (getIdx s) (getOmx s) s)
+    $ mkStream ls Complemented h ij
+  {-# Inline mkStream #-}
+
diff --git a/ADP/Fusion/Term/PeekIndex/Type.hs b/ADP/Fusion/Term/PeekIndex/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/PeekIndex/Type.hs
@@ -0,0 +1,31 @@
+
+module ADP.Fusion.Term.PeekIndex.Type where
+
+import Data.Strict.Tuple
+
+import Data.PrimitiveArray
+
+import ADP.Fusion.Base
+
+
+
+data PeekIndex i = PeekIndex
+
+instance Build (PeekIndex i)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: PeekIndex i) i where
+    data Elm (ls :!: PeekIndex i) i = ElmPeekIndex !i !i !(Elm ls i)
+    type Arg (ls :!: PeekIndex i)   = Arg ls :. (i :. i)
+    getArg (ElmPeekIndex i o ls)    = getArg ls :. (i:.o)
+    getIdx (ElmPeekIndex i _ _ )    = i
+    getOmx (ElmPeekIndex _ o _ )    = o
+    {-# Inline getArg #-}
+    {-# Inline getIdx #-}
+    {-# Inline getOmx #-}
+
+deriving instance (Show i, Show (Elm ls i)) => Show (Elm (ls :!: PeekIndex i) i)
+
+type instance TermArg (TermSymbol a (PeekIndex i)) = TermArg a :. PeekIndex i
+
diff --git a/ADP/Fusion/Term/Strng.hs b/ADP/Fusion/Term/Strng.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Strng.hs
@@ -0,0 +1,11 @@
+
+-- | A 'Strng' matches [0..] 'Chr's.
+
+module ADP.Fusion.Term.Strng
+  ( module ADP.Fusion.Term.Strng.Type
+  , module ADP.Fusion.Term.Strng.Point
+  ) where
+
+import ADP.Fusion.Term.Strng.Point
+import ADP.Fusion.Term.Strng.Type
+
diff --git a/ADP/Fusion/Term/Strng/Point.hs b/ADP/Fusion/Term/Strng/Point.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Strng/Point.hs
@@ -0,0 +1,43 @@
+
+module ADP.Fusion.Term.Strng.Point where
+
+import           Data.Strict.Tuple
+import           Debug.Trace
+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
+  ( Monad m
+  , Element ls PointL
+  , MkStream m ls PointL
+  ) => MkStream m (ls :!: Strng v x) PointL where
+  mkStream (ls :!: Strng f minL maxL xs) (IStatic d) (PointL u) (PointL i)
+    = staticCheck (i - minL >= 0 && i <= u && minL <= maxL)
+    $ S.map (\z -> let PointL j = getIdx z in ElmStrng (f j (i-j) xs) (PointL i) (PointL 0) z)
+    $ mkStream ls (IVariable $ d + maxL - minL) (PointL u) (PointL $ i - minL)
+  mkStream _ _ _ _ = error "mkStream / Strng / PointL / IVariable"
+  {-# Inline mkStream #-}
+
+instance TermStaticVar (Strng v x) PointL where
+  termStaticVar _ (IStatic   d) _ = IVariable d
+  termStaticVar _ (IVariable d) _ = IVariable d
+  termStreamIndex (Strng _ minL _ _) (IStatic d) (PointL j) = PointL $ j - minL
+  {-# Inline [0] termStaticVar   #-}
+  {-# Inline [0] termStreamIndex #-}
+
+instance
+  ( Monad m
+  , TerminalStream m a is
+  ) => TerminalStream m (TermSymbol a (Strng v x)) (is:.PointL) where
+  terminalStream (a:|Strng f minL maxL xs) (sv:.IStatic d) (is:.i@(PointL j))
+    = S.map (\(S6 s (zi:.PointL pi) (zo:._) is os e) -> S6 s zi zo (is:.i) (os:.PointL 0) (e:.f pi (j-pi) xs))
+    . iPackTerminalStream a sv (is:.i)
+  {-# Inline terminalStream #-}
+
diff --git a/ADP/Fusion/Term/Strng/Type.hs b/ADP/Fusion/Term/Strng/Type.hs
new file mode 100644
--- /dev/null
+++ b/ADP/Fusion/Term/Strng/Type.hs
@@ -0,0 +1,56 @@
+
+module ADP.Fusion.Term.Strng.Type where
+
+import           Data.Strict.Tuple
+import qualified Data.Vector.Generic as VG
+
+import           Data.PrimitiveArray
+
+import           ADP.Fusion.Base
+
+
+
+-- | 'Strng' terminals return "strings", i.e. vectors of @Chr@s. They allow
+-- the user to specify @[ 0 .. ]@ atoms to be parsed at once. It is
+-- possible to both, limit the minimal and maximal number.
+--
+-- NOTE gadt comments are not parsed by haddock?
+
+data Strng v x where
+  Strng :: VG.Vector v x
+        => !(Int -> Int -> v x -> v x)  -- @slice@ function
+        -> !Int                         -- minimal size
+        -> !Int                         -- maximal size (just use s.th. big if you don't want a limit)
+        -> !(v x)                       -- the actual vector
+        -> Strng v x
+
+manyS :: VG.Vector v x => v x -> Strng v x
+manyS = \xs -> Strng VG.unsafeSlice 0 (VG.length xs) xs
+{-# Inline manyS #-}
+
+someS :: VG.Vector v x => v x -> Strng v x
+someS = \xs -> Strng VG.unsafeSlice 1 (VG.length xs) xs
+{-# Inline someS #-}
+
+strng :: VG.Vector v x => Int -> Int -> v x -> Strng v x
+strng = \minL maxL xs -> Strng VG.unsafeSlice minL maxL xs
+{-# Inline strng #-}
+
+instance Build (Strng v x)
+
+instance
+  ( Element ls i
+  ) => Element (ls :!: Strng v x) i where
+  data Elm (ls :!: Strng v x) i = ElmStrng !(v x) !i !i !(Elm ls i)
+  type Arg (ls :!: Strng v x)   = Arg ls :. v x
+  getArg (ElmStrng x _ _ ls) = getArg ls :. x
+  getIdx (ElmStrng _ i _ _ ) = i
+  getOmx (ElmStrng _ _ o _ ) = o
+  {-# Inline getArg #-}
+  {-# Inline getIdx #-}
+  {-# Inline getOmx #-}
+
+deriving instance (Show i, Show (v x), Show (Elm ls i)) => Show (Elm (ls :!: Strng v x) i)
+
+type instance TermArg (TermSymbol a (Strng v x)) = TermArg a :. v x
+
diff --git a/ADPfusion.cabal b/ADPfusion.cabal
--- a/ADPfusion.cabal
+++ b/ADPfusion.cabal
@@ -1,24 +1,36 @@
 name:           ADPfusion
-version:        0.2.1.0
-author:         Christian Hoener zu Siederdissen, 2011-2013
-copyright:      Christian Hoener zu Siederdissen, 2011-2013
-homepage:       http://www.tbi.univie.ac.at/~choener/adpfusion
-maintainer:     choener@tbi.univie.ac.at
-category:       Algorithms, Data Structures, Bioinformatics
+version:        0.4.0.0
+author:         Christian Hoener zu Siederdissen, 2011-2015
+copyright:      Christian Hoener zu Siederdissen, 2011-2015
+homepage:       http://www.bioinf.uni-leipzig.de/Software/gADP/
+maintainer:     choener@bioinf.uni-leipzig.de
+category:       Algorithms, Data Structures, Bioinformatics, Formal Languages
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
 stability:      experimental
-cabal-version:  >= 1.6.0
-synopsis:
-                Efficient, high-level dynamic programming.
+cabal-version:  >= 1.10.0
+tested-with:    GHC == 7.8.4, GHC == 7.10.1
+synopsis:       Efficient, high-level dynamic programming.
 description:
                 ADPfusion combines stream-fusion (using the stream interface
                 provided by the vector library) and type-level programming to
                 provide highly efficient dynamic programming combinators.
                 .
-                This library is described in:
+                ADPfusion allows writing dynamic programs for single- and
+                multi-tape problems. Inputs can be sequences, or sets. And new
+                input types can be defined, without having to rewrite this
+                library thanks to the open-world assumption of ADPfusion.
                 .
+                The library provides the machinery for Outside and Ensemble
+                algorithms as well. Ensemble algorithms combine Inside and
+                Outside calculations.
+                .
+                The homepage provides a number of tutorial-style examples, with
+                linear and context-free grammars over sequence and set inputs.
+                .
+                Ideas implemented here are described in a couple of papers:
+                .
                 @
                 Christian Hoener zu Siederdissen
                 Sneaking Around ConcatMap: Efficient Combinators for Dynamic Programming
@@ -26,109 +38,353 @@
                 <http://doi.acm.org/10.1145/2364527.2364559> preprint: <http://www.tbi.univie.ac.at/newpapers/pdfs/TBI-p-2012-2.pdf>
                 @
                 .
-                From the programmers' viewpoint, ADPfusion behaves very much
-                like the original ADP implementation
-                <http://bibiserv.techfak.uni-bielefeld.de/adp/> developed by
-                Robert Giegerich and colleagues, though both combinator
-                semantics and backtracking are different.
-                .
-                The library internals, however, are designed not only to speed
-                up ADP by a large margin (which this library does), but also to
-                provide further runtime improvements by allowing the programmer
-                to switch over to other kinds of data structures with better
-                time and space behaviour. Most importantly, dynamic programming
-                tables can be strict, removing indirections present in lazy,
-                boxed tables.
-                .
-                As a simple benchmark, consider the Nussinov78 algorithm which
-                translates to three nested for loops (for C). In the figure,
-                four different approaches are compared using inputs with size
-                100 characters to 1000 characters in increments of 100
-                characters. "C" is an implementation (@./C/@ directory) in "C"
-                using "gcc -O3". "ADP" is the original ADP approach (see link
-                above), while "GAPC" uses the "GAP" language
-                (<http://gapc.eu/>).
-                .
-                Performance comparison figure:
-                <http://www.tbi.univie.ac.at/~choener/adpfusion/gaplike-nussinov-runtime.jpg>
-                .
-                Please note that actual performance will depend much on table
-                layout and data structures accessed during calculations, but in
-                general performance is very good: close to C and better than
-                other high-level approaches (that I know of).
-                .
-                .
-                .
-                Even complex ADP code tends to be completely optimized to loops
-                that use only unboxed variables (Int# and others,
-                indexIntArray# and others).
-                .
-                Completely novel (compared to ADP), is the idea of allowing
-                efficient monadic combinators. This facilitates writing code
-                that performs backtracking, or samples structures
-                stochastically, among others things.
+                @
+                Andrew Farmer, Christian Höner zu Siederdissen, and Andy Gill.
+                The HERMIT in the stream: fusing stream fusion’s concatMap.
+                2014. Proceedings of the ACM SIGPLAN 2014 workshop on Partial evaluation and program manipulation.
+                <http://dl.acm.org/citation.cfm?doid=2543728.2543736>
+                @
                 .
+                @
+                Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler.
+                Product Grammars for Alignment and Folding.
+                2014. IEEE/ACM Transactions on Computational Biology and Bioinformatics. 99.
+                <http://ieeexplore.ieee.org/xpl/articleDetails.jsp?arnumber=6819790>
+                @
                 .
+                @
+                Christian Höner zu Siederdissen, Sonja J. Prohaska, and Peter F. Stadler.
+                Algebraic Dynamic Programming over General Data Structures.
+                2015. submitted.
+                @
                 .
-                Two algorithms from the realm of computational biology are
-                provided as examples on how to write dynamic programming
-                algorithms using this library:
-                <http://hackage.haskell.org/package/Nussinov78> and
-                <http://hackage.haskell.org/package/RNAFold>.
 
 
 
 Extra-Source-Files:
   README.md
-  changelog
+  changelog.md
 
 
 
+flag examples
+  description:  build the examples
+  default:      False
+  manual:       True
+
+flag llvm
+  description:  build using LLVM
+  default:      False
+  manual:       True
+
+flag debug
+  description:  dump intermediate Core files
+  default:      False
+  manual:       True
+
+
+
 library
-  build-depends:
-    base >= 4 && < 5,
-    deepseq        >= 1.3     ,
-    ghc-prim                  ,
-    primitive      >= 0.5     ,
-    PrimitiveArray >= 0.5.3   ,
-    QuickCheck     >= 2.5     ,
-    repa           >= 3.2     ,
-    strict         >= 0.3.2   ,
-    template-haskell          ,
-    transformers              ,
-    vector         >= 0.10
+
+  build-depends: base               >= 4.7      && < 4.9
+               , bits               == 0.4.*
+               , mmorph             == 1.0.*
+               , monad-primitive    == 0.1
+               , mtl                == 2.*
+               , OrderedBits        == 0.0.0.*
+               , primitive          >= 0.5.4    && < 0.7
+               , PrimitiveArray     == 0.6.0.*
+               , QuickCheck         >= 2.7      && < 2.9
+               , strict             == 0.3.*
+               , template-haskell   == 2.*
+               , transformers       >= 0.3      && < 0.5
+               , tuple              == 0.3.*
+               , vector             == 0.10.*
+
   exposed-modules:
     ADP.Fusion
     ADP.Fusion.Apply
-    ADP.Fusion.Chr
-    ADP.Fusion.Classes
-    ADP.Fusion.Empty
-    ADP.Fusion.Examples.Palindrome
-    ADP.Fusion.Multi
-    ADP.Fusion.Multi.Classes
-    ADP.Fusion.Multi.Empty
-    ADP.Fusion.Multi.GChr
-    ADP.Fusion.Multi.None
-    ADP.Fusion.None
-    ADP.Fusion.QuickCheck
-    ADP.Fusion.Region
-    ADP.Fusion.Table
+    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.Term
+    ADP.Fusion.Term.Chr
+    ADP.Fusion.Term.Chr.Point
+    ADP.Fusion.Term.Chr.Subword
+    ADP.Fusion.Term.Chr.Type
+    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.Subword
+    ADP.Fusion.Term.Epsilon.Type
+    ADP.Fusion.Term.Deletion
+    ADP.Fusion.Term.Deletion.Point
+    ADP.Fusion.Term.Deletion.Type
+    ADP.Fusion.Term.PeekIndex.Subword
+    ADP.Fusion.Term.PeekIndex.Type
+    ADP.Fusion.Term.Strng
+    ADP.Fusion.Term.Strng.Point
+    ADP.Fusion.Term.Strng.Type
+    ADP.Fusion.SynVar
+    ADP.Fusion.SynVar.Array
+    ADP.Fusion.SynVar.Array.Point
+    ADP.Fusion.SynVar.Array.Set
+    ADP.Fusion.SynVar.Array.Subword
+    ADP.Fusion.SynVar.Array.Type
+    ADP.Fusion.SynVar.Axiom
+    ADP.Fusion.SynVar.Backtrack
+    ADP.Fusion.SynVar.Fill
+    ADP.Fusion.SynVar.Indices
+    ADP.Fusion.SynVar.Recursive
+    ADP.Fusion.SynVar.Recursive.Point
+    ADP.Fusion.SynVar.Recursive.Subword
+    ADP.Fusion.SynVar.Recursive.Type
     ADP.Fusion.TH
+    ADP.Fusion.TH.Backtrack
+    ADP.Fusion.TH.Common
+    ADP.Fusion.QuickCheck.Common
+    ADP.Fusion.QuickCheck.Point
+    ADP.Fusion.QuickCheck.Set
+    ADP.Fusion.QuickCheck.Subword
 
+  default-extensions: BangPatterns
+                    , DefaultSignatures
+                    , FlexibleContexts
+                    , FlexibleInstances
+                    , GADTs
+                    , MultiParamTypeClasses
+                    , RankNTypes
+                    , StandaloneDeriving
+                    , TemplateHaskell
+                    , TypeFamilies
+                    , TypeOperators
+                    , TypeSynonymInstances
+                    , UndecidableInstances
+
+  default-language:
+    Haskell2010
   ghc-options:
     -O2 -funbox-strict-fields
 
+
+
+-- 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
   main-is:
-    ADP/Fusion/Examples/TwoDim.hs
+    NeedlemanWunsch.hs
+  default-language:
+    Haskell2010
+  default-extensions: BangPatterns
+                    , FlexibleContexts
+                    , FlexibleInstances
+                    , MultiParamTypeClasses
+                    , RecordWildCards
+                    , TemplateHaskell
+                    , TypeFamilies
+                    , TypeOperators
   ghc-options:
-    -Odph
+    -O2
     -funbox-strict-fields
     -funfolding-use-threshold1000
     -funfolding-keeness-factor1000
-    -fllvm
-    -optlo-O3 -optlo-std-compile-opts
-    -fllvm-tbaa
+  if flag(llvm)
+    ghc-options:
+      -fllvm
+      -optlo-O3 -optlo-std-compile-opts
+      -fllvm-tbaa
+  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
+
+  hs-source-dirs:
+    src
+  main-is:
+    Nussinov.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(llvm)
+    ghc-options:
+      -fllvm
+      -optlo-O3 -optlo-std-compile-opts
+      -fllvm-tbaa
+  if flag(debug)
+    ghc-options:
+      -ddump-to-file
+      -ddump-simpl
+      -dsuppress-all
+
+
+
+-- Basic RNA secondary structure folding with partition function calculations
+
+executable PartNussinov
+
+  if flag(examples)
+    buildable:
+      True
+    build-depends:  base
+                 ,  ADPfusion
+                 ,  log-domain        == 0.10.*
+                 ,  PrimitiveArray
+                 ,  template-haskell
+                 ,  vector
+  else
+    buildable:
+      False
+
+  hs-source-dirs:
+    src
+  main-is:
+    PartNussinov.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(llvm)
+    ghc-options:
+      -fllvm
+      -optlo-O3 -optlo-std-compile-opts
+      -fllvm-tbaa
+  if flag(debug)
+    ghc-options:
+      -ddump-to-file
+      -ddump-simpl
+      -dsuppress-all
+
+
+
+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(llvm)
+    ghc-options:
+      -fllvm
+      -optlo-O3 -optlo-std-compile-opts
+      -fllvm-tbaa
+  if flag(debug)
+    ghc-options:
+      -ddump-to-file
+      -ddump-simpl
+      -dsuppress-all
+
+
+
+test-suite properties
+  type:
+    exitcode-stdio-1.0
+  main-is:
+    properties.hs
+  ghc-options:
+    -threaded -rtsopts -with-rtsopts=-N
+  hs-source-dirs:
+    tests
+  default-language:
+    Haskell2010
+  default-extensions: TemplateHaskell
+  build-depends: base
+               , ADPfusion
+               , QuickCheck
+               , test-framework               >= 0.8  && < 0.9
+               , test-framework-quickcheck2   >= 0.3  && < 0.4
+               , test-framework-th            >= 0.2  && < 0.3
+
+
 
 source-repository head
   type: git
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright Christian Hoener zu Siederdissen 2011-2012
+Copyright Christian Hoener zu Siederdissen 2011-2015
 
 All rights reserved.
 
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,15 +1,13 @@
+# ADPfusion
 
-ADPfusion
-(c) 2012, Christian Hoener zu Siederdissen
-University of Vienna, Vienna, Austria
-choener@tbi.univie.ac.at
-LICENSE: BSD3
+[![Build Status](https://travis-ci.org/choener/ADPfusion.svg?branch=master)](https://travis-ci.org/choener/ADPfusion)
 
+[*generalized ADPfusion Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)
 
 
-Introduction
-============
 
+# Introduction
+
 ADPfusion combines stream-fusion (using the stream interface provided by the
 vector library) and type-level programming to provide highly efficient dynamic
 programming combinators.
@@ -46,9 +44,9 @@
 <http://hackage.haskell.org/package/RNAfold>.
 
 
-Installation
-============
 
+# Installation
+
 If GHC-7.2.2/GHC-7.4, LLVM and cabal-install are available, you should be all
 set. I recommend using cabal-dev as it provides a very nice sandbox (replace
 cabal-dev with cabal otherwise).
@@ -66,8 +64,7 @@
 
 
 
-Notes
-=====
+# Notes
 
 If you have problems, find bugs, or want to use this library to write your own
 DP algorithms, please send me a mail. I'm very interested in hearing what is
@@ -83,35 +80,25 @@
 
 
 
-VERSION HISTORY
-===============
+# Implementors Notes
 
-- 0.0.0.3:
-  - initial version, together with submitted paper
 
-- 0.0.0.4:
-  - based most combinators on just two generalized Box creators
-  - cleaned up and simplified RNAfold example
-  - RNAfold execution now a bit slower. Simplified energy functions typically
-    only have three arguments now, which can be of 'Primary' type. While this
-    reduces speed because we will repeatedly ask for the same value, it is much
-    easier to handle the different functions and ``play'' with fusion
-    properties.
-  - RNAfold compilation massively faster: execution/compilation tradoff is
-    worth it for experimenting with ADPfusion; still faster than anything
-    except RNAfold itself. We are now now 2.8x times slower, but 3.5x times
-    slower
-  - Quickcheck properties for many combinators
-  - Unit tests for RNAfold functions
-  - will soon split off RNAfold and Nussinov and publish three hackage
-    libraries
-  - this version was never available, after being done, a split into library
-    and examples was performed.
+- The general inlining scheme is: (i) mkStream is {-# INLINE mkStream #-},
+  inner functions like mk, step, worker functions, and index-modifying
+  functions get an {-# INLINE [0] funName #-}. Where there is no function to
+  annotate, use delay_inline.
 
-- 0.0.1.0
-  - providing just the library. Examples are found in different libraries.
+- If you implement a new kind of memoizing table, like the dense Table.Array
+  ones, you will have to implement mkStream code. When you hand to the left,
+  the (i,j) indices and modify their extend (by, say, having NonEmpty table
+  constaints), you have to delay_inline this (until inliner phase 0). Otherwise
+  you will break fusion for mkStream.
 
-- 0.0.1.1
-  - this version should be compatible with GHC-7.4, at least GHC-7,4.2-rc1.
-  - a type family (TF) version has not been able to show the same performance
-    as fundeps. This means that fundeps for Internal.hs stay alive, for now.
+
+
+#### Contact
+
+Christian Hoener zu Siederdissen
+choener@bioinf.uni-leipzig.de
+Leipzig University, Leipzig, Germany
+
diff --git a/changelog b/changelog
deleted file mode 100644
--- a/changelog
+++ /dev/null
@@ -1,4 +0,0 @@
-0.2:
-      * Streamlined interface: access everything via ADP.Fusion
-
-      * /Multi-tape/ grammars can now be written and are fused
diff --git a/changelog.md b/changelog.md
new file mode 100644
--- /dev/null
+++ b/changelog.md
@@ -0,0 +1,31 @@
+0.4.0.0
+-------
+
+- travic-ci integration
+- forward phase now operates on immutable tables that are internally thawed
+- resembles the behavior of Data.Vector.Generic.constructN
+- Empty needs to be bound to input. We require this as certain index structures
+  have no natural notion of and empty index -- unless one provides additional
+  information in the index
+
+0.3.0.0
+-------
+
+- simplified boundary checking: sometimes gives performance gain (!) due to one
+  loop variable less
+- optimized loop variable design following "The HERMIT in the Stream" (Farmer
+  et al, 2014)
+- somewhat nicer programmer interfaces
+- automatic filling and freezing of tables
+- multiple example algorithms (build with -fexamples switch):
+  - Needleman-Wunsch global alignment
+  - RNA secondary structure prediction using simple base pair maximization
+- updated Table code to handle single-dim Subwords in a better way.
+- simplified backtracking
+
+0.2.x.x
+-------
+
+- Streamlined interface: access everything via ADP.Fusion
+- /Multi-tape/ grammars can now be written and are fused
+
diff --git a/src/Durbin.hs b/src/Durbin.hs
new file mode 100644
--- /dev/null
+++ b/src/Durbin.hs
@@ -0,0 +1,122 @@
+
+-- | 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 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 -> 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 #-}
+
+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
+  in (Z:.t)
+{-# INLINE grammar #-}
+
+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 Subword Int
+  -- d = let (ITbl _ _ arr _) = t in arr PA.! subword 0 n
+  d = iTblArray t PA.! subword 0 n
+  !(Z:.b) = grammar (bpmax <|| pretty) (chr i) (toBacktrack t (undefined :: Id a -> Id a))
+
+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
new file mode 100644
--- /dev/null
+++ b/src/NeedlemanWunsch.hs
@@ -0,0 +1,323 @@
+
+-- | 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.
+--
+-- 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.
+--
+-- Don't forget to inline basically everything!
+--
+-- One note on performance: Needleman-Wunsch is actually one of the worst
+-- cases for ADPfusion. Low-level implementations can get away with a very
+-- small number of code steps for each cell to be filled. We can't /quite/
+-- do this. The relative overhead for each cell to be written into goes
+-- down with more complex grammars and algebras.
+
+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 as S
+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
+
+-- @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@ exposes everything necessary for higher-level DP
+-- algorithms.
+
+import           ADP.Fusion
+
+
+
+-- | 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.
+--
+-- 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
+-- 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
+  }
+
+-- | 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
+
+-- | 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 = 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 #-}
+
+-- | 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 #-}
+
+-- | Scores alone are 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 = return
+-- . id@, 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 #-}
+
+-- | 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 #-}
+
+-- | 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:.ITbl Id Unboxed (Z:.PointL:.PointL) 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 #-}
+
+nwInsideBacktrack :: VU.Vector Char -> VU.Vector Char -> ITbl Id Unboxed (Z:.PointL:.PointL) Int -> [[String]]
+nwInsideBacktrack i1 i2 t = {-# SCC "nwInsideBacktrack" #-} unId $ axiom b
+  where !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
+{-# NoInline nwInsideBacktrack #-}
+
+-- | 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 -- . S.toList . unId $ axiom b) where -- ,gogo) 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.! (O (Z:.PointL 0:.PointL 0))
+  !(Z:.b) = grammar (sScore <|| sPretty) (toBacktrack t (undefined :: Id a -> Id a)) i1 i2
+{-# Noinline runOutsideNeedlemanWunsch #-}
+
+-- | Again, to be able to observe performance, we have extracted the
+-- outside-table-filling part.
+
+nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.ITbl Id Unboxed (Outside (Z:.PointL:.PointL)) Int
+nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $
+                           grammar sScore
+                           (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (O (Z:.PointL 0:.PointL 0)) (O (Z:.PointL n1:.PointL n2)) (-999999) []))
+                           i1 i2
+  where n1 = VU.length i1
+        n2 = VU.length i2
+{-# Noinline nwOutsideForward #-}
+
+-- | 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
+
+-- | 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/src/Nussinov.hs b/src/Nussinov.hs
new file mode 100644
--- /dev/null
+++ b/src/Nussinov.hs
@@ -0,0 +1,132 @@
+
+-- | 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 -- . {- . S.toList . -} unId $ axiom b) 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 Subword 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 Subword 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/PartNussinov.hs b/src/PartNussinov.hs
new file mode 100644
--- /dev/null
+++ b/src/PartNussinov.hs
@@ -0,0 +1,275 @@
+
+-- | 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 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
+
+
+
+-- * 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)
+        (Complement Subword:.(Complement Subword))
+        (Subword, Log Double)
+        [(Subword, Log Double)]
+ensemble z = NussinovEnsemble
+  { ens = \ x (C k:._) y -> ( k , x * y / z )
+  , hhh = SM.toList
+  }
+{-# Inline ensemble #-}
+
+ensembleGrammar NussinovEnsemble{..} i o v' =
+  let v = v' ( ens <<< i % (PeekIndex :: PeekIndex (Complement Subword)) % o ... hhh )
+  in  Z:.v
+{-# Inline ensembleGrammar #-}
+
+-- makeAlgebraProductH ['hhh] ''NussinovEnsemble
+
+
+
+-- * Run different algorithm parts
+
+runNussinov :: String -> ([(Subword, 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.! (O $ subword k k) | k <- [0 .. n] ]
+  ys =  [ ( k
+          , l
+          , fwda PA.! subword k l
+          , fwdp PA.! subword k l
+          , bwdb PA.! (O $ subword k l)
+          , bwdq PA.! (O $ subword k l)
+          )
+        | 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          Subword  (Log Double)
+type TblO = ITbl Id Unboxed (Outside Subword) (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 (O $ subword 0 0) (O $ subword 0 n) 0 []))
+                            (ITbl 0 1 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) 0 []))
+  where n = VU.length i
+{-# NoInline runOutsideForward #-}
+
+runEnsembleForward :: Log Double -> TblI -> TblO -> [ (Subword,Log Double) ]
+runEnsembleForward z i o = unId $ axiom g
+  where (Z:.g) = ensembleGrammar (ensemble z)
+                   i o
+                   (IRec EmptyOk (C l) (C h))
+                 :: Z :. IRec Id (Complement Subword) [(Subword, Log Double)]
+        (l,h) = let (ITbl _ _ _ arr _) = i in bounds arr
+{-# 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/tests/properties.hs b/tests/properties.hs
new file mode 100644
--- /dev/null
+++ b/tests/properties.hs
@@ -0,0 +1,90 @@
+
+-- | Test all properties automatically. We keep the QC2 modules in the main
+-- library for now, as this allows for more efficient repl tests.
+
+module Main where
+
+import Test.Framework.Providers.QuickCheck2
+import Test.Framework.TH
+
+import qualified ADP.Fusion.QuickCheck.Subword  as QSW
+import qualified ADP.Fusion.QuickCheck.Set      as QS
+import qualified ADP.Fusion.QuickCheck.Point    as QP
+import ADP.Fusion.QuickCheck.Point
+
+
+{-
+grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Subword.hs | awk '{print $1"QSW", "=", "QSW."$1 }' | uniq
+grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Set.hs | awk '{print $1"QS", "=", "QS."$1 }' | uniq
+grep -o -e "^prop_[[:alnum:]_]*" ADP/Fusion/QuickCheck/Point.hs | awk '{print $1"QP", "=", "QP."$1 }' | uniq
+-}
+
+-- subwords
+
+prop_sv_OIQSW = QSW.prop_sv_OI
+prop_sv_IOQSW = QSW.prop_sv_IO
+prop_sv_OIIQSW = QSW.prop_sv_OII
+prop_sv_IOIQSW = QSW.prop_sv_IOI
+prop_sv_IIOQSW = QSW.prop_sv_IIO
+prop_cOcQSW = QSW.prop_cOc
+prop_ccOccQSW = QSW.prop_ccOcc
+prop_cOcccQSW = QSW.prop_cOccc
+prop_cOcIcQSW = QSW.prop_cOcIc
+prop_cIcOcQSW = QSW.prop_cIcOc
+prop_EpsilonQSW = QSW.prop_Epsilon
+
+-- sets
+
+prop_b_iiQS = QS.prop_b_ii
+prop_b_ii_nnQS = QS.prop_b_ii_nn
+prop_b_iiiQS = QS.prop_b_iii
+prop_b_iii_nnnQS = QS.prop_b_iii_nnn
+prop_bii_iQS = QS.prop_bii_i
+prop_bii_i_nQS = QS.prop_bii_i_n
+prop_bii_eQS = QS.prop_bii_e
+prop_bii_ieQS = QS.prop_bii_ie
+prop_bii_ie_nQS = QS.prop_bii_ie_n
+prop_bii_ieeQS = QS.prop_bii_iee
+prop_bii_ieeeQS = QS.prop_bii_ieee
+prop_bii_iee_nQS = QS.prop_bii_iee_n
+prop_bii_ieee_nQS = QS.prop_bii_ieee_n
+
+-- points
+
+prop_EpsilonQP = QP.prop_Epsilon
+prop_O_EpsilonQP = QP.prop_O_Epsilon
+prop_ZEpsilonQP = QP.prop_ZEpsilon
+prop_O_ZEpsilonQP = QP.prop_O_ZEpsilon
+prop_O_ZEpsilonEpsilonQP = QP.prop_O_ZEpsilonEpsilon
+prop_O_ItNCQP = QP.prop_O_ItNC
+prop_O_ZItNCQP = QP.prop_O_ZItNC
+prop_O_2dimIt_NC_CNQP = QP.prop_O_2dimIt_NC_CN
+prop_2dimIt_NC_CNQP = QP.prop_2dimIt_NC_CN
+prop_TtQP = QP.prop_Tt
+prop_CCQP = QP.prop_CC
+prop_ItQP = QP.prop_It
+prop_O_ItQP = QP.prop_O_It
+prop_ZItQP = QP.prop_ZIt
+prop_O_ZItQP = QP.prop_O_ZIt
+prop_ItCQP = QP.prop_ItC
+prop_O_ItCQP = QP.prop_O_ItC
+prop_O_ItCCQP = QP.prop_O_ItCC
+prop_O_ZItCCQP = QP.prop_O_ZItCC
+prop_2dimItCCQP = QP.prop_2dimItCC
+prop_O_2dimItCCQP = QP.prop_O_2dimItCC
+prop_ManySQP = QP.prop_ManyS
+prop_SomeSQP = QP.prop_SomeS
+prop_2dim_ManyS_ManySQP = QP.prop_2dim_ManyS_ManyS
+prop_2dim_SomeS_SomeSQP = QP.prop_2dim_SomeS_SomeS
+prop_Itbl_ManySQP = QP.prop_Itbl_ManyS
+prop_Itbl_SomeSQP = QP.prop_Itbl_SomeS
+prop_1dim_Itbl_ManySQP = QP.prop_1dim_Itbl_ManyS
+prop_1dim_Itbl_SomeSQP = QP.prop_1dim_Itbl_SomeS
+prop_2dim_Itbl_ManyS_ManySQP = QP.prop_2dim_Itbl_ManyS_ManyS
+prop_2dim_Itbl_SomeS_SomeSQP = QP.prop_2dim_Itbl_SomeS_SomeS
+
+
+
+main :: IO ()
+main = $(defaultMainGenerator)
+