packages feed

ADPfusionForest (empty) → 0.0.0.1

raw patch · 29 files changed

+4519/−0 lines, 29 filesdep +ADPfusiondep +ADPfusionForestdep +BiobaseNewicksetup-changed

Dependencies added: ADPfusion, ADPfusionForest, BiobaseNewick, DPutils, ForestStructures, FormalGrammars, GrammarProducts, PrimitiveArray, PrimitiveArray-Pretty, QuickCheck, base, cmdargs, containers, criterion, fgl, filepath, log-domain, strict, tasty, tasty-quickcheck, tasty-th, text, unordered-containers, vector, vector-algorithms, vector-instances, vector-th-unbox

Files

+ ADP/Fusion/Core/ForestAlign/PermuteRightLinear.hs view
@@ -0,0 +1,1401 @@++-- | Data structures and instances to combine efficient 'Forest' structures+-- with @ADPfusion@.++module ADP.Fusion.Core.ForestAlign.PermuteRightLinear where++import qualified Data.List as L+import           Control.Exception (assert)+import           Data.Either (either)+import           Data.Graph.Inductive.Basic+import           Data.Strict.Tuple hiding (fst, snd)+import           Data.Traversable (mapAccumL)+import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Debug.Trace+import           Prelude hiding (map)+import qualified Data.Forest.Static as F+import qualified Data.Tree as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Unboxed as VU+import           Data.Vector.Instances+import qualified Data.Vector.Algorithms.Intro as VI+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as S+import           Data.List (subsequences, permutations)+import qualified Data.List as L+import qualified Prelude as P++import           ADP.Fusion.Core+import           Data.Forest.Static+import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Term.Node.Type++-- HETEROGEN++-- |++data TreeIxR p v a t+  -- | The @TreeIxR@ constructor holds the runtime information for the+  -- current subforest we look at.+  --+  -- We have a pointer to the actual forest structure @Forest p v a@. Next,+  -- we have @Lookup@, it gives a linear index from the set of ordered+  -- subforests to the set @|N@.+  --+  -- The actual runtime position is held by @TFE@, which is an index+  -- structure in the current substructure.+  = TreeIxR !(Forest p v a) !LookUp !TFE++instance Show (TreeIxR p v a t) where+  show (TreeIxR _ i j) = show (i,j)++minIx, maxIx :: Forest Pre v a -> TreeIxR Pre v a t+minIx f = let l = mkLookUp f+          in  TreeIxR f l (F (VU.fromList []))  -- $ roots f)++maxIx f = let l = mkLookUp f+          in  TreeIxR f l (E $ VU.length (parent f))+{-# Inline minIx #-}+{-# Inline maxIx #-}++-- | For permutated trees, we need to know the order of the remaining+-- children, given as a @VU.Vector Int@, yielding the next linearized+-- index. The @LookUp@ data structure holds all possible such orderings of+-- children.++type LookUp = HM.HashMap (VU.Vector Int) Int++-- | Given a static forest, we need to associate each possible ordered+-- subset of children of each node with a linear index. The @mkLookUp@+-- function generates this.+--+-- TODO use 'sortedSubForests' such that the partial order matches the+-- linearized order.++mkLookUp :: Forest Pre v a -> LookUp+mkLookUp f = HM.fromList . flip P.zip [0..] $ sortedSubForests f+{-+mkLookUp f = HM.fromList . flip P.zip [0..] . go $ roots f : (VG.toList $ children f)+  where go :: [VU.Vector Int] -> [VU.Vector Int]+        go = P.map VG.fromList+           . S.toList . S.fromList+           . P.concatMap (P.tail . subsequences)+           . P.concatMap permutations+           . P.map VG.toList+        -- @go@ generates all permutations (i.e. all orders of children),+        -- then for each such order provides all possible subsequences.+        -- This yields all ordered subsets. These are then made unique and+        -- associated in the main body with linearized indices.+-}++-- | @TFE@ provides the three possible "states" of our system. @E@+-- indicates that we have reached an indixed epsilon state. @T@ is the tree+-- originating at a particular node. Finally @F@ is the subforest with an+-- attached ordered set of subtrees.++data TFE+  -- | Forest with permutation. The vector holds the trees making up the+  -- forest, and their order via the root node indices of the individual+  -- trees.+  --+  -- TODO do we allow empty forests?+  = F (VU.Vector Int)+  -- | A single tree, represented by the index of the root node.+  | T !Int+  -- | An empty forest, BUT annotated with index for the subforest "to the+  -- right of it".+  | E !Int+  deriving (Show,Eq,Ord)++isTree (T _) = True+isTree _     = False+{-# Inline isTree #-}++isEmpty (E _) = True+isEmpty _ = False+{-# Inline isEmpty #-}++getTFEIx (T l) = l+getTFEIx (E l) = l+getTFEIx (F vs)+  | VU.null vs = error "AlignPermuteRL: Forest empty" -- change!!!+  | otherwise = VU.head vs+++-- | As usual, we need a running index. We only need the @TFE@ structure,+-- since now (and compared to @AlignRL.hs@) we actually carry the node+-- information in each @TFE@ ctor.++data instance RunningIndex (TreeIxR p v a I) = RiTirI !TFE+++-- | The index function needs to provide a linearized representation of the+-- @TFE@-based index.++instance Index (TreeIxR p v a t) where+  -- | trees @T@ are stored in the first line, i.e. @+0@, forests @F@ (with+  -- @j==u@ are stored in the second line, i.e. @+u+1@ to each index.+  -- Finally, all @F@ structures are looked up based on the linear index,+  -- shifted by the base width of @2*m@.+  linearIndex (TreeIxR _ _ ll) (TreeIxR _ _ uu) (TreeIxR _ lk tf)+    | T k <- tf = 2*k+    | E k <- tf = 2*k + 1+    | F k <- tf = 2*(m+1) + HM.lookupDefault (error "AlignPermuteRL: invariant violated!") k lk+    where E m = uu+  {-# Inline linearIndex #-}+  smallestLinearIndex _ = error "still needed?"+  {-# Inline smallestLinearIndex #-}+  largestLinearIndex (TreeIxR p lk (E u)) = 2 * (u+1) + HM.size lk+  largestLinearIndex (TreeIxR p lk err) = error $ "non-legal largest index structure: " P.++ show err+  {-# Inline largestLinearIndex #-}+  size (TreeIxR _ l ll) (TreeIxR _ lk (E u)) = 2 * (u+1) + HM.size l + 1+  {-# Inline size #-}+  inBounds (TreeIxR _ l _) (TreeIxR _ u _) (TreeIxR _ k _) = error "inBounds: write me" -- l <= k && k <= u+  {-# Inline inBounds #-}++++instance IndexStream z => IndexStream (z:.TreeIxR Pre v a I) where+  streamUp   (ls:.TreeIxR p llk lf) (hs:.TreeIxR _ _ ht) = flatten (streamUpMk   p lf ht) (streamUpStep   p llk lf ht) $ streamUp ls hs+--  streamDown (ls:.TreeIxR p llk lf) (hs:.TreeIxR _ _ ht) = flatten (streamUpMk   p lf ht) (streamUpStep   p llk lf ht) $ streamDown ls hs -- STUPID!!!+  streamDown (ls:.TreeIxR p llk lf) (hs:.TreeIxR _ _ ht) = flatten (streamDownMk p lf ht) (streamDownStep p llk lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++-- cull from p the non-needed parts via lf ht+streamUpMk p lf ht z =+      -- all sorted subsets of subforests in the forest (have a beer).+  let ssf = sortedSubForests p+      -- extract the highest possible index, which by definition is an+      -- @E index@.+      E ht' = ht+  in  {- trace ("XXX" P.++ show ssf) . -} return $ SE' ht' (z,ssf)+{-# Inline [0] streamUpMk #-}++streamDownMk p lf ht z =+  let ssf = reverse $ VG.empty : sortedSubForests p+  in  return $ Stp (z,ssf)+{-# Inline [0] streamDownMk #-}++-- |++data StepTFE x+  -- | @x@ is a set of size>=1, which will be turned into a forest.+  = SF x+  -- | @x@ is a set of size ==1, which will be turned into a tree.+  | ST x+  -- | Perform one step in @streamUpStep@. In case of trees, this will+  -- actually yield both a tree and a forest.+  | Stp x+  -- | This encodes that we have an empty forest (@E@), but directly+  -- encodes the highest @Int@-index given via @streamUpMk@.+  | SE' Int x+  -- | Only for outside calculations!+  | SEout x++-- | For each index @k@, we can easily first calculate @Epsilon k@. Then we+-- want to know the tree at index @k@, but this needs knowledge of all+-- subforests below it, hence we need to calculate this before @Tree k@.++-- this one is called only once and creates an @E k@ element at the highest+-- possible index.+streamUpStep p lk lf ht (SE' k (z,xs))+  = return $ SM.Yield (z:.TreeIxR p lk (E k)) (Stp (z,xs))+-- there is no subforest left to work with. We are done.+streamUpStep p lk lf ht (Stp (z,[]))+  = return $ SM.Done+-- We have at least one sorted subforest @x:@ to deal with. By definition,+-- sets of size 0 do not happen. This is enforced by @sortedSubForests@+-- which produces vectors of @size >= 1@.+streamUpStep p lk lf ht (Stp (z,x:xs))+  -- subsets of size one are trees. They first create an @E@psilon object.+  -- Then they create a @T@ree object, followed by a @F@orest with one tree.+  | sz == 1 = return $ SM.Yield (z:.TreeIxR p lk (E i)) (ST (z,x:xs))+  -- subsets of size 2 or more just create forests and we jump directly to+  -- forest creation.+  | sz >= 2 = return $ SM.Skip (SF (z,x:xs))+  where sz = VU.length x+        i = VU.head x+-- Here we deal with structures that are supposed to be a tree @T@, via+-- @ST@. Seems stupid at first, but if the set size of @x@ is one, we first+-- create a @T@ree @T i@, then we will produce a forest @F [i]@ one step+-- later.+-- Here, we only have subsets of size ==1. We build a tree (we have already+-- built the @E@ part before), and continue on to build a forest with+-- exactly one tree inside.+streamUpStep p lk lf ht (ST (z,x:xs))+  = return $ SM.Yield (z:.TreeIxR p lk (T i)) (SF (z,x:xs))+  where i = VU.head x+-- Create an ordered subforest @F x@. After that, we are done with @x@+-- (indepedent of it being a tree or a forest), and continue with the+-- remainder of the sets.+streamUpStep p lk lf ht (SF (z,x:xs))+  = return $ SM.Yield (z:.TreeIxR p lk (F x)) (Stp (z,xs))+{-# Inline [0] streamUpStep #-}++-- |++-- this is the case of our artificially added size==0 set.+streamDownStep p lk lf ht (Stp (z,[x]))+  = let E k = ht+    in  return $ SM.Yield (z:.TreeIxR p lk (E k)) (Stp (z,[]))+streamDownStep p lk lf ht (Stp (z,[]))+  = return $ SM.Done+streamDownStep p lk lf ht (Stp (z,x:xs))+  | sz == 1 = return $ SM.Yield (z:.TreeIxR p lk (F x)) (ST (z,x:xs))+  | sz >= 2 = return $ SM.Yield (z:.TreeIxR p lk (F x)) (Stp (z,xs))+  where sz = VG.length x+streamDownStep p lk lf ht (ST (z,x:xs))+  = return $ SM.Yield (z:.TreeIxR p lk (T i)) (SEout (z,x:xs))+  where i = VG.head x+streamDownStep p lk lf ht (SEout (z,x:xs))+  = return $ SM.Yield (z:.TreeIxR p lk (E i)) (Stp (z,xs))+  where i = VG.head x+{-# Inline [0] streamDownStep #-}++{-++streamDownMk lf ht z = return (z,lf,minBound :: TF)+{-# Inline [0] streamDownMk #-}++streamDownStep p lf ht (z,k,tf)+  | k > ht         = return $ SM.Done+  | tf == maxBound = return $ SM.Yield (z:.TreeIxR p k tf) (z,k+1,minBound)+  | otherwise      = return $ SM.Yield (z:.TreeIxR p k tf) (z,k,succ tf)+{-# Inline [0] streamDownStep #-}++-}++instance IndexStream (Z:.TreeIxR p v a t) => IndexStream (TreeIxR p v a t)++instance RuleContext (TreeIxR p v a I) where+  type Context (TreeIxR p v a I) = InsideContext ()+  initialContext _ = IStatic ()+  {-# Inline initialContext #-}+++++-- | Epsilon+--+-- X    -> ε+-- i,E     i,E    ∀ i++instance+  ( TmkCtx1 m ls Epsilon (TreeIxR p v a t)+  ) => MkStream m (ls :!: Epsilon) (TreeIxR p v a t) where+  mkStream (ls :!: Epsilon) sv us is+    = map (\(ss,ee,ii) -> ElmEpsilon ii ss)+    . addTermStream1 Epsilon sv us is+    $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)+  {-# Inline mkStream #-}+++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a I)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.TreeIxR p v a I) where+  termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.TreeIxR _ ul utfe) (is:.TreeIxR frst il itfe)+    = map (\(TState s ii ee) ->+              let RiTirI ef = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                  l         = case ef of {E l -> l ; F _ -> 0}+              in  TState s (ii:.:RiTirI ef) (ee:.()) )+    . termStream ts cs us is+    . staticCheck ( (isEmpty itfe) || getTFEIx utfe == 0) --TODO: 2nd condition takes care of empty inputs+  {-# Inline termStream #-}+++instance TermStaticVar Epsilon (TreeIxR p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+++--deletion++instance+  ( TmkCtx1 m ls Deletion (TreeIxR p v a t)+  ) => MkStream m (ls :!: Deletion) (TreeIxR p v a t) where+  mkStream (ls :!: Deletion) sv us is+    = map (\(ss,ee,ii) -> ElmDeletion ii ss)+    . addTermStream1 Deletion sv us is+    $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is)+  {-# Inline mkStream #-}+++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a I)+  ) => TermStream m (TermSymbol ts Deletion) s (is:.TreeIxR p v a I) where+  termStream (ts:|Deletion) (cs:.IVariable ()) (us:.u) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirI tfe = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+              in  {- traceShow ("-"::String,l,tf) $ -} TState s (ii:.:RiTirI tfe) (ee:.()) )+    . termStream ts cs us is+--    . staticCheck (ii == T)+  {-# Inline termStream #-}+++instance TermStaticVar Deletion (TreeIxR p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a I) where+  mkStream S _ (TreeIxR frst ul utfe) (TreeIxR _ kl ktfe)+    = staticCheck ((getTFEIx ktfe) >=0 && (getTFEIx ktfe) <= (getTFEIx utfe)) . singleton . ElmS $ RiTirI ktfe+  {-# Inline mkStream #-}+++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a I) where+  mkStream S (vs:._) (lus:.TreeIxR frst ul utfe) (is:.TreeIxR _ kl ktfe)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirI ktfe)+    . staticCheck ((getTFEIx ktfe) >=0 && (getTFEIx ktfe) <= (getTFEIx utfe))+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++-- | When choosing tree and forest sizes, ++data TFsize s+  -- The tree shall have size epsilon, the forest be full. If @TF@ is @F@+  -- then the forest is a real forest, if @TF@ is @T@ then the forest is+  -- a tree.+  = EpsFull TFE s+  -- | The tree is full (and actually a forest), the remainder of the+  -- forest is epsilon. This means that in the "tree" synvar, we can only+  -- do indels.+  | FullEpsFF s+  -- | The tree is set, the remaining forest gets what is left.+  | OneRemFT s+  -- | The tree is set, the remaining forest is empty.+  | OneEpsTT s+  | Finis++-- | Syntactic variables. Different variants on parsing.+--+-- In case we have @X -> Y@, no restrictions are placed.+--+-- We now need @X -> Y Z@:+--+-- @+--+-- X    ->  Y     Z+-- i,E      i,E   i,E+--+--+--+-- X    ->  Y     Z       we do not split off the first tree+-- i,F      i,E   i,F+--+-- X    ->  Y     Z+-- i,F      i,T   k,F     k,E, if k==u ; 1st tree split off+--          i_k+--+-- X    ->  Y     Z       move complete forest down+-- i,F      i,F   u,E+--+--+--+-- When does this happen? If you have @T -> - F@ then @F@ will now actually+-- be such a @T@.    T -> TF ; (1) T -> εT ; (2) T -> Tε+--+-- X    ->  Y     Z       do not hand i,T down+-- i,T      i,E   i,T+--+-- X    ->  Y     Z       further hand down+-- i,T      i,T   k,E+--          i_k+--+-- @++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a I)+  , MinSize c+--  , Show a, VG.Vector v a -- TEMP!+--  , a ~ Info+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a I) where+  addIndexDenseGo (cs:._) (vs:.IStatic ()) (lbs:._) (ubs:._) (us:.TreeIxR frst ul utfe) (is:.TreeIxR _ jl jtfe)+    = map go . addIndexDenseGo cs vs lbs ubs us is+    where+      go (SvS s tt ii) =+        let RiTirI tfe = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+            -- TODO this will probably barf, because we need the index+            -- "after the empty forest", which we can't get anymore.+            tfe'       = if getTFEIx tfe == getTFEIx utfe then E (getTFEIx tfe) else tfe+        in  tSI (glb) ('S',tfe,'.') $+            SvS s (tt:.TreeIxR frst ul tfe') (ii:.:RiTirI utfe)+  addIndexDenseGo (cs:._) (vs:.IVariable ()) (lbs:._) (ubs:._) (us:.TreeIxR frst ul utfe) (is:.TreeIxR _ jl jtfe)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk svS = return $ EpsFull jtfe svS+          step Finis = return $ Done+          -- nothing here+          step (EpsFull (E _) svS@(SvS s tt ii))+            = let j = getTFEIx jtfe+              in  return $ Yield (SvS s (tt:.TreeIxR frst jl (E j)) (ii:.:RiTirI (E j))) Finis+          -- _ -> TF , for forests: with T having size ε, F having full size+          step (EpsFull (F ys) svS@(SvS s tt ii))+            = do let RiTirI ktfe = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                     k           = getTFEIx ktfe+                 tSI (glb) ('V',ktfe) .+                   return $ Yield (SvS s (tt:.TreeIxR frst jl (E k)) (ii:.:RiTirI ktfe)) (FullEpsFF svS)  -- @k Epsilon / full@+          -- _ -> TF, for forests: with T having full size, F having size ε+          step (FullEpsFF svS@(SvS s tt ii))+            = do let RiTirI ktfe = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                     u           = getTFEIx utfe+                 tSI (glb) ('A',ktfe) .+                   return $ Yield (SvS s (tt:.TreeIxR frst jl ktfe) (ii:.:RiTirI (E u))) (OneRemFT svS)   -- @full / u Epsilon@+          -- _ -> TF for forests: with T having size 1, F having full - 1 size+          step (OneRemFT (SvS s tt ii))+            = do let RiTirI (F kcs) = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                     k         = VU.head kcs+                     cs        = VU.tail kcs+                     ltfe      = if VU.null cs then (E $ getTFEIx utfe) else F cs+                 tSI (glb) ('B') .+                   return $ Yield (SvS s (tt:.TreeIxR frst jl (T k)) (ii:.:RiTirI ltfe)) Finis -- @1 / l ltf@+          -- _ -> TF , for trees: with T having size ε, F having size 1 (or T)+          step (EpsFull (T _) svS@(SvS s tt ii))+            = do let RiTirI (T k)  = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                 tSI (glb) ('Q') .+                   return $ Yield (SvS s (tt:.TreeIxR frst ul (E k)) (ii:.:RiTirI (T k))) (OneEpsTT svS)+          -- _ -> TF, for trees: with T having size 1, F having size ε+          step (OneEpsTT (SvS s tt ii))+            = do let RiTirI (T k) = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                     l         = rbdef (getTFEIx utfe) frst k+                 tSI (glb) ('W') .+                   return $ Yield (SvS s (tt:.TreeIxR frst ul (T k)) (ii:.:RiTirI (E l))) Finis+          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++glb = True++tSI cond s i = if cond then traceShow s i else i++instance (MinSize c) => TableStaticVar u c (TreeIxR p v a I) where +  tableStaticVar _ _ _ _ = IVariable ()+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++getrbound frst k+  | VG.length rs >= k = VG.length rs+  | r < 0             = VG.length rs+  | otherwise         = r+  where rs = rsib frst ; r = rs VG.! k+{-# Inline getrbound #-}++trright frst k = rbdef (VG.length $ rsib frst) frst k++-- | The next right sibling.++rbdef d frst k = maybe d (\z -> if z<0 then d else z) $ rsib frst VG.!? k+{-# Inline rbdef #-}++-- | Give us the parent for node @k@ or @-1@ if there is no parent++pardef frst k = maybe (-1) id $ parent frst VG.!? k+{-# Inline pardef #-}+++-- Outside+++data instance RunningIndex (TreeIxR p v a O) = RiTirO !TFE++++instance IndexStream z => IndexStream (z:.TreeIxR Pre v a O) where+  streamUp   (ls:.TreeIxR p llk lf) (hs:.TreeIxR _ _ ht) = flatten (streamDownMk   p lf ht) (streamDownStep   p llk lf ht) $ streamDown ls hs+  streamDown (ls:.TreeIxR p llk lf) (hs:.TreeIxR _ _ ht) = flatten (streamUpMk p lf ht) (streamUpStep p llk lf ht) $ streamUp ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++++instance RuleContext (TreeIxR p v a O) where+  type Context (TreeIxR p v a O) = OutsideContext ()+  initialContext _ = OStatic ()+  {-# Inline initialContext #-}+++-- | Node+--+-- Inside:+-- @+-- M     -> n     F+-- i,T   -> i,T   <ls>,F+--+-- where ls = ordered subforest of all children of 'i'+-- @+--+-- Outside:+-- @+-- F       -> n     M+-- <ls>,F  -> i,T   i,T+-- @+--+-- with the condition that the rule is active only if @<ls>@ is indeed the+-- whole ordered subforest below @i@.++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  , Show r+  ) => TermStream m (TermSymbol ts (Node r x)) s (is:.TreeIxR p v a O) where+  termStream (ts:|Node f nty xs) (cs:.OFirstLeft ()) (us:.TreeIxR _ ul utfe) (is:.TreeIxR frst il itfe)+    = map (\(TState s ii ee) ->+              let RiTirO l = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+                  p = case l of +                        E i  -> i +                        F cs -> parent frst VG.! VG.head cs+              in  TState s (ii:.:RiTirO (T p)) (ee:.f xs p) )+    . termStream ts cs us is+    . staticCheck ({- itfe < utfe && -} isOrdfull frst itfe)+  {-# Inline termStream #-}+++instance TermStaticVar (Node r x) (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxR frst i j) = TreeIxR frst i j+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++isOrdfull:: (Forest p v a) -> TFE -> Bool +isOrdfull frst (F cs)+  | Just c <- cs VG.!? 0+  , let p = parent frst VG.! c +  , p >= 0+  = children frst VG.! p == cs+isOrdfull frst (E i) = VG.null $ children frst VG.! i+isOrdfull _    _     = False+{-# Inline isOrdfull   #-}++++-- PermNode++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  , Show r+  ) => TermStream m (TermSymbol ts (PermNode r x)) s (is:.TreeIxR p v a O) where+  termStream (ts:|PermNode f xs) (cs:.OFirstLeft ()) (us:.TreeIxR _ ul utfe) (is:.TreeIxR frst il itfe)+    = map (\(TState s ii ee) ->+              let RiTirO l = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+                  p = case l of +                        E i  -> i +                        F cs -> parent frst VG.! VG.head cs+              in  TState s (ii:.:RiTirO (T p)) (ee:.f xs p) )+    . termStream ts cs us is+    . staticCheck ({- itfe < utfe && -} isPermfull frst itfe) --instead of isTree ask if it is a full ordered vector of its siblings including itself +  {-# Inline termStream #-}+++instance TermStaticVar (PermNode r x) (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxR frst i j) = TreeIxR frst i j+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++isPermfull:: (Forest p v a) -> TFE -> Bool +isPermfull frst (F cs)+  | Just c <- cs VG.!? 0+  , let p = parent frst VG.! c +  , p >= 0+  = VG.length (children frst VG.! p) == VG.length cs  -- cs is a subset of the other vector+isPermfull frst (E i) = VG.null $ children frst VG.! i+isPermfull _    _     = False+{-# Inline isPermfull #-}++++-- Epsilon+++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.TreeIxR p v a O) where+  termStream (ts:|Epsilon) (cs:.OStatic ()) (us:.TreeIxR _ ul utfe) (is:.TreeIxR frst il itfe)+    = map (\(TState s ii ee) ->+              let RiTirO ef = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+              in  TState s (ii:.:RiTirO ef) (ee:.()) )+    . termStream ts cs us is+    . staticCheck (case itfe of {F cs -> cs == roots frst; _ -> False}) +  {-# Inline termStream #-}+++instance TermStaticVar Epsilon (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++++-- |+--+-- das wird deletion+--+-- Inside+-- @+-- T   -> - F+-- i,? ->   i,?+++--Deletion+++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  ) => TermStream m (TermSymbol ts Deletion) s (is:.TreeIxR p v a O) where+  termStream (ts:|Deletion) (cs:._) (us:.u) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirO tfe = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+              in  {- traceShow ("-"::String,l,tf) $ -} TState s (ii:.:RiTirO tfe) (ee:.()) )+    . termStream ts cs us is+--    . staticCheck (ii == T)+  {-# Inline termStream #-}+++instance TermStaticVar Deletion (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a O) where+  mkStream S _ (TreeIxR frst ul utfe) (TreeIxR _ kl ktfe)+    = staticCheck ((getTFEIx ktfe) >=0 && (getTFEIx ktfe) <= (getTFEIx utfe)) . singleton . ElmS $ RiTirO ktfe+  {-# Inline mkStream #-}+++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a O) where+  mkStream S (vs:._) (lus:.TreeIxR frst ul utfe) (is:.TreeIxR _ kl ktfe)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirO ktfe)+    . staticCheck ((getTFEIx ktfe) >=0 && (getTFEIx ktfe) <= (getTFEIx utfe))+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++++++++++++-- OOE for E and T++data OOEFT x+  = OOE x !TFE+  | OOEF x [TFE]+  | OOF x !TFE+  | OOFinis+++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a O) cs c is (TreeIxR p v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a O) (cs:.c) (is:.TreeIxR p v a O) where+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:._) (ubs:._) (us:.TreeIxR frst ul utfe) (is:.TreeIxR _ jl jtfe)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirO ol = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  SvS s (tt:.TreeIxR frst ul ol) (ii:.:RiTirO ol) -- TODO should set right boundary+  addIndexDenseGo (cs:._) (vs:.ORightOf ()) (lbs:._) (ubs:._) (us:.TreeIxR frst ul utfe) (is:.TreeIxR _ jl jtfe)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk svS = return $ case jtfe of+                    E _ -> OOE svS jtfe+                    T _ -> OOE svS jtfe+                    F _ -> OOF svS jtfe+          step OOFinis = return Done+          step (OOE svS@(SvS s tt ii) (E i)) | i < (getTFEIx utfe) = +            return $ Yield (SvS s (tt:.TreeIxR frst jl (E i)) (ii:.:RiTirO (E i))) (OOE svS (T i))+          step (OOE svS@(SvS s tt ii) (T i)) | i < (getTFEIx utfe) = +            return $ Yield (SvS s (tt:.TreeIxR frst jl (T i)) (ii:.:RiTirO (T i))) (OOEF svS (genPerm frst i)) +          step (OOEF svS@(SvS s tt ii) []) = return Done+          step (OOEF svS@(SvS s tt ii) (F i:is)) = +            return $ Yield (SvS s (tt:.TreeIxR frst jl (F i)) (ii:.:RiTirO (F i))) (OOEF svS is) +          step (OOF svS@(SvS s tt ii) (F i)) = +            return $ Yield (SvS s (tt:.TreeIxR frst jl (F i)) (ii:.:RiTirO (E (getTFEIx utfe)))) OOFinis +          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++++genPerm frst i+  | let p = parent frst VG.! i+  , p >= 0+  , let cs = children frst VG.! p+  = L.map (F. VG.fromList) . L.map (i:) . L.concatMap permutations . subsequences . L.delete i $ VG.toList cs +genPerm _ _ = []+{-# Inline genPerm #-}+++++data OIEFT x+  = OIEE x !TFE+  | OIET x !TFE+  | OIEF x [TFE]+  | OIT x !TFE+  | OIFE x !TFE+  | OIFT x !(VU.Vector Int) [Int]+  | OIFinis+++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a O) where+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:._) (ubs:._) (us:.TreeIxR frst ul utfe) (is:.TreeIxR _ jl jtfe)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirO lo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  SvS s (tt:.TreeIxR frst jl lo) (ii:.:RiTirO lo) -- TODO should set right boundary+  addIndexDenseGo (cs:._) (vs:.OFirstLeft ()) (lbs:._) (ubs:._) (us:.TreeIxR frst ul utfe) (is:.TreeIxR _ jl jtfe)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk svS@(SvS s tt ii) =+            let RiTirO lo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  return $ case lo of+                  E _ -> OIEE svS lo+                  F _ -> OIFE svS lo+                  T _ -> OIT svS lo+          step OIFinis = return Done+          step (OIEE svS@(SvS s tt ii) (E i)) | i < (getTFEIx utfe) =+            return $ Yield (SvS s (tt:.TreeIxR frst jl (E i)) (ii:.:RiTirO (E i))) (OIET svS (E i))+          step (OIEE svS@(SvS s tt ii) (E i)) = return $ Skip (OIET svS (E i))+          step (OIET svS@(SvS s tt ii) (E i)) | Just l <- leftSibling (rightMostLeaf frst (getTFEIx utfe)) frst i =+            return $ Yield (SvS s (tt:.TreeIxR frst jl (T l)) (ii:.:RiTirO (T l))) +                           (OIEF svS $ if i == (getTFEIx utfe) then (L.map F $ sortedSubForests frst) else [])+          step (OIET svS@(SvS s tt ii) (E i)) = return Done+          step (OIEF svS@(SvS s tt ii) []) = return Done+          step (OIEF svS@(SvS s tt ii) (x:xs)) =+            return $ Yield (SvS s (tt:.TreeIxR frst jl x) (ii:.:RiTirO x)) (OIEF svS xs) +          step (OIT svS@(SvS s tt ii) (T i)) =+            return $ Yield (SvS s (tt:.TreeIxR frst jl (E i)) (ii:.:RiTirO (T i))) OIFinis+          step (OIFE svS@(SvS s tt ii) (F i)) =+            return $ Yield (SvS s (tt:.TreeIxR frst jl (E $ VG.head i)) (ii:.:RiTirO (F i))) (OIFT svS i $ genTrees frst i) +          step (OIFT svS@(SvS s tt ii) ss []) = return Done+          step (OIFT svS@(SvS s tt ii) ss (x:xs)) =+            return $ Yield (SvS s (tt:.TreeIxR frst jl (T x)) (ii:.:RiTirO (F $ x `VG.cons` ss))) (OIFT svS ss xs) +          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++++genTrees frst is = rs+  where +    i = VG.head is+    p = parent frst VG.! i+    cs = if p >= 0 then children frst VG.! p else roots frst+    rs = VG.toList $ VG.filter (`VG.notElem` is) cs+{-# Inline genTrees #-}+++leftSibling d frst k +  | k >= VG.length (children frst)  = Just d+  | Just l <- lsib frst VG.!? k = Just l+  | otherwise = Nothing+{-# Inline leftSibling #-}++++++-- * Complemented instances++-- | Outside running index structure requires two local index structures.+-- One is for the inside symbols, one for the outside symbol.++data instance RunningIndex (TreeIxR p v a C) = RiTirC !TFE++-- | Outside works in the opposite direction.+--++instance IndexStream z => IndexStream (z:.TreeIxR p v a C) where+  streamUp   (ls:.TreeIxR p llk lf) (hs:.TreeIxR _ _ ht) = flatten (streamUpMk p lf ht) (streamUpStep   p llk lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxR p llk lf) (hs:.TreeIxR _ _ ht) = flatten (streamDownMk p lf ht) (streamDownStep p llk lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxR p v a C) where+  type Context (TreeIxR p v a C) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a C) where+  mkStream S _ (TreeIxR frst lk uu) (TreeIxR _ _ kt)+    = staticCheck (let k = getTFEIx kt;u = getTFEIx uu in k >=0 && k<= u) . singleton . ElmS $ RiTirC kt+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a C) where+  mkStream S (vs:._) (lus:.TreeIxR frst lk uu) (is:.TreeIxR _ _ kt)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirC kt)+    . staticCheck (let k = getTFEIx kt;u = getTFEIx uu in k >=0 && k<= u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:.TreeIxR frst lk v) (is:.TreeIxR _ _ j)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirC tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a C))+            in  SvS s (tt:.TreeIxR frst lk tf) (ii:.:RiTirC tf)+  {-# Inline addIndexDenseGo #-}++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a O) cs c is (TreeIxR p v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a O) (cs:.c) (is:.TreeIxR p v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:.TreeIxR frst lk v) (is:.TreeIxR _ _ j)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirC tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a C))+            in  SvS s (tt:.TreeIxR frst lk tf) (ii:.:RiTirC tf)+  {-# Inline addIndexDenseGo #-}+++++++{-+-- * Outside instances++-- | Outside running index structure requires two local index structures.+-- One is for the inside symbols, one for the outside symbol.++data instance RunningIndex (TreeIxR p v a O) = RiTirO !Int !TF !Int !TF -- I, I, O, O++-- | Outside works in the opposite direction.+--+-- TODO check if the original @Up@ / @Down@ combination is ok.++instance IndexStream z => IndexStream (z:.TreeIxR p v a O) where+  streamUp   (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamDownMk lf ht) (streamDownStep p lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamUpMk   lf ht) (streamUpStep   p lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxR p v a O) where+  type Context (TreeIxR p v a O) = OutsideContext ()+  initialContext _ = OStatic ()+  {-# Inline initialContext #-}++++-- Node++-- | We are a @F@orest at position @i@. Now we request the parent, who+-- happens to be the root of a @T@ree.+--+-- TODO we should actually move the outside index via the @OFirstLeft@+-- (etc) encoding+--+-- X    -> n    Y+-- i,T  -> i,T  i+1,t     -- @t@ = if @i@ has no children, then @E@, else @F@.+--+-- Y'     ->  n       X'+-- i+1,t      i,T     i,T   -- @t@ = if @i@ ...+--+-- Y'     ->  n       X'+-- i,t        i-1,T   i-1,T -- @t@ = if @i-1@ has no children, then @E@ else @F@++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  , Show r+  ) => TermStream m (TermSymbol ts (Node r x)) s (is:.TreeIxR p v a O) where+  termStream (ts:|Node f xs) (cs:.OFirstLeft ()) (us:.TreeIxR _ u ut) (is:.TreeIxR frst i it)+    = map (\(TState s ii ee) ->+              let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+                  l' = li - 1+              in  TState s (ii:.:RiTirO li T l' T) (ee:.f xs l') ) -- @li@, since we have now just 'eaten' @li -1 , li@+    . termStream ts cs us is+    -- @i>0@ so that we can actually have a parent+    -- @it==E@ in case we @i-1@ has no children; @it==F@ in case @i-1@ has+    -- children.+    . staticCheck (let hc = not $ VG.null (children frst VG.! (i-1))+                   in  i>0 && (not hc && it==E || hc && it==F))+  {-# Inline termStream #-}++instance TermStaticVar (Node r x) (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxR frst i j) = TreeIxR frst i j+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- | Epsilon++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.TreeIxR p v a O) where+  termStream (ts:|Epsilon) (cs:.OStatic ()) (us:.TreeIxR _ u uu) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+              in  TState s (ii:.:RiTirO li tfi lo tfo) (ee:.()) )+    . termStream ts cs us is+    . staticCheck ((i==0 && ii==F) || (i==0 && u==0 && ii==E))+  {-# Inline termStream #-}+++instance TermStaticVar Epsilon (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- | Deletion.+--+-- Has no conditions on when it is acceptable.++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  ) => TermStream m (TermSymbol ts Deletion) s (is:.TreeIxR p v a O) where+  termStream (ts:|Deletion) (cs:._) (us:.u) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+              in  TState s (ii:.:RiTirO li tfi lo tfo) (ee:.()) )+    . termStream ts cs us is+  {-# Inline termStream #-}+++instance TermStaticVar Deletion (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a O) where+  mkStream S _ (TreeIxR frst u ut) (TreeIxR _ k kt)+    = staticCheck (k>=0 && k<=u) . singleton . ElmS $ RiTirO k kt k kt+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a O) where+  mkStream S (vs:._) (lus:.TreeIxR frst u ut) (is:.TreeIxR _ k kt)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirO k kt k kt)+    . staticCheck (k>=0 && k<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++-- For both, I / O and O / O systems, we need to consider a large number of+-- cases. The general rule @X -> Y Z@ with all variants follows below.+--+--+-- @+--+-- X    ->  Y     Z+-- i,E      i,E   i,E+--+-- Y^   ->  X^    Z+-- i,E      i,E   i,E+--+-- Z^   ->  Y     X^+-- i,E      i,E   i,E+--+--+--+-- X    ->  Y     Z       we do not split off the first tree; down is empty+-- i,F      i,E   i,F+--+-- Y^   ->  X^    Z+-- i,E      i,F   i,F+--+-- Z^   ->  Y     X^+-- i,F      i,E   i,F+--+--+-- X    ->  Y     Z+-- i,F      i,T   k,t     if k==u then E else F ; 1st tree split off+--          i~k+--+-- Y^   ->  X^    Z+-- i,T      i,F   k,t     if k==u then E else F+-- i~k+--+-- Z^   ->  Y     X^+-- u,E      i,T   i,F     ∀ i ;; for all trees [i,u) !+--          i~u+--+-- Z^   ->  Y     X^+-- k,F      i,T   i,F     i is left sibling of k+--          i~k+--+--+-- X    ->  Y     Z       move complete forest down+-- i,F      i,F   u,E+--+-- Y^   ->  X^    Z+-- i,F      i,F   u,E+--+-- Z^   ->  Y     X^      ∀ i ;; for u,E collect all possible splits.+-- u,E      i,F   i,F+--+--+--+-- X    ->  Y     Z       do not hand i,T down+-- i,T      i,E   i,T+--+-- Y^   ->  X^    Z+-- i,E      i,T   i,T+--+-- Z^   ->  Y     X^+-- i,T      i,E   i,T+--+--+--+-- X    ->  Y     Z       further hand down+-- i,T      i,T   k,E+--          i_k+--+-- Y^   ->  X^    Z+-- i,T      i,T   k,E+-- i_k+--+-- Z^   ->  Y     X^+-- k,E      i,T   i,T+--          i_k+--+--+-- @++data OIEFT x+  = OIEFF x Int -- svS , forests starting at @i@+  | OIETT x Int -- svS , parent index for trees with right boundary @j@+  | OIETF x Int -- svS , parent index for trees with right boundary @u@+  | OIEEE x     -- svS+  | OIFEF x     -- svS+  | OIFTF x     -- svS+  | OITET x     -- svS+  | OIFinis++-- | The different cases for @O@ context with @O@ tables.++data OOEFT x -- = OOE TF x | OOF x | OOT TF x | OOFinis+  = OOE x TF  -- svS , all variants of T F E+  | OOFFE x   -- svS+  | OOTF  x   -- svS+  | OOTT  x   -- svS+  | OOFinis++-- In principle, we are missing an extra boolean case on @j==u@ or @j==l,+-- l/=u@ for tree-symbols, i.e. those that bind terminals. However, in+-- these linear languages, there can be only one such symbol per rule. This+-- in turn means they are never in outside mode on the r.h.s. and hence we+-- have no ambiguity problems.++-- synVar: @Table I@ with @Index O@ We only have two options: @X' -> Y' Z@+-- with @Z@ being in @OStatic@ position or @X' -> Y Z'@ with @Y@ being in+-- @OFirstLeft@ position.+--+-- @+--+-- Z^   ->  Y     X^      ∀ i ;; for u,E collect all possible splits.+-- u,E      i,F   i,F     this is move complete forest down / inside+--+-- Z^   ->  Y     X^      further hand down+-- k,E      i,T   i,T+--          i_k+--+-- Z^   ->  Y     X^+-- u,E      i,T   i,F     ∀ i ;; for all trees [i,u) !+--          i~u+--+-- Z^   ->  Y     X^+-- i,E      i,E   i,E+--+--+--+-- Z^   ->  Y     X^       we do not split off the first tree; down is empty+-- i,F      i,E   i,F+--+-- Z^   ->  Y     X^+-- k,F      i,T   i,F     ∀ i ;; for all trees [i,k) k/=u !+--          i~k+--+--+--+-- Z^   ->  Y     X^      do not hand i,T down+-- i,T      i,E   i,T+--+-- @++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a O) where+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (us:.TreeIxR frst u v) (is:.TreeIxR _ j jj)+    = map go .addIndexDenseGo cs vs us is+    where go (SvS s tt ii) =+            let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  SvS s (tt:.TreeIxR frst li tfi) (ii:.:RiTirO j E lo tfo) -- TODO should set right boundary+  addIndexDenseGo (cs:._) (vs:.OFirstLeft ()) (us:.TreeIxR frst u v) (is:.TreeIxR _ j jj)+    = flatten mk step . addIndexDenseGo cs vs us is+    where mk svS@(SvS s tt ii) =+            let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  return $ case jj of+                  E -> OIEFF svS 0+                  F -> OIFEF svS+                  T -> OITET svS+          step OIFinis = return Done+          -- Z^   ->  Y     X^      ∀ i ;; for u,E collect all possible splits.+          -- u,E      i,F   i,F     this is move complete forest down / inside+          step (OIEFF svS@(SvS s tt ii) k) | j==u && k<u+            = return $ Yield (SvS s (tt:.TreeIxR frst k F) (ii:.:RiTirO u E k F)) (OIEFF svS (k+1))+          step (OIEFF svS _)+            = let pj = maybe (-1) id $ F.lsib frst VG.!? j+              in  return $ Skip $ OIETT svS pj+          -- Z^   ->  Y     X^      further hand down+          -- k,E      i,T   i,T+          --          i_k+          step (OIETT svS@(SvS s tt ii) pj) | j<u && pj>=0+            = let pj' = pardef frst pj+                  tr  = if j==u then E else F+              in  return $ Yield (SvS s (tt:.TreeIxR frst pj T) (ii:.:RiTirO j tr pj T)) (OIETT svS pj')+          step (OIETT svS _)+            = let pu = pardef frst $ u - 1+              in  return $ Skip $ OIETF svS pu+          -- Z^   ->  Y     X^+          -- u,E      i,T   i,F     ∀ i ;; for all trees [i,u) !+          --          i~u+          step (OIETF svS@(SvS s tt ii) pu) | j==u && pu>=0+            = let pu' = pardef frst pu+              in  return $ Yield (SvS s (tt:.TreeIxR frst pu T) (ii:.:RiTirO u E pu F)) (OIETF svS pu')+          step (OIETF svS _)+            = return $ Skip $ OIEEE svS+          -- Z^   ->  Y     X^+          -- i,E      i,E   i,E+          step (OIEEE svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j E) (ii:.:RiTirO j E j E)) OIFinis+          -- Z^   ->  Y     X^       we do not split off the first tree; down is empty+          -- i,F      i,E   i,F+          step (OIFEF svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j E) (ii:.:RiTirO j E j F)) (OIFTF svS)+          -- Z^   ->  Y     X^+          -- k,F      i,T   i,F     i is left sibling of k+          --          i~k+          step (OIFTF svS@(SvS s tt ii)) | Just ls <- F.lsib frst VG.!? j, ls >= 0+            = return $ Yield (SvS s (tt:.TreeIxR frst ls T) (ii:.:RiTirO j F ls F)) OIFinis+          step (OIFTF _) = return $ Skip $ OIFinis+          -- Z^   ->  Y     X^      do not hand i,T down+          -- i,T      i,E   i,T+          step (OITET svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j E) (ii:.:RiTirO j E j T)) OIFinis+          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++--synVar: @Table O@   with @Index O@+--+-- @+--+-- Y^   ->  X^    Z+-- i,E      i,E   i,E+--+-- Y^   ->  X^    Z       we do not split off the first tree; down is empty+-- i,E      i,F   i,F+--+-- Y^   ->  X^    Z       do not hand i,T down+-- i,E      i,T   i,T+--+--+--+-- Y^   ->  X^    Z+-- i,T      i,F   k,t     if k==u then E else F ; 1st tree split off+-- i_k+--+-- Y^   ->  X^    Z       further hand down ; k,E because @T@+-- i,T      i,T   k,E+-- i_k+--+--+--+-- Y^   ->  X^    Z       move complete forest down+-- i,F      i,F   u,E+--+-- @++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a O) cs c is (TreeIxR p v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a O) (cs:.c) (is:.TreeIxR p v a O) where+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (us:.TreeIxR frst u v) (is:.TreeIxR _ j _)+    = map go .addIndexDenseGo cs vs us is+    where go (SvS s tt ii) =+            let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  SvS s (tt:.TreeIxR frst lo tfo) (ii:.:RiTirO li tfi j E) -- TODO should set right boundary+  addIndexDenseGo (cs:._) (vs:.ORightOf ()) (us:.TreeIxR frst u v) (is:.TreeIxR _ j jj)+    = flatten mk step . addIndexDenseGo cs vs us is+    where mk svS = return $ case jj of+                    E -> OOE   svS minBound+                    F -> OOFFE svS+                    T -> OOTF  svS+          -- done+          step OOFinis = return Done+          -- Y^   ->  X^    Z+          -- i,E      i,E   i,E+          --+          -- Y^   ->  X^    Z       we do not split off the first tree; down is empty+          -- i,E      i,F   i,F+          --+          -- Y^   ->  X^    Z       do not hand i,T down+          -- i,E      i,T   i,T+          step (OOE svS@(SvS s tt ii) tf) | tf < maxBound+            = return $ Yield (SvS s (tt:.TreeIxR frst j tf) (ii:.:RiTirO j tf j E)) (OOE svS (succ tf))+          step (OOE svS@(SvS s tt ii) tf) | tf == maxBound+            = return $ Yield (SvS s (tt:.TreeIxR frst j tf) (ii:.:RiTirO j tf j E)) OOFinis+          -- Y^   ->  X^    Z       move complete forest down+          -- i,F      i,F   u,E+          step (OOFFE svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j F) (ii:.:RiTirO u E j E)) OOFinis+          -- Y^   ->  X^    Z+          -- i,T      i,F   k,t     if k==u then E else F ; 1st tree split off+          -- i_k+          step (OOTF svS@(SvS s tt ii))+            = let k = rbdef u frst j+                  tf = if k==u then E else F+              in  return $ Yield (SvS s (tt:.TreeIxR frst j F) (ii:.:RiTirO k tf j E)) (OOTT svS)+          -- Y^   ->  X^    Z       further hand down ; k,E because @T@+          -- i,T      i,T   k,E+          -- i_k+          step (OOTT svS@(SvS s tt ii))+            = let k = rbdef u frst j+              in  return $ Yield (SvS s (tt:.TreeIxR frst j T) (ii:.:RiTirO k E j E)) OOFinis+          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++instance (MinSize c) => TableStaticVar (u I) c (TreeIxR p v a O) where +  tableStaticVar _ _ (OStatic    d) _ = ORightOf d+  tableStaticVar _ _ (ORightOf   d) _ = ORightOf d+  tableStaticVar _ _ (OFirstLeft d) _ = OLeftOf  d+  tableStaticVar _ _ (OLeftOf    d) _ = OLeftOf  d+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++instance (MinSize c) => TableStaticVar (u O) c (TreeIxR p v a O) where +  tableStaticVar _ _ (OStatic  d) _ = OFirstLeft d+  tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++++++-- * Complemented instances++-- | Outside running index structure requires two local index structures.+-- One is for the inside symbols, one for the outside symbol.++data instance RunningIndex (TreeIxR p v a C) = RiTirC !Int !TF++-- | Outside works in the opposite direction.+--+-- TODO check if the original @Up@ / @Down@ combination is ok.++instance IndexStream z => IndexStream (z:.TreeIxR p v a C) where+  streamUp   (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamUpMk   lf ht) (streamUpStep   p lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamDownMk lf ht) (streamDownStep p lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxR p v a C) where+  type Context (TreeIxR p v a C) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a C) where+  mkStream S _ (TreeIxR frst u ut) (TreeIxR _ k kt)+    = staticCheck (k>=0 && k<=u) . singleton . ElmS $ RiTirC k kt+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a C) where+  mkStream S (vs:._) (lus:.TreeIxR frst u ut) (is:.TreeIxR _ k kt)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirC k kt)+    . staticCheck (k>=0 && k<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (us:.TreeIxR frst u v) (is:.TreeIxR _ j _)+    = map go .addIndexDenseGo cs vs us is+    where go (SvS s tt ii) =+            let RiTirC k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a C))+            in  SvS s (tt:.TreeIxR frst k tf) (ii:.:RiTirC k tf)++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a O) cs c is (TreeIxR p v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a O) (cs:.c) (is:.TreeIxR p v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (us:.TreeIxR frst u v) (is:.TreeIxR _ j _)+    = map go .addIndexDenseGo cs vs us is+    where go (SvS s tt ii) =+            let RiTirC k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a C))+            in  SvS s (tt:.TreeIxR frst k tf) (ii:.:RiTirC k tf)++-}+
+ ADP/Fusion/Core/ForestAlign/RightLinear.hs view
@@ -0,0 +1,220 @@++-- | Data structures and instances to combine efficient 'Forest' structures+-- with @ADPfusion@.++module ADP.Fusion.Core.ForestAlign.RightLinear where++import           Control.Exception (assert)+import           Data.Either (either)+import           Data.Graph.Inductive.Basic+import           Data.Strict.Tuple hiding (fst, snd)+import           Data.Traversable (mapAccumL)+import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Debug.Trace+import           Prelude hiding (map)+import qualified Data.Forest.Static as F+import qualified Data.Tree as T+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Unboxed as VU++import           ADP.Fusion.Core+import           Data.Forest.Static+import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Term.Node.Type++++data TreeIxR p v a t = TreeIxR !(Forest p v a) !Int !TF++instance Show (TreeIxR p v a t) where+  show (TreeIxR _ i j) = show (i,j)++minIx, maxIx :: Forest p v a -> TreeIxR p v a t+minIx f = TreeIxR f 0 minBound++maxIx f = TreeIxR f (VU.length (parent f)) maxBound+{-# Inline minIx #-}+{-# Inline maxIx #-}++data TF = F | T | E+  deriving (Show,Eq,Ord,Enum,Bounded)++instance Index TF where+  linearIndex _ _ tf = fromEnum tf+  {-# Inline linearIndex #-}+  smallestLinearIndex _ = fromEnum (minBound :: TF)+  {-# Inline smallestLinearIndex #-}+  largestLinearIndex _ = fromEnum (maxBound :: TF)+  {-# Inline largestLinearIndex #-}+  size _ _ = fromEnum (maxBound :: TF) + 1+  {-# Inline size #-}+  inBounds _ u k = k <= u+  {-# Inline inBounds #-}+++data instance RunningIndex (TreeIxR p v a I) = RiTirI !Int !TF++instance Index (TreeIxR p v a t) where+  -- | trees @T@ are stored in the first line, i.e. @+0@, forests @F@ (with+  -- @j==u@ are stored in the second line, i.e. @+u+1@ to each index.+  linearIndex (TreeIxR _ l ll) (TreeIxR _ u uu) (TreeIxR _ k tf)+    = (fromEnum (maxBound :: TF) + 1) * k + fromEnum tf+  {-# Inline linearIndex #-}+  smallestLinearIndex _ = error "still needed?"+  {-# Inline smallestLinearIndex #-}+  largestLinearIndex (TreeIxR p u ut) = (fromEnum (maxBound :: TF) + 1) * u + fromEnum (maxBound :: TF)+  {-# Inline largestLinearIndex #-}+  size (TreeIxR _ l ll) (TreeIxR _ u uu) = (fromEnum (maxBound :: TF) + 1) * (u+1)+  {-# Inline size #-}+  inBounds (TreeIxR _ l _) (TreeIxR _ u _) (TreeIxR _ k _) = l <= k && k <= u+  {-# Inline inBounds #-}+++instance IndexStream z => IndexStream (z:.TreeIxR p v a I) where+  streamUp   (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamUpMk   lf ht) (streamUpStep   p lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamDownMk lf ht) (streamDownStep p lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++streamUpMk lf ht z = return (z,ht,maxBound :: TF)+{-# Inline [0] streamUpMk #-}++streamUpStep p lf ht (z,k,tf)+  | k < lf         = return $ SM.Done+  | tf == minBound = return $ SM.Yield (z:.TreeIxR p k tf) (z,k-1,maxBound)+  | otherwise      = return $ SM.Yield (z:.TreeIxR p k tf) (z,k,pred tf)+{-# Inline [0] streamUpStep #-}++streamDownMk lf ht z = return (z,lf,minBound :: TF)+{-# Inline [0] streamDownMk #-}++streamDownStep p lf ht (z,k,tf)+  | k > ht         = return $ SM.Done+  | tf == maxBound = return $ SM.Yield (z:.TreeIxR p k tf) (z,k+1,minBound)+  | otherwise      = return $ SM.Yield (z:.TreeIxR p k tf) (z,k,succ tf)+{-# Inline [0] streamDownStep #-}+++instance IndexStream (Z:.TreeIxR p v a t) => IndexStream (TreeIxR p v a t)++instance RuleContext (TreeIxR p v a I) where+  type Context (TreeIxR p v a I) = InsideContext ()+  initialContext _ = IStatic ()+  {-# Inline initialContext #-}++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a I) where+  mkStream S _ (TreeIxR frst u ut) (TreeIxR _ k kt)+    = staticCheck (k>=0 && k<=u) . singleton . ElmS $ RiTirI k kt+  {-# Inline mkStream #-}+++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a I) where+  mkStream S (vs:._) (lus:.TreeIxR frst u ut) (is:.TreeIxR _ k kt)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirI k kt)+    . staticCheck (k>=0 && k<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++++-- * Outside instances++-- | Outside running index structure requires two local index structures.+-- One is for the inside symbols, one for the outside symbol.++data instance RunningIndex (TreeIxR p v a O) = RiTirO !Int !TF !Int !TF -- I, I, O, O++-- | Outside works in the opposite direction.+--+-- TODO check if the original @Up@ / @Down@ combination is ok.++instance IndexStream z => IndexStream (z:.TreeIxR p v a O) where+  streamUp   (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamDownMk lf ht) (streamDownStep p lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamUpMk   lf ht) (streamUpStep   p lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxR p v a O) where+  type Context (TreeIxR p v a O) = OutsideContext ()+  initialContext _ = OStatic ()+  {-# Inline initialContext #-}++++++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a O) where+  mkStream S _ (TreeIxR frst u ut) (TreeIxR _ k kt)+    = staticCheck (k>=0 && k<=u) . singleton . ElmS $ RiTirO k kt k kt+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a O) where+  mkStream S (vs:._) (lus:.TreeIxR frst u ut) (is:.TreeIxR _ k kt)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirO k kt k kt)+    . staticCheck (k>=0 && k<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}+++++-- * Complemented instances++-- | Outside running index structure requires two local index structures.+-- One is for the inside symbols, one for the outside symbol.++data instance RunningIndex (TreeIxR p v a C) = RiTirC !Int !TF++-- | Outside works in the opposite direction.+--+-- TODO check if the original @Up@ / @Down@ combination is ok.++instance IndexStream z => IndexStream (z:.TreeIxR p v a C) where+  streamUp   (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamUpMk   lf ht) (streamUpStep   p lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxR p lf _) (hs:.TreeIxR _ ht _) = flatten (streamDownMk lf ht) (streamDownStep p lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxR p v a C) where+  type Context (TreeIxR p v a C) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxR p v a C) where+  mkStream S _ (TreeIxR frst u ut) (TreeIxR _ k kt)+    = staticCheck (k>=0 && k<=u) . singleton . ElmS $ RiTirC k kt+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxR p v a C) where+  mkStream S (vs:._) (lus:.TreeIxR frst u ut) (is:.TreeIxR _ k kt)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTirC k kt)+    . staticCheck (k>=0 && k<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}+++
+ ADP/Fusion/Core/ForestEdit/LeftLinear.hs view
@@ -0,0 +1,243 @@++module ADP.Fusion.Core.ForestEdit.LeftLinear where++import           Data.Either (either)+import           Data.Graph.Inductive.Basic+import           Data.Strict.Tuple hiding (fst, snd)+import           Data.Traversable (mapAccumL)+import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Debug.Trace+import           Prelude hiding (map)+import qualified Data.Forest.Static as F+import qualified Data.Tree as T+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Unboxed as VU++import           ADP.Fusion.Core+import           Data.Forest.Static+import           Data.PrimitiveArray hiding (map)+import           Math.TriangularNumbers++import           ADP.Fusion.Term.Node.Type++++-- | Index for editing purposes into a post-order tree structure+--+-- @+--      6+--    /   \+--   2     5+--  / \   / \+-- 0  1  3   4+-- @+--+-- Cf the tree rooted at @5@. Its bounded by @[3,6)@+--+-- The index @[0,7]@ includes the lower bound, but excludes the bound.+-- Hence, this is the tree from the leaf @0@ to the local root @6@. It+-- implicitly goes down to the leaf @4@ as well.+--+-- The index @[0.6]@ on the other hand describes a forest. This forest+-- contains two full local trees, rooted at @2@ and @5@ respectively.+--+-- We index the left-most lower-most leaf, and the right-most, top-most+-- root (actually the index is the first excluded element, hence @[0,6)@+-- instead of @[0,5]@.+--+-- TODO need to fix @p ~ PostOrder@++data TreeIxL p v a t+  = TreeIxL+      !(Forest p v a)   -- ^ the actual forest we operate on+      !(VU.Vector Int)  -- ^ given a node, gives the index of the left-most leaf of the node+      !Int              -- ^ left-most, lower-most index+      !Int              -- ^ right-most, top-most index++instance Show (TreeIxL p v a t) where+  show (TreeIxL _ _ i j) = show (i,j)++minIx, maxIx :: Forest p v a -> TreeIxL p v a t+minIx f = TreeIxL f (leftMostLeaves f) 0 (VU.length (parent f))++maxIx f = TreeIxL f (leftMostLeaves f) 0 (VU.length (parent f))+{-# Inline minIx #-}+{-# Inline maxIx #-}++instance Index (TreeIxL p v a t) where+  -- | trees @T@ are stored in the first line, i.e. @+0@, forests @F@ (with+  -- @j==u@ are stored in the second line, i.e. @+u+1@ to each index.+  linearIndex _ (TreeIxL _ _ l u) (TreeIxL _ _ i j)+    = linearIndex (subword 0 0) (subword l u) (subword i j)+  {-# Inline linearIndex #-}+  smallestLinearIndex _ = error "still needed?"+  {-# Inline smallestLinearIndex #-}+  largestLinearIndex (TreeIxL _ _ _ u) = (triangularNumber $ u-0+1) - 1+  {-# Inline largestLinearIndex #-}+  size _ (TreeIxL _ _ _ u) = triangularNumber $ u-0+1+  {-# Inline size #-}+  inBounds _ (TreeIxL _ _ _ u) (TreeIxL _ _ i j) = 0 <= i && i <= j && j <= u+  {-# Inline inBounds #-}++streamUpMk l h z = return (z,0,0)  -- start with size 0 and smallest element 0+{-# Inline [0] streamUpMk #-}++-- 0,0 1,1 2,2 ...+-- 0,1 1,2 2,3 ...+-- 0,2 1,3 2,4 ...++streamUpStep p c lf ht (z,s,i)  -- s=size, i=left border+  | s > VG.length c     = return $ SM.Done+  | i + s > VG.length c = return $ SM.Skip (z,s+1,0)+  | otherwise = return $ SM.Yield (z:.TreeIxL p c i (i+s)) (z,s,i+1)+{-# Inline [0] streamUpStep #-}++streamDownMk lf ht z = return (z,ht,0)+{-# Inline [0] streamDownMk #-}++streamDownStep p c lf ht (z,s,i)+  | s < 0     = return $ SM.Done+  | i < 0     = return $ SM.Skip (z,s-1,ht-(s-1))+  | otherwise = return $ SM.Yield (z:.TreeIxL p c i (i+s)) (z,s,i-1)+{-# Inline [0] streamDownStep #-}++instance IndexStream (Z:.TreeIxL p v a t) => IndexStream (TreeIxL p v a t)++++-- * Inside++++data instance RunningIndex (TreeIxL p v a I) = RiTilI !Int !Int++instance IndexStream z => IndexStream (z:.TreeIxL p v a I) where+  streamUp   (ls:.TreeIxL p c lf _) (hs:.TreeIxL _ _ _ ht) = flatten (streamUpMk lf  ht) (streamUpStep  p c lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxL p c lf _) (hs:.TreeIxL _ _ _ ht) = flatten (streamDownMk lf ht) (streamDownStep p c lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxL p v a I) where+  type Context (TreeIxL p v a I) = InsideContext ()+  initialContext _ = IStatic ()+  {-# Inline initialContext #-}++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxL p v a I) where+  mkStream S (IStatic ()) (TreeIxL frst _ l u) (TreeIxL _ _ i j)+    = staticCheck (i>=0 && i==j && j<=u) . singleton . ElmS $ RiTilI i i+  mkStream S (IVariable ()) (TreeIxL frst _ l u) (TreeIxL _ _ i j)+    = staticCheck (i>=0 && i<=j && j<=u) . singleton . ElmS $ RiTilI i i+  {-# Inline mkStream #-}+++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxL p v a I) where+  mkStream S (vs:.IStatic()) (lus:.TreeIxL frst _ l u) (is:.TreeIxL _ _ i j)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTilI i i)+    . staticCheck (i>=0 && i==j && j<=u)+    $ mkStream S vs lus is+  mkStream S (vs:.IVariable()) (lus:.TreeIxL frst _ l u) (is:.TreeIxL _ _ i j)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTilI i i)+    . staticCheck (i>=0 && i<=j && j<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}++++-- * Outside++++-- | Running index structure for outside tree-edit algorithms. We+-- explicitly name the indices, to be more sure inside and outside+-- are correctly assigned to.++data instance RunningIndex (TreeIxL p v a O) = RiTilO { iLeft, iRight, oLeft, oRight :: !Int }++instance IndexStream z => IndexStream (z:.TreeIxL Post v a O) where+  streamUp   (ls:.TreeIxL p c lf _) (hs:.TreeIxL _ _ _ ht) = flatten (streamDownMk lf ht) (streamDownStep p c lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxL p c lf _) (hs:.TreeIxL _ _ _ ht) = flatten (streamUpMk   lf ht) (streamUpStep   p c lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxL Post v a O) where+  type Context (TreeIxL Post v a O) = OutsideContext ()+  initialContext _ = OStatic ()+  {-# Inline initialContext #-}++instance (Monad m) => MkStream m S (TreeIxL Post v a O) where+  mkStream S (OStatic ()) (TreeIxL frst _ l u) (TreeIxL _ _ i j)+    = staticCheck (i==0 && j==u) . singleton . ElmS $ RiTilO i j i j+  mkStream S (ORightOf ()) (TreeIxL frst _ l u) (TreeIxL _ _ i j)+    = error $ "mkStream S / ORightOf should not be happening!"+  mkStream S (OFirstLeft ()) (TreeIxL frst _ l u) (TreeIxL _ _ i j)+    = staticCheck True . singleton . ElmS $ RiTilO i i i j -- TODO ???+  mkStream S (OLeftOf ()) (TreeIxL frst _ l u) (TreeIxL _ _ i j)+    = staticCheck True . singleton . ElmS $ RiTilO 0 i 0 j+  {-# Inline mkStream #-}++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxL Post v a O) where+  mkStream S (vs:.OStatic ()) (us:.TreeIxL frst _ l u) (is:.TreeIxL _ _ i j)+    = map (\(ElmS zi) -> ElmS $ zi:.:RiTilO i j i j)+    . staticCheck (i==0 && j==u)+    $ mkStream S vs us is+  mkStream S (vs:.ORightOf ()) (us:.TreeIxL frst _ l u) (is:.TreeIxL _ _ i j)+    = error $ "mkStream S / ORightOf should not be happening!"+  mkStream S (vs:.OFirstLeft ()) (us:.TreeIxL frst _ l u) (is:.TreeIxL _ _ i j)+    = map (\(ElmS zi) -> ElmS $ zi:.:RiTilO i i i j)+    . staticCheck True+    $ mkStream S vs us is+  mkStream S (vs:.OLeftOf ()) (us:.TreeIxL frst _ l u) (is:.TreeIxL _ _ i j)+    = map (\(ElmS zi) -> ElmS $ zi:.:RiTilO 0 i 0 j)+    . staticCheck True+    $ mkStream S vs us is+  {-# Inline mkStream #-}++++-- * Complement++data instance RunningIndex (TreeIxL p v a C) = RiTilC !Int !Int++instance IndexStream z => IndexStream (z:.TreeIxL p v a C) where+  streamUp   (ls:.TreeIxL p c lf _) (hs:.TreeIxL _ _ _ ht) = flatten (streamUpMk lf  ht) (streamUpStep  p c lf ht) $ streamUp ls hs+  streamDown (ls:.TreeIxL p c lf _) (hs:.TreeIxL _ _ _ ht) = flatten (streamDownMk lf ht) (streamDownStep p c lf ht) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance RuleContext (TreeIxL p v a C) where+  type Context (TreeIxL p v a C) = ComplementContext+  initialContext _ = Complemented+  {-# Inline initialContext #-}++++-- Invisible starting symbol++instance (Monad m) => MkStream m S (TreeIxL p v a C) where+  mkStream S Complemented (TreeIxL frst _ l u) (TreeIxL _ _ i j)+    = staticCheck (i>=0 && i==j && j<=u) . singleton . ElmS $ RiTilC i j+  {-# Inline mkStream #-}+++instance+  ( Monad m+  , MkStream m S is+  ) => MkStream m S (is:.TreeIxL p v a C) where+  mkStream S (vs:.Complemented) (lus:.TreeIxL frst _ l u) (is:.TreeIxL _ _ i j)+    = map (\(ElmS zi) -> ElmS $ zi :.: RiTilC i j)+    . staticCheck (i>=0 && i==j && j<=u)+    $ mkStream S vs lus is+  {-# INLINE mkStream #-}+
+ ADP/Fusion/Forest/Align/PRL.hs view
@@ -0,0 +1,13 @@++module ADP.Fusion.Forest.Align.PRL+  ( module ADP.Fusion.Core+  , module ADP.Fusion.Core.ForestAlign.PermuteRightLinear+  , module ADP.Fusion.Term.Node.ForestAlign.RightLinear+  , module ADP.Fusion.Term.Node.Type+  ) where++import ADP.Fusion.Core+import ADP.Fusion.Core.ForestAlign.PermuteRightLinear+import ADP.Fusion.Term.Node.ForestAlign.RightLinear+import ADP.Fusion.Term.Node.Type+
+ ADP/Fusion/Forest/Align/RL.hs view
@@ -0,0 +1,19 @@++module ADP.Fusion.Forest.Align.RL+  ( module ADP.Fusion.Core+  , module ADP.Fusion.Core.ForestAlign.RightLinear+  , module ADP.Fusion.SynVar.Indices.ForestAlign.RightLinear+  , module ADP.Fusion.Term.Deletion.ForestAlign.RightLinear+  , module ADP.Fusion.Term.Epsilon.ForestAlign.RightLinear+  , module ADP.Fusion.Term.Node.ForestAlign.RightLinear+  , module ADP.Fusion.Term.Node.Type+  ) where++import ADP.Fusion.Core+import ADP.Fusion.Core.ForestAlign.RightLinear+import ADP.Fusion.SynVar.Indices.ForestAlign.RightLinear+import ADP.Fusion.Term.Deletion.ForestAlign.RightLinear+import ADP.Fusion.Term.Epsilon.ForestAlign.RightLinear+import ADP.Fusion.Term.Node.ForestAlign.RightLinear+import ADP.Fusion.Term.Node.Type+
+ ADP/Fusion/Forest/Edit/LL.hs view
@@ -0,0 +1,19 @@++module ADP.Fusion.Forest.Edit.LL+  ( module ADP.Fusion.Core+  , module ADP.Fusion.Core.ForestEdit.LeftLinear+  , module ADP.Fusion.SynVar.Indices.ForestEdit.LeftLinear+  , module ADP.Fusion.Term.Deletion.ForestEdit.LeftLinear+  , module ADP.Fusion.Term.Epsilon.ForestEdit.LeftLinear+  , module ADP.Fusion.Term.Node.ForestEdit.LeftLinear+  , module ADP.Fusion.Term.Node.Type+  ) where++import ADP.Fusion.Core+import ADP.Fusion.Core.ForestEdit.LeftLinear+import ADP.Fusion.SynVar.Indices.ForestEdit.LeftLinear+import ADP.Fusion.Term.Deletion.ForestEdit.LeftLinear+import ADP.Fusion.Term.Epsilon.ForestEdit.LeftLinear+import ADP.Fusion.Term.Node.ForestEdit.LeftLinear+import ADP.Fusion.Term.Node.Type+
+ ADP/Fusion/SynVar/Indices/ForestAlign/RightLinear.hs view
@@ -0,0 +1,515 @@++-- |+--+-- TODO finding major simplifications here would be very useful++module ADP.Fusion.SynVar.Indices.ForestAlign.RightLinear where++import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Debug.Trace+import           Prelude hiding (map)+import qualified Data.Forest.Static as F+import qualified Data.Vector.Generic as VG++import           ADP.Fusion.Core+import           Data.Forest.Static+import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Core.ForestAlign.RightLinear++++-- * Inside++++-- | When choosing tree and forest sizes:+--+-- Syntactic variables. Different variants on parsing.+--+-- In case we have @X -> Y@, no restrictions are placed.+--+-- We now need @X -> Y Z@:+--+-- @+--+-- X    ->  Y     Z+-- i,E      i,E   i,E+--+--+--+-- X    ->  Y     Z       we do not split off the first tree+-- i,F      i,E   i,F+--+-- X    ->  Y     Z+-- i,F      i,T   k,F     k,E, if k==u ; 1st tree split off+--          i_k+--+-- X    ->  Y     Z       move complete forest down+-- i,F      i,F   u,E+--+--+--+-- When does this happen? If you have @T -> - F@ then @F@ will now actually+-- be such a @T@.+--+-- X    ->  Y     Z       do not hand i,T down+-- i,T      i,E   i,T+--+-- X    ->  Y     Z       further hand down+-- i,T      i,T   k,E+--          i_k+--+-- @++data TFsize s+  -- The tree shall have size epsilon, the forest be full. If @TF@ is @F@+  -- then the forest is a real forest, if @TF@ is @T@ then the forest is+  -- a tree.+  = EpsFull TF s+  -- | The tree is full (and actually a forest), the remainder of the+  -- forest is epsilon. This means that in the "tree" synvar, we can only+  -- do indels.+  | FullEpsFF s+  -- | The tree is set, the remaining forest gets what is left.+  | OneRemFT s+  -- | The tree is set, the remaining forest is empty.+  | OneEpsTT s+  | Finis++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a I)+  , MinSize c+--  , Show a, VG.Vector v a -- TEMP!+--  , a ~ Info+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a I) where+  addIndexDenseGo (cs:._) (vs:.IStatic ()) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j _)+    = map go . addIndexDenseGo cs vs lbs ubs us is+    where+      go (SvS s tt ii) =+        let RiTirI l tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+            tf'         = if l==u then E else tf+        in -- tSI (glb) ('S',u,l,tf,'.',distance $ F.label frst VG.! 0) $+            SvS s (tt:.TreeIxR frst l tf') (ii:.:RiTirI u E)+  addIndexDenseGo (cs:._) (vs:.IVariable ()) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j jj)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk svS = return $ EpsFull jj svS+          step Finis = return $ Done+          -- nothing here+          step (EpsFull E svS@(SvS s tt ii)) = return $ Yield (SvS s (tt:.TreeIxR frst j E) (ii:.:RiTirI j E)) Finis+          -- _ -> TF , for forests: with T having size ε, F having full size+          step (EpsFull F svS@(SvS s tt ii))+            = do let RiTirI k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                 --tSI (glb) ('V',u,k,F,'.',distance $ F.label frst VG.! 0) .+                 return $ Yield (SvS s (tt:.TreeIxR frst k E) (ii:.:RiTirI k F)) (FullEpsFF svS)  -- @k Epsilon / full@+          -- _ -> TF, for forests: with T having full size, F having size ε+          step (FullEpsFF svS@(SvS s tt ii))+            = do let RiTirI k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                 --tSI (glb) ('W',u,k,T,'.',distance $ F.label frst VG.! 0) .+                 return $ Yield (SvS s (tt:.TreeIxR frst k F) (ii:.:RiTirI u E)) (OneRemFT svS)   -- @full / u Epsilon@+          -- _ -> TF for forests: with T having size 1, F having full - 1 size+          step (OneRemFT (SvS s tt ii))+            = do let RiTirI k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                     l         = rbdef u frst k+                     ltf       = if l==u then E else F+                 --tSI (glb) ('W',u,k,l,T,'.',distance $ F.label frst VG.! 0) .+                 return $ Yield (SvS s (tt:.TreeIxR frst k T) (ii:.:RiTirI l ltf)) Finis -- @1 / l ltf@+          -- _ -> TF , for trees: with T having size ε, F having size 1 (or T)+          step (EpsFull T svS@(SvS s tt ii))+            = do let RiTirI k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                 --tSI (glb) ('V',u,k,F,'.',distance $ F.label frst VG.! 0) .+                 return $ Yield (SvS s (tt:.TreeIxR frst k E) (ii:.:RiTirI k T)) (OneEpsTT svS)+          -- _ -> TF, for trees: with T having size 1, F having size ε+          step (OneEpsTT (SvS s tt ii))+            = do let RiTirI k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                     l         = rbdef u frst k+                 --tSI (glb) ('W',u,k,l,T,'.',distance $ F.label frst VG.! 0) .+                 return $ Yield (SvS s (tt:.TreeIxR frst k T) (ii:.:RiTirI l E)) Finis+          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++glb = False++tSI cond s i = if cond then traceShow s i else i++instance (MinSize c) => TableStaticVar u c (TreeIxR p v a I) where +  tableStaticVar _ _ _ _ = IVariable ()+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++getrbound frst k+  | VG.length rs >= k = VG.length rs+  | r < 0             = VG.length rs+  | otherwise         = r+  where rs = rsib frst ; r = rs VG.! k+{-# Inline getrbound #-}++trright frst k = rbdef (VG.length $ rsib frst) frst k++-- | The next right sibling.++rbdef d frst k = maybe d (\z -> if z<0 then d else z) $ rsib frst VG.!? k+{-# Inline rbdef #-}++-- | Give us the parent for node @k@ or @-1@ if there is no parent++pardef frst k = maybe (-1) id $ parent frst VG.!? k+{-# Inline pardef #-}++++-- * Outside+--+-- For both, I / O and O / O systems, we need to consider a large number of+-- cases. The general rule @X -> Y Z@ with all variants follows below.+--+--+-- @+--+-- X    ->  Y     Z+-- i,E      i,E   i,E+--+-- Y^   ->  X^    Z+-- i,E      i,E   i,E+--+-- Z^   ->  Y     X^+-- i,E      i,E   i,E+--+--+--+-- X    ->  Y     Z       we do not split off the first tree; down is empty+-- i,F      i,E   i,F+--+-- Y^   ->  X^    Z+-- i,E      i,F   i,F+--+-- Z^   ->  Y     X^+-- i,F      i,E   i,F+--+--+-- X    ->  Y     Z+-- i,F      i,T   k,t     if k==u then E else F ; 1st tree split off+--          i~k+--+-- Y^   ->  X^    Z+-- i,T      i,F   k,t     if k==u then E else F+-- i~k+--+-- Z^   ->  Y     X^+-- u,E      i,T   i,F     ∀ i ;; for all trees [i,u) !+--          i~u+--+-- Z^   ->  Y     X^+-- k,F      i,T   i,F     i is left sibling of k+--          i~k+--+--+-- X    ->  Y     Z       move complete forest down+-- i,F      i,F   u,E+--+-- Y^   ->  X^    Z+-- i,F      i,F   u,E+--+-- Z^   ->  Y     X^      ∀ i ;; for u,E collect all possible splits.+-- u,E      i,F   i,F+--+--+--+-- X    ->  Y     Z       do not hand i,T down+-- i,T      i,E   i,T+--+-- Y^   ->  X^    Z+-- i,E      i,T   i,T+--+-- Z^   ->  Y     X^+-- i,T      i,E   i,T+--+--+--+-- X    ->  Y     Z       further hand down+-- i,T      i,T   k,E+--          i_k+--+-- Y^   ->  X^    Z+-- i,T      i,T   k,E+-- i_k+--+-- Z^   ->  Y     X^+-- k,E      i,T   i,T+--          i_k+--+--+-- @++++-- |+--+-- (where does this block of comments belong?)+--+-- In principle, we are missing an extra boolean case on @j==u@ or @j==l,+-- l/=u@ for tree-symbols, i.e. those that bind terminals. However, in+-- these linear languages, there can be only one such symbol per rule. This+-- in turn means they are never in outside mode on the r.h.s. and hence we+-- have no ambiguity problems.+--+-- synVar: @Table I@ with @Index O@ We only have two options: @X' -> Y'+-- Z@ with @Z@ being in @OStatic@ position or @X' -> Y Z'@ with @Y@ being+-- in @OFirstLeft@ position.+--+-- @+--+-- Z^   ->  Y     X^      ∀ i ;; for u,E collect all possible splits.+-- u,E      i,F   i,F     this is move complete forest down / inside+--+-- Z^   ->  Y     X^      further hand down+-- k,E      i,T   i,T+--          i_k+--+-- Z^   ->  Y     X^+-- u,E      i,T   i,F     ∀ i ;; for all trees [i,u) !+--          i~u+--+-- Z^   ->  Y     X^+-- i,E      i,E   i,E+--+--+--+-- Z^   ->  Y     X^       we do not split off the first tree; down is empty+-- i,F      i,E   i,F+--+-- Z^   ->  Y     X^+-- k,F      i,T   i,F     ∀ i ;; for all trees [i,k) k/=u !+--          i~k+--+--+--+-- Z^   ->  Y     X^      do not hand i,T down+-- i,T      i,E   i,T+--+-- @++data OIEFT x+  = OIEFF x Int -- svS , forests starting at @i@+  | OIETT x Int -- svS , parent index for trees with right boundary @j@+  | OIETF x Int -- svS , parent index for trees with right boundary @u@+  | OIEEE x     -- svS+  | OIFEF x     -- svS+  | OIFTF x     -- svS+  | OITET x     -- svS+  | OIFinis++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a O) where+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j jj)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  SvS s (tt:.TreeIxR frst li tfi) (ii:.:RiTirO j E lo tfo) -- TODO should set right boundary+  addIndexDenseGo (cs:._) (vs:.OFirstLeft ()) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j jj)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk svS@(SvS s tt ii) =+            let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  return $ case jj of+                  E -> OIEFF svS 0+                  F -> OIFEF svS+                  T -> OITET svS+          step OIFinis = return Done+          -- Z^   ->  Y     X^      ∀ i ;; for u,E collect all possible splits.+          -- u,E      i,F   i,F     this is move complete forest down / inside+          step (OIEFF svS@(SvS s tt ii) k) | j==u && k<u+            = return $ Yield (SvS s (tt:.TreeIxR frst k F) (ii:.:RiTirO u E k F)) (OIEFF svS (k+1))+          step (OIEFF svS _)+            = let pj = maybe (-1) id $ F.lsib frst VG.!? j+              in  return $ Skip $ OIETT svS pj+          -- Z^   ->  Y     X^      further hand down+          -- k,E      i,T   i,T+          --          i_k+          step (OIETT svS@(SvS s tt ii) pj) | j<u && pj>=0+            = let pj' = pardef frst pj+                  tr  = if j==u then E else F+              in  return $ Yield (SvS s (tt:.TreeIxR frst pj T) (ii:.:RiTirO j tr pj T)) (OIETT svS pj')+          step (OIETT svS _)+            = let pu = pardef frst $ u - 1+              in  return $ Skip $ OIETF svS pu+          -- Z^   ->  Y     X^+          -- u,E      i,T   i,F     ∀ i ;; for all trees [i,u) !+          --          i~u+          step (OIETF svS@(SvS s tt ii) pu) | j==u && pu>=0+            = let pu' = pardef frst pu+              in  return $ Yield (SvS s (tt:.TreeIxR frst pu T) (ii:.:RiTirO u E pu F)) (OIETF svS pu')+          step (OIETF svS _)+            = return $ Skip $ OIEEE svS+          -- Z^   ->  Y     X^+          -- i,E      i,E   i,E+          step (OIEEE svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j E) (ii:.:RiTirO j E j E)) OIFinis+          -- Z^   ->  Y     X^       we do not split off the first tree; down is empty+          -- i,F      i,E   i,F+          step (OIFEF svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j E) (ii:.:RiTirO j E j F)) (OIFTF svS)+          -- Z^   ->  Y     X^+          -- k,F      i,T   i,F     i is left sibling of k+          --          i~k+          step (OIFTF svS@(SvS s tt ii)) | Just ls <- F.lsib frst VG.!? j, ls >= 0+            = return $ Yield (SvS s (tt:.TreeIxR frst ls T) (ii:.:RiTirO j F ls F)) OIFinis+          step (OIFTF _) = return $ Skip $ OIFinis+          -- Z^   ->  Y     X^      do not hand i,T down+          -- i,T      i,E   i,T+          step (OITET svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j E) (ii:.:RiTirO j E j T)) OIFinis+          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++++-- | The different cases for @O@ context with @O@ tables.+--+-- synVar: @Table O@   with @Index O@+--+-- @+--+-- Y^   ->  X^    Z+-- i,E      i,E   i,E+--+-- Y^   ->  X^    Z       we do not split off the first tree; down is empty+-- i,E      i,F   i,F+--+-- Y^   ->  X^    Z       do not hand i,T down+-- i,E      i,T   i,T+--+--+--+-- Y^   ->  X^    Z+-- i,T      i,F   k,t     if k==u then E else F ; 1st tree split off+-- i_k+--+-- Y^   ->  X^    Z       further hand down ; k,E because @T@+-- i,T      i,T   k,E+-- i_k+--+--+--+-- Y^   ->  X^    Z       move complete forest down+-- i,F      i,F   u,E+--+-- @++data OOEFT x -- = OOE TF x | OOF x | OOT TF x | OOFinis+  = OOE x TF  -- svS , all variants of T F E+  | OOFFE x   -- svS+  | OOTF  x   -- svS+  | OOTT  x   -- svS+  | OOFinis++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a O) cs c is (TreeIxR p v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a O) (cs:.c) (is:.TreeIxR p v a O) where+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j _)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+            in  SvS s (tt:.TreeIxR frst lo tfo) (ii:.:RiTirO li tfi j E) -- TODO should set right boundary+  addIndexDenseGo (cs:._) (vs:.ORightOf ()) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j jj)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk svS = return $ case jj of+                    E -> OOE   svS minBound+                    F -> OOFFE svS+                    T -> OOTF  svS+          -- done+          step OOFinis = return Done+          -- Y^   ->  X^    Z+          -- i,E      i,E   i,E+          --+          -- Y^   ->  X^    Z       we do not split off the first tree; down is empty+          -- i,E      i,F   i,F+          --+          -- Y^   ->  X^    Z       do not hand i,T down+          -- i,E      i,T   i,T+          step (OOE svS@(SvS s tt ii) tf) | tf < maxBound+            = return $ Yield (SvS s (tt:.TreeIxR frst j tf) (ii:.:RiTirO j tf j E)) (OOE svS (succ tf))+          step (OOE svS@(SvS s tt ii) tf) | tf == maxBound+            = return $ Yield (SvS s (tt:.TreeIxR frst j tf) (ii:.:RiTirO j tf j E)) OOFinis+          -- Y^   ->  X^    Z       move complete forest down+          -- i,F      i,F   u,E+          step (OOFFE svS@(SvS s tt ii))+            = return $ Yield (SvS s (tt:.TreeIxR frst j F) (ii:.:RiTirO u E j E)) OOFinis+          -- Y^   ->  X^    Z+          -- i,T      i,F   k,t     if k==u then E else F ; 1st tree split off+          -- i_k+          step (OOTF svS@(SvS s tt ii))+            = let k = rbdef u frst j+                  tf = if k==u then E else F+              in  return $ Yield (SvS s (tt:.TreeIxR frst j F) (ii:.:RiTirO k tf j E)) (OOTT svS)+          -- Y^   ->  X^    Z       further hand down ; k,E because @T@+          -- i,T      i,T   k,E+          -- i_k+          step (OOTT svS@(SvS s tt ii))+            = let k = rbdef u frst j+              in  return $ Yield (SvS s (tt:.TreeIxR frst j T) (ii:.:RiTirO k E j E)) OOFinis+          {-# Inline [0] mk #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++++instance (MinSize c) => TableStaticVar (u I) c (TreeIxR p v a O) where +  tableStaticVar _ _ (OStatic    d) _ = ORightOf d+  tableStaticVar _ _ (ORightOf   d) _ = ORightOf d+  tableStaticVar _ _ (OFirstLeft d) _ = OLeftOf  d+  tableStaticVar _ _ (OLeftOf    d) _ = OLeftOf  d+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++++instance (MinSize c) => TableStaticVar (u O) c (TreeIxR p v a O) where +  tableStaticVar _ _ (OStatic  d) _ = OFirstLeft d+  tableStaticVar _ _ (ORightOf d) _ = OFirstLeft d+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++++-- * Complemented++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a I) cs c is (TreeIxR p v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a I) (cs:.c) (is:.TreeIxR p v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j _)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirC k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a C))+            in  SvS s (tt:.TreeIxR frst k tf) (ii:.:RiTirC k tf)+  {-# Inline addIndexDenseGo #-}++++instance+  ( IndexHdr s x0 i0 us (TreeIxR p v a O) cs c is (TreeIxR p v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxR p v a O) (cs:.c) (is:.TreeIxR p v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:.TreeIxR frst u v) (is:.TreeIxR _ j _)+    = map go .addIndexDenseGo cs vs lbs ubs us is+    where go (SvS s tt ii) =+            let RiTirC k tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a C))+            in  SvS s (tt:.TreeIxR frst k tf) (ii:.:RiTirC k tf)+  {-# Inline addIndexDenseGo #-}+
+ ADP/Fusion/SynVar/Indices/ForestEdit/LeftLinear.hs view
@@ -0,0 +1,217 @@++module ADP.Fusion.SynVar.Indices.ForestEdit.LeftLinear where++import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Prelude hiding (map)+import qualified Data.Vector.Generic as VG+import           Debug.Trace+import           Data.List (sort,nub)++import           ADP.Fusion.Core+import           Data.Forest.Static+import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Core.ForestEdit.LeftLinear++++-- * Inside indices, Inside object++instance+  ( IndexHdr s x0 i0 us (TreeIxL p v a I) cs c is (TreeIxL p v a I)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxL p v a I) (cs:.c) (is:.TreeIxL p v a I) where+  addIndexDenseGo (cs:._) (vs:.IStatic ()) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j)  -- static = rechts!+    = map go . addIndexDenseGo cs vs lbs ubs us is+    where+      go (SvS s tt ii) =+        let RiTilI _ k = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL p v a I))+        in SvS s (tt:.TreeIxL frst lc k j) (ii:.:RiTilI k j)+  addIndexDenseGo (cs:._) (vs:.IVariable ()) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j) --variable = links!+    = map go . addIndexDenseGo cs vs lbs ubs us is . staticCheck (i<j)+    where+      go (SvS s tt ii) =+        let RiTilI _ k = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL p v a I))+            l = lc VG.! (j-1)+        in SvS s (tt:.TreeIxL frst lc k l) (ii:.:RiTilI k l)+  {-# Inline addIndexDenseGo #-}++instance (MinSize c) => TableStaticVar u c (TreeIxL p v a I) where +  tableStaticVar _ _ _ _ = IVariable ()+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++++-- * Grammar: Outside; Table: Outside++instance+  ( IndexHdr s x0 i0 us (TreeIxL Post v a O) cs c is (TreeIxL Post v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxL Post v a O) (cs:.c) (is:.TreeIxL Post v a O) where+  --+  -- \hat{T} -> F      \hat{F}+  -- [i,j)   -> [0,i)  [0,j)+  -- @+  --+  -- TODO in case this is a @Tree@, not a @Forest@, then we should only+  -- return some value, if @i,j@ is proper.+  --+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j)  -- static = rechts!+    = map go . addIndexDenseGo cs vs lbs ubs us is+    where+      go (SvS s tt ii) =+        let RiTilO iii iij ooi ooj = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL Post v a O))+        in  -- traceShowIf True (ss "O/O/st",(i,j),(ooi,j)) $+            SvS s (tt:.TreeIxL frst lc ooi ooj) (ii:.:RiTilO iii iij ooi ooj)+  -- TODO do we need to filter out everything that is not "almost+  -- right-most", where only a single tree will then be? This will go into+  -- the territory of linear vs. context-free languages for tree-editing.+  --+  -- \hat{F} -> \hat{F} T+  -- [0,i)   -> [0,j)   [i,j)+  -- @+  --+  -- TODO use ooi, ooj instead of i,j for CFG-style grammars+  addIndexDenseGo (cs:._) (vs:.ORightOf ()) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j) --variable = links!+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk svs = return (svs, Prelude.filter (\z -> j == lc VG.! z) $ toRoot frst j)+          -- ^ the @filter@ makes sure that we only build trees whose+          -- left-most leaf is @j@. Since then forest and tree fit next to+          -- each other.+          step (_,[]) = return Done+          -- a tree we can place to the right of us: @[j,k+1)@+          -- we ourselves make a whole @[i,k+1)@ in which to place said+          -- tree.+          step (SvS s tt ii,k:ks) = do+            let RiTilO iii iij ooi ooj = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL Post v a O))+            -- traceShow (ss "OOvar",i,j,(i,k+1),(j,k+1)) .+            return $ Yield (SvS s (tt:.TreeIxL frst lc i (k+1)) (ii:.:RiTilO j (k+1) i (k+1))) (SvS s tt ii, ks)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+--          blub = if False -- (i,j) == (0,1)+--                 then traceShow (ss "blub",i,j, let rs = toRoot frst j in (rs, [r | r <- rs, j == lc VG.! r]))+--                 else id+  {-# Inline addIndexDenseGo #-}++toRoot frst k = goR k+  where goR (-1) = []+        goR k | k >= VG.length (parent frst) = []+        goR k    = k : goR (parent frst VG.! k)++ss :: String -> String+ss = id++instance (MinSize c) => TableStaticVar (u O) c (TreeIxL Post v a O) where +  tableStaticVar _ _ (OStatic  ()) _ = OFirstLeft ()+  tableStaticVar _ _ (ORightOf ()) _ = OFirstLeft ()+  tableStaticVar _ _ z             _ = z+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++++-- * Grammar: Outside; Table: Inside++instance+  ( IndexHdr s x0 i0 us (TreeIxL Post v a I) cs c is (TreeIxL Post v a O)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxL Post v a I) (cs:.c) (is:.TreeIxL Post v a O) where+  --+  -- \hat{F} -> \hat{F} T+  -- [0,i)   -> [0,j)   [i,j)+  -- @+  --+  addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j)  -- static = rechts!+    = map go . addIndexDenseGo cs vs lbs ubs us is -- . staticCheck (j>0 && rt>=0)+    where+      go (SvS s tt ii) =+        let RiTilO iii iij ooi ooj = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL Post v a O))+        in  if (iij>0 && j == iii && iii == lc VG.! (iij-1))+            then SvS s (tt:.TreeIxL frst lc iii iij) (ii:.:RiTilO iii iij ooi ooj)+            else error $ show (i,j,iii,iij, lc VG.! (iij-1), toRoot frst (j-1))+  -- TODO do we need to filter out everything that is not "almost+  -- right-most", where only a single tree will then be? This will go into+  -- the territory of linear vs. context-free languages for tree-editing.+  --+  -- \hat{T} -> F      \hat{F}+  -- [i,j)   -> [0,i)  [0,j)+  -- @+  --+  addIndexDenseGo (cs:._) (vs:.OFirstLeft ()) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j) --variable = links!+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is -- . staticCheck isValidTree -- . blub+    where mk svs = return (svs, [0..j-1]) -- allLeftBoundForests frst lc (j-1))+          step (s,[]) = return Done+          step (SvS s tt ii,k:ks) = do+            let RiTilO iii iij ooi ooj = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL Post v a O))+            -- traceShowIf True (ss "OIvar",(i,j),(k,i)) .+            return $ Yield (SvS s (tt:.TreeIxL frst lc k i) (ii:.:RiTilO k i k j)) (SvS s tt ii,ks) -- j or ooj ???+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+          !isValidTree = j>0 && j<=u+--          blub = if (i,j) == (3,4)+--                 then traceShow ((i,j),let zs = allLeftBoundForests frst lc (j-1) in (zs,[ ((k,i),(k,j)) | k <- zs] ))+--                 else id+  addIndexDenseGo _ (vs:.bang) _ _ _ _ = error $ show bang+  {-# Inline addIndexDenseGo #-}++traceShowIf cond s = if cond then traceShow s else id++lboundary frst lc k = go k $ lsib frst VG.! k+  where go now next | next == -1 = lc VG.! now+                    | otherwise  = go next (lsib frst VG.! now)++allLeftBoundForests frst lc k = ls+  where rs = goR k+        ls = nub $ sort [ lc VG.! z | z <- rs ]+        goR (-1) = []+        goR k    = k : goR (parent frst VG.! k)++instance (MinSize c) => TableStaticVar (u I) c (TreeIxL Post v a O) where +  tableStaticVar _ _ (OStatic  ())   _ = ORightOf   ()+  tableStaticVar _ _ (ORightOf ())   _ = OFirstLeft ()+  tableStaticVar _ _ (OFirstLeft ()) _ = OLeftOf    ()+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++++-- * Complement++instance+  ( IndexHdr s x0 i0 us (TreeIxL Post v a I) cs c is (TreeIxL Post v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxL Post v a I) (cs:.c) (is:.TreeIxL Post v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j)  -- static = rechts!+    = map go . addIndexDenseGo cs vs lbs ubs us is+    where+      go (SvS s tt ii) = SvS s (tt:.TreeIxL frst lc i j) (ii:.:RiTilC i j)+  {-# Inline addIndexDenseGo #-}++instance+  ( IndexHdr s x0 i0 us (TreeIxL Post v a O) cs c is (TreeIxL Post v a C)+  , MinSize c+  ) => AddIndexDense s (us:.TreeIxL Post v a O) (cs:.c) (is:.TreeIxL Post v a C) where+  addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:.TreeIxL frst lc l u) (is:.TreeIxL _ _ i j)  -- static = rechts!+    = map go . addIndexDenseGo cs vs lbs ubs us is+    where+      go (SvS s tt ii) = SvS s (tt:.TreeIxL frst lc i j) (ii:.:RiTilC i j)+  {-# Inline addIndexDenseGo #-}++++instance (MinSize c) => TableStaticVar (u I) c (TreeIxL Post v a C) where +  tableStaticVar _ _ z             _ = z+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}++instance (MinSize c) => TableStaticVar (u O) c (TreeIxL Post v a C) where +  tableStaticVar _ _ z             _ = z+  tableStreamIndex _ c _ = id+  {-# Inline [0] tableStaticVar #-}+  {-# Inline [0] tableStreamIndex #-}+
+ ADP/Fusion/Term/Deletion/ForestAlign/RightLinear.hs view
@@ -0,0 +1,76 @@++module ADP.Fusion.Term.Deletion.ForestAlign.RightLinear where++import Data.Strict.Tuple hiding (fst, snd)+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Prelude hiding (map)++import ADP.Fusion.Core+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.ForestAlign.RightLinear++++-- * Inside++++instance+  ( TmkCtx1 m ls Deletion (TreeIxR p v a t)+  ) => MkStream m (ls :!: Deletion) (TreeIxR p v a t) where+  mkStream (ls :!: Deletion) sv us is+    = map (\(ss,ee,ii) -> ElmDeletion ii ss)+    . addTermStream1 Deletion sv us is+    $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is)+  {-# Inline mkStream #-}++++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a I)+  ) => TermStream m (TermSymbol ts Deletion) s (is:.TreeIxR p v a I) where+  termStream (ts:|Deletion) (cs:.IVariable ()) (us:.u) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirI l tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+              in  {- traceShow ("-"::String,l,tf) $ -} TState s (ii:.:RiTirI l tf) (ee:.()) )+    . termStream ts cs us is+--    . staticCheck (ii == T)+  {-# Inline termStream #-}++++instance TermStaticVar Deletion (TreeIxR p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- * Outside+--+-- Has no conditions on when it is acceptable.+--+-- TODO missing single tape instance?++++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  ) => TermStream m (TermSymbol ts Deletion) s (is:.TreeIxR p v a O) where+  termStream (ts:|Deletion) (cs:._) (us:.u) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+              in  TState s (ii:.:RiTirO li tfi lo tfo) (ee:.()) )+    . termStream ts cs us is+  {-# Inline termStream #-}++++instance TermStaticVar Deletion (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+
+ ADP/Fusion/Term/Deletion/ForestEdit/LeftLinear.hs view
@@ -0,0 +1,68 @@++module ADP.Fusion.Term.Deletion.ForestEdit.LeftLinear where++import Data.Strict.Tuple hiding (fst, snd)+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Prelude hiding (map)++import ADP.Fusion.Core+import Data.Forest.Static+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.ForestEdit.LeftLinear++++-- * Common++instance+  ( TmkCtx1 m ls Deletion (TreeIxL p v a t)+  ) => MkStream m (ls :!: Deletion) (TreeIxL p v a t) where+  mkStream (ls :!: Deletion) sv us is+    = map (\(ss,ee,ii) -> ElmDeletion ii ss)+    . addTermStream1 Deletion sv us is+    $ mkStream ls (termStaticVar Deletion sv is) us (termStreamIndex Deletion sv is)+  {-# Inline mkStream #-}++++-- * Inside++instance+  ( TstCtx m ts s x0 i0 is (TreeIxL p v a I)+  ) => TermStream m (TermSymbol ts Deletion) s (is:.TreeIxL p v a I) where+  termStream (ts:|Deletion) (cs:.IStatic ()) (us:.u) (is:.TreeIxL frst _ i j)+    = map (\(TState s ii ee) ->+              let RiTilI k l = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL p v a I))+              in  {- traceShow ("-"::String,l,tf) $ -} TState s (ii:.:RiTilI k l) (ee:.()) )+    . termStream ts cs us is+  {-# Inline termStream #-}+++instance TermStaticVar Deletion (TreeIxL p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- * Outside++instance+  ( TstCtx m ts s x0 i0 is (TreeIxL Post v a O)+  ) => TermStream m (TermSymbol ts Deletion) s (is:.TreeIxL Post v a O) where+  termStream (ts:|Deletion) (cs:.OStatic ()) (us:.u) (is:.TreeIxL frst _ i j)+    = map (\(TState s ii ee) ->+              let RiTilO _ k oi oj = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL Post v a O))+              in  TState s (ii:.:RiTilO k k oi oj) (ee:.()) )+    . termStream ts cs us is+  {-# Inline termStream #-}+++instance TermStaticVar Deletion (TreeIxL Post v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+
+ ADP/Fusion/Term/Epsilon/ForestAlign/PermuteRightLinear.hs view
@@ -0,0 +1,3 @@++module ADP.Fusion.Term.Epsilon.ForestAlign.PermuteRightLinear where+
+ ADP/Fusion/Term/Epsilon/ForestAlign/RightLinear.hs view
@@ -0,0 +1,78 @@++-- | Epsilon+--+-- X    -> ε+-- i,E     i,E    ∀ i++module ADP.Fusion.Term.Epsilon.ForestAlign.RightLinear where++import           Data.Strict.Tuple hiding (fst, snd)+import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Prelude hiding (map)++import           ADP.Fusion.Core+import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Core.ForestAlign.RightLinear++++-- * Inside++++instance+  ( TmkCtx1 m ls Epsilon (TreeIxR p v a t)+  ) => MkStream m (ls :!: Epsilon) (TreeIxR p v a t) where+  mkStream (ls :!: Epsilon) sv us is+    = map (\(ss,ee,ii) -> ElmEpsilon ii ss)+    . addTermStream1 Epsilon sv us is+    $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)+  {-# Inline mkStream #-}++++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a I)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.TreeIxR p v a I) where+  termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.TreeIxR _ u uu) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirI l tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+              in  TState s (ii:.:RiTirI l tf) (ee:.()) )+    . termStream ts cs us is+    . staticCheck ( (ii==E) || (u==0 && uu==F) ) -- 2nd condition takes care of empty inputs+  {-# Inline termStream #-}++++instance TermStaticVar Epsilon (TreeIxR p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- * Outside++++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.TreeIxR p v a O) where+  termStream (ts:|Epsilon) (cs:.OStatic ()) (us:.TreeIxR _ u uu) (is:.TreeIxR frst i ii)+    = map (\(TState s ii ee) ->+              let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+              in  TState s (ii:.:RiTirO li tfi lo tfo) (ee:.()) )+    . termStream ts cs us is+    . staticCheck ((i==0 && ii==F) || (i==0 && u==0 && ii==E))+  {-# Inline termStream #-}++++instance TermStaticVar Epsilon (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+
+ ADP/Fusion/Term/Epsilon/ForestEdit/LeftLinear.hs view
@@ -0,0 +1,68 @@++module ADP.Fusion.Term.Epsilon.ForestEdit.LeftLinear where++import Data.Strict.Tuple hiding (fst, snd)+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Prelude hiding (map)++import ADP.Fusion.Core+import Data.Forest.Static+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.ForestEdit.LeftLinear++++-- * Common++instance+  ( TmkCtx1 m ls Epsilon (TreeIxL p v a t)+  ) => MkStream m (ls :!: Epsilon) (TreeIxL p v a t) where+  mkStream (ls :!: Epsilon) sv us is+    = map (\(ss,ee,ii) -> ElmEpsilon ii ss)+    . addTermStream1 Epsilon sv us is+    $ mkStream ls (termStaticVar Epsilon sv is) us (termStreamIndex Epsilon sv is)+  {-# Inline mkStream #-}++++-- * Inside++instance+  ( TstCtx m ts s x0 i0 is (TreeIxL p v a I)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.TreeIxL p v a I) where+  termStream (ts:|Epsilon) (cs:.IStatic ()) (us:.TreeIxL _ _ l u) (is:.TreeIxL frst _ i j)+    = map (\(TState s ii ee) -> TState s (ii:.:RiTilI i j) (ee:.()) )+    . termStream ts cs us is+    . staticCheck (i==j)+  {-# Inline termStream #-}+++instance TermStaticVar Epsilon (TreeIxL p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- * Outside++instance+  ( TstCtx m ts s x0 i0 is (TreeIxL Post v a O)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.TreeIxL Post v a O) where+  termStream (ts:|Epsilon) (cs:.OStatic ()) (us:.TreeIxL _ _ l u) (is:.TreeIxL frst _ i j)+    = map (\(TState s ii ee) ->+              let oo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL Post v a O))+              in  TState s (ii:.:oo) (ee:.()) )+    . termStream ts cs us is+    . staticCheck (l==i && u==j)+  {-# Inline termStream #-}+++instance TermStaticVar Epsilon (TreeIxL Post v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ i = i+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+
+ ADP/Fusion/Term/Node/ForestAlign/PermuteRightLinear.hs view
@@ -0,0 +1,114 @@++-- |+--+-- TODO outside costs++module ADP.Fusion.Term.Node.ForestAlign.PermuteRightLinear where++import           Data.List (permutations)+import           Data.Strict.Tuple hiding (fst, snd)+import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Prelude hiding (map)+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Unboxed as VU+import qualified Prelude as P++import           ADP.Fusion.Core+import           Data.Forest.Static+import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Core.ForestAlign.PermuteRightLinear+import           ADP.Fusion.Term.Node.Type++++-- Node: parse a local root++instance+  ( TmkCtx1 m ls (Node r x) (TreeIxR p v a t)+  ) => MkStream m (ls :!: Node r x) (TreeIxR p v a t) where+  mkStream (ls :!: Node f nty xs) sv us is+    = map (\(ss,ee,ii) -> ElmNode ee ii ss)+    . addTermStream1 (Node f nty xs) sv us is+    $ mkStream ls (termStaticVar (Node f nty xs) sv is) us (termStreamIndex (Node f nty xs) sv is)+  {-# Inline mkStream #-}++++-- |+--+-- X    -> n    Y+-- i,T  -> i,T  (i+1),t    -- @t@ = if @i@ has no children, then @E@, else @F@.++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a I)+--  , Show r+  ) => TermStream m (TermSymbol ts (Node r x)) s (is:.TreeIxR p v a I) where+  termStream (ts:|Node f nty xs) (cs:.IVariable ()) (us:.TreeIxR _ ul utfe) (is:.TreeIxR frst il itfe)+    = map (\(TState s ii ee) ->+              let RiTirI (T l) = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                  cs = children frst VG.! l+                  fe = if VG.null cs then E l else F cs+              in  -- traceShow ("N"::String,cs,fe, f xs l) $+                  TState s (ii:.:RiTirI fe) (ee:.f xs l) )+    . termStream ts cs us is+    . staticCheck ({- itfe < utfe && -} isTree itfe)+  {-# Inline termStream #-}+++instance TermStaticVar (Node r x) (TreeIxR p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxR frst i j) = TreeIxR frst i j+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- PermNode: parse a local root and permute the local forest++instance+  ( TmkCtx1 m ls (PermNode r x) (TreeIxR p v a t)+  ) => MkStream m (ls :!: PermNode r x) (TreeIxR p v a t) where+  mkStream (ls :!: PermNode f xs) sv us is+    = map (\(ss,ee,ii) -> ElmPermNode ee ii ss)+    . addTermStream1 (PermNode f xs) sv us is+    $ mkStream ls (termStaticVar (PermNode f xs) sv is) us (termStreamIndex (PermNode f xs) sv is)+  {-# Inline mkStream #-}++++-- |+--+-- X    -> n    Y+-- i,T  -> i,T  (i+1),t    -- @t@ = if @i@ has no children, then @E@, else @F@.++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a I)+  ) => TermStream m (TermSymbol ts (PermNode r x)) s (is:.TreeIxR p v a I) where+  termStream (ts:|PermNode f xs) (cs:.IVariable ()) (us:.TreeIxR _ ul utfe) (is:.TreeIxR frst il itfe)+    = flatten mk step+    . termStream ts cs us is+    . staticCheck ({- itfe < utfe && -} isTree itfe)+    where mk (TState s ii ee) =+            let RiTirI (T l) = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                cs = children frst VG.! l+                fe = if VG.null cs then Nothing else (Just $ permutations $ VU.toList cs)+            in  return (s, ii, ee, fe)+          step (s, _ , _ , Just [])+            = return $ Done+          step (s, ii, ee,  Nothing)+            = let RiTirI (T l) = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+              in  return $ Yield (TState s (ii:.:RiTirI (E l)) (ee:.f xs l)) (s, ii, ee, Just [])+          step (s, ii, ee, Just (y:ys))+            = let RiTirI (T l) = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+              in  return $ Yield (TState s (ii:.:RiTirI (F $ VU.fromList y)) (ee:.f xs l)) (s, ii, ee, Just ys)+  {-# Inline termStream #-}++++instance TermStaticVar (PermNode r x) (TreeIxR p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxR frst i j) = TreeIxR frst i j+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+
+ ADP/Fusion/Term/Node/ForestAlign/RightLinear.hs view
@@ -0,0 +1,97 @@++module ADP.Fusion.Term.Node.ForestAlign.RightLinear where++import           Data.Strict.Tuple hiding (fst, snd)+import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Prelude hiding (map)+import qualified Data.Vector.Generic as VG++import           ADP.Fusion.Core+import           Data.Forest.Static+import           Data.PrimitiveArray hiding (map)++import           ADP.Fusion.Core.ForestAlign.RightLinear+import           ADP.Fusion.Term.Node.Type++++-- * Inside++instance+  ( TmkCtx1 m ls (Node r x) (TreeIxR p v a t)+  ) => MkStream m (ls :!: Node r x) (TreeIxR p v a t) where+  mkStream (ls :!: Node f nty xs) sv us is+    = map (\(ss,ee,ii) -> ElmNode ee ii ss)+    . addTermStream1 (Node f nty xs) sv us is+    $ mkStream ls (termStaticVar (Node f nty xs) sv is) us (termStreamIndex (Node f nty xs) sv is)+  {-# Inline mkStream #-}++-- |+--+-- X    -> n    Y+-- i,T  -> i,T  (i+1),t    -- @t@ = if @i@ has no children, then @E@, else @F@.++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a I)+  ) => TermStream m (TermSymbol ts (Node r x)) s (is:.TreeIxR p v a I) where+  termStream (ts:|Node f nty xs) (cs:.IVariable ()) (us:.TreeIxR _ u ut) (is:.TreeIxR frst i it)+    = map (\(TState s ii ee) ->+              let RiTirI l tf = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a I))+                  l'  = l+1+                  tf'  = if VG.null (children frst VG.! l) then E else F+              in  {- traceShow ("N"::String,l,tf) $ -} TState s (ii:.:RiTirI l' tf') (ee:.f xs l) )+    . termStream ts cs us is+    . staticCheck (i<u && it == T)+  {-# Inline termStream #-}+++instance TermStaticVar (Node r x) (TreeIxR p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxR frst i j) = TreeIxR frst i j+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- * Outside++-- | We are a @F@orest at position @i@. Now we request the parent, who+-- happens to be the root of a @T@ree.+--+-- TODO we should actually move the outside index via the @OFirstLeft@+-- (etc) encoding+--+-- X    -> n    Y+-- i,T  -> i,T  i+1,t     -- @t@ = if @i@ has no children, then @E@, else @F@.+--+-- Y'     ->  n       X'+-- i+1,t      i,T     i,T   -- @t@ = if @i@ ...+--+-- Y'     ->  n       X'+-- i,t        i-1,T   i-1,T -- @t@ = if @i-1@ has no children, then @E@ else @F@++instance+  ( TstCtx m ts s x0 i0 is (TreeIxR p v a O)+  , Show r+  ) => TermStream m (TermSymbol ts (Node r x)) s (is:.TreeIxR p v a O) where+  termStream (ts:|Node f nty xs) (cs:.OFirstLeft ()) (us:.TreeIxR _ u ut) (is:.TreeIxR frst i it)+    = map (\(TState s ii ee) ->+              let RiTirO li tfi lo tfo = getIndex (getIdx s) (Proxy :: PRI is (TreeIxR p v a O))+                  l' = li - 1+              in  TState s (ii:.:RiTirO li T l' T) (ee:.f xs l') ) -- @li@, since we have now just 'eaten' @li -1 , li@+    . termStream ts cs us is+    -- @i>0@ so that we can actually have a parent+    -- @it==E@ in case we @i-1@ has no children; @it==F@ in case @i-1@ has+    -- children.+    . staticCheck (let hc = not $ VG.null (children frst VG.! (i-1))+                   in  i>0 && (not hc && it==E || hc && it==F))+  {-# Inline termStream #-}++instance TermStaticVar (Node r x) (TreeIxR p v a O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxR frst i j) = TreeIxR frst i j+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+++
+ ADP/Fusion/Term/Node/ForestEdit/LeftLinear.hs view
@@ -0,0 +1,93 @@++-- | 'Node' handling for tree-editing.+--+-- TODO outside++module ADP.Fusion.Term.Node.ForestEdit.LeftLinear where++import           Data.Strict.Tuple hiding (fst, snd)+import           Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import           Prelude hiding (map)+import qualified Prelude as P+import qualified Data.Vector.Generic as VG++import           ADP.Fusion.Core+import           Data.PrimitiveArray hiding (map)+import           Data.Forest.Static++import           ADP.Fusion.Core.ForestEdit.LeftLinear+import           ADP.Fusion.Term.Node.Type++++-- * Common++instance+  ( TmkCtx1 m ls (Node r x) (TreeIxL p v a t)+  ) => MkStream m (ls :!: Node r x) (TreeIxL p v a t) where+  mkStream (ls :!: Node f nty xs) sv us is+    = map (\(ss,ee,ii) -> ElmNode ee ii ss)+    . addTermStream1 (Node f nty xs) sv us is+    $ mkStream ls (termStaticVar (Node f nty xs) sv is) us (termStreamIndex (Node f nty xs) sv is)+  {-# Inline mkStream #-}++++-- * Inside++instance+  ( TstCtx m ts s x0 i0 is (TreeIxL p v a I)+  ) => TermStream m (TermSymbol ts (Node r x)) s (is:.TreeIxL p v a I) where+  termStream (ts:|Node f nty xs) (cs:.IStatic ()) (us:.TreeIxL _ _ l u) (is:.TreeIxL frst lc i j)+    = map (\(TState s ii ee) -> {-traceShow ('n',i,j) $-} TState s (ii:.:RiTilI (j-1) j) (ee:.f xs (j-1)) )+    . termStream ts cs us is+    . staticCheck (i < j && (nty == NTany || i == lc VG.! (j-1)) )+    -- TODO this check should only be @i<j@, but we want to test more with+    -- SingleEdit where only have this for actual trees+  {-# Inline termStream #-}+++instance TermStaticVar (Node r x) (TreeIxL p v a I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ (TreeIxL frst c i j) = TreeIxL frst c i $ j-1+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}++++-- * Outside+--+-- basically, we have a missing forest (@-0@ and @-1@) and if we have this+-- and an existing (@2@) node, then before we had a missing tree. So+-- @\hat{F} -> \hat{T} x@, for example.+--+-- @+--              2         -2+--   / \    +       =     / \+--  -0 -1                -0 -1+-- @++instance+  ( TstCtx m ts s x0 i0 is (TreeIxL Post v a O)+  ) => TermStream m (TermSymbol ts (Node r x)) s (is:.TreeIxL Post v a O) where+  termStream (ts:|Node f nty xs) (cs:.OStatic ()) (us:.TreeIxL _ _ l u) (is:.TreeIxL frst lc i j)+    = map (\(TState s ii ee) -> let RiTilO _ _ oi oj = getIndex (getIdx s) (Proxy :: PRI is (TreeIxL Post v a O))+            -- given an index @[i,j)@ of "missing" structure, we add a new+            -- node at @[j,j+1)@.+            in TState s (ii:.:RiTilO j (j+1) oi oj) (ee:.f xs j) )+    . termStream ts cs us is+    . staticCheck (i <= j && j < u && (nty == NTany || j < u && i == lc VG.! j) )+    -- TODO same here, check is only for SingleEdit. If this works out,+    -- we'll actually need special tree-root nodes for Tree-Editing.+  {-# Inline termStream #-}++++instance TermStaticVar (Node r x) (TreeIxL Post v a O) where+  termStaticVar _ sv _ = sv -- context doesn't change+  termStreamIndex _ _ (TreeIxL frst c i j) = TreeIxL frst c i $ j+1+  {-# Inline [0] termStaticVar   #-}+  {-# Inline [0] termStreamIndex #-}+++
+ ADP/Fusion/Term/Node/Type.hs view
@@ -0,0 +1,77 @@++module ADP.Fusion.Term.Node.Type where++import           Data.Strict.Tuple+import qualified Data.Vector.Generic as VG++import           ADP.Fusion.Core+import           Data.PrimitiveArray++++data NodeType = NTany | NTroot+  deriving (Eq,Show)++data Node r x where+  Node :: VG.Vector v x+       => (v x -> Int -> r)+       -> NodeType+       -> !(v x)+       -> Node r x++node :: VG.Vector v x => NodeType -> v x -> Node x x+node = Node (VG.!)+{-# Inline node #-}++instance Build (Node r x)++instance+  ( Element ls i+  ) => Element (ls :!: Node r x) i where+    data Elm (ls :!: Node r x) i = ElmNode !r !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: Node r x)   = Arg ls :. r+    getArg (ElmNode x _ ls) = getArg ls :. x+    getIdx (ElmNode _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}+++type instance TermArg (Node r x) = r++++-- | TODO Should return permutation being used as well This means we have+-- a vector @v@ and a permutation @p@ on @[1 .. |v|]@. We should apply @p@+-- to @v@ yielding @v'@, the permutation of @v@. @PermNode@ should then+-- hold on to the pair @(v',p)@. This allows us to observe the permutation+-- directly via @v'@, but also consider the applied @p@. This is useful for+-- considering what the "cost" of @p@ should be. Say, given @[1,2,3,4]@+-- then the identity permutation is cost-free, while @[2,1,3,4]@ could be+-- less costly than @[4,1,3,2]@, but more costly than @[4,3,2,1]@. This+-- will depend on the user but should be supported.++data PermNode r x where+  PermNode :: VG.Vector v x+       => (v x -> Int -> r)+       -> !(v x)+       -> PermNode r x++permNode :: VG.Vector v x => v x -> PermNode x x+permNode = PermNode (VG.!)+{-# Inline permNode #-}++instance Build (PermNode r x)++instance+  ( Element ls i+  ) => Element (ls :!: PermNode r x) i where+    data Elm (ls :!: PermNode r x) i = ElmPermNode !r !(RunningIndex i) !(Elm ls i)+    type Arg (ls :!: PermNode r x)   = Arg ls :. r+    getArg (ElmPermNode x _ ls) = getArg ls :. x+    getIdx (ElmPermNode _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}+++type instance TermArg (PermNode r x) = r+
+ ADPfusionForest.cabal view
@@ -0,0 +1,426 @@+name:           ADPfusionForest+version:        0.0.0.1+author:         Christian Hoener zu Siederdissen, Sarah Berkemer, 2016-2017+copyright:      Christian Hoener zu Siederdissen, 2016-2017+homepage:       https://github.com/choener/ADPfusionForest+bug-reports:    https://github.com/choener/ADPfusionForest/issues+maintainer:     choener@bioinf.uni-leipzig.de+category:       Formal Languages, Bioinformatics+license:        BSD3+license-file:   LICENSE+build-type:     Simple+stability:      experimental+cabal-version:  >= 1.10.0+tested-with:    GHC == 8.0.2+synopsis:       Dynamic programming on tree and forest structures+description:+                ADPfusion for formal languages on tree and forest structures.+                This library connects+                <http://hackage.haskell.org/package/ForestStructures @ForestStructures@>,+                a library which defines efficient, tree-like structures and+                <http://hackage.haskell.org/package/ADPfusion @ADPfusion@>.+                The result is the ability to easily write formal grammars which+                act on input trees (as compared to the more common input+                strings).+                .+                Build this library with GHC-8.0.2++++Extra-Source-Files:+  changelog.md+  README.md+  stack.yaml+  examples/t1.nwk+  examples/t2.nwk++++flag examples+  description: build the examples+  default:     False+  manual:      True++++library+  build-depends: base                   >= 4.7      &&  < 5.0+               , containers             >= 0.5+               , fgl                    >= 5.5+               , strict                 >= 0.3+               , text                   >= 1.2+               , unordered-containers   >= 0.2+               , vector                 >= 0.10+               -- >= 3.4 for Hashable (Vector a)+               , vector-instances       >= 3.4+               , vector-th-unbox        >= 0.2+               , vector-algorithms      >= 0.7+               --+               , ADPfusion              == 0.5.2.*+               , DPutils                == 0.0.1.*+               , ForestStructures       == 0.0.0.*+               , GrammarProducts        == 0.1.*+               , PrimitiveArray         == 0.8.0.*++  exposed-modules:+    ADP.Fusion.Forest.Align.PRL+    ADP.Fusion.Forest.Align.RL+    ADP.Fusion.Forest.Edit.LL+    -- done+    ADP.Fusion.Core.ForestEdit.LeftLinear+    ADP.Fusion.SynVar.Indices.ForestEdit.LeftLinear+    ADP.Fusion.Term.Deletion.ForestEdit.LeftLinear+    ADP.Fusion.Term.Epsilon.ForestEdit.LeftLinear+    ADP.Fusion.Term.Node.ForestEdit.LeftLinear+    ADP.Fusion.Term.Node.Type+    -- wip+    ADP.Fusion.Core.ForestAlign.PermuteRightLinear+    ADP.Fusion.Term.Epsilon.ForestAlign.PermuteRightLinear+    ADP.Fusion.Term.Node.ForestAlign.PermuteRightLinear+    -- current+    ADP.Fusion.Core.ForestAlign.RightLinear+    ADP.Fusion.Term.Epsilon.ForestAlign.RightLinear+    ADP.Fusion.Term.Deletion.ForestAlign.RightLinear+    ADP.Fusion.Term.Node.ForestAlign.RightLinear+    ADP.Fusion.SynVar.Indices.ForestAlign.RightLinear+  default-language:+    Haskell2010+  default-extensions: AllowAmbiguousTypes+                    , BangPatterns+                    , DataKinds+                    , FlexibleContexts+                    , FlexibleInstances+                    , GADTs+                    , KindSignatures+                    , MultiParamTypeClasses+                    , OverloadedStrings+                    , RankNTypes+                    , ScopedTypeVariables+                    , StandaloneDeriving+                    , TypeFamilies+                    , TypeOperators+                    , UndecidableInstances+  ghc-options:+    -O2+    -funbox-strict-fields++++executable AlignNewickTrees+  if flag(examples)+    buildable:+      True+    build-depends: base+                 , cmdargs                >= 0.10+                 , containers+                 , filepath+                 , log-domain             >= 0.10+                 , text+                 , vector+                 --+                 , ADPfusion+                 , ADPfusionForest+                 , BiobaseNewick          >= 0.0.0.1+                 , ForestStructures+                 , FormalGrammars         >= 0.3+                 , PrimitiveArray+                 , PrimitiveArray-Pretty  >= 0.0+  else+    buildable:+      False+  hs-source-dirs:+    src+  main-is:+    AlignNewickTrees.hs+  default-language:+    Haskell2010+  default-extensions: BangPatterns+                    , DataKinds+                    , DeriveDataTypeable+                    , FlexibleContexts+                    , GADTs+                    , MultiParamTypeClasses+                    , OverloadedStrings+                    , QuasiQuotes+                    , RecordWildCards+                    , TemplateHaskell+                    , TypeFamilies+                    , TypeOperators+  ghc-options:+    -O2+    -funbox-strict-fields++++executable AffineAlignNewickTreesSmall+  if flag(examples)+    buildable:+      True+    build-depends: base+                 , cmdargs                >= 0.10+                 , containers+                 , filepath+                 , log-domain             >= 0.10+                 , text+                 , vector+                 --+                 , ADPfusion+                 , ADPfusionForest+                 , BiobaseNewick          >= 0.0.0.1+                 , ForestStructures+                 , FormalGrammars         >= 0.3+                 , PrimitiveArray+                 , PrimitiveArray-Pretty  >= 0.0+  else+    buildable:+      False+  hs-source-dirs:+    src+  main-is:+    AffineAlignNewickTreesSmall.hs+  default-language:+    Haskell2010+  default-extensions: BangPatterns+                    , DataKinds+                    , DeriveDataTypeable+                    , FlexibleContexts+                    , GADTs+                    , MultiParamTypeClasses+                    , OverloadedStrings+                    , QuasiQuotes+                    , RecordWildCards+                    , TemplateHaskell+                    , TypeFamilies+                    , TypeOperators+  ghc-options:+    -O2+    -funbox-strict-fields+++-- AffineAlignNewickTrees too  big, use AffineAlignNewickTreesSmall++-- executable EditNewickTrees+--   if flag(examples)+--     buildable:+--       True+--     build-depends: base+--                  , cmdargs                >= 0.10+--                  , containers+--                  , filepath+--                  , log-domain             >= 0.10+--                  , text+--                  , vector+--                  --+--                  , ADPfusion+--                  , ADPfusionForest+--                  , BiobaseNewick          >= 0.0.0.1+--                  , ForestStructures+--                  , FormalGrammars         >= 0.3+--                  , PrimitiveArray+--                  , PrimitiveArray-Pretty  >= 0.0+--   else+--     buildable:+--       False+--   hs-source-dirs:+--     src+--   main-is:+--     EditNewickTrees.hs+--   default-language:+--     Haskell2010+--   default-extensions: BangPatterns+--                     , DataKinds+--                     , DeriveDataTypeable+--                     , FlexibleContexts+--                     , GADTs+--                     , MultiParamTypeClasses+--                     , OverloadedStrings+--                     , QuasiQuotes+--                     , RecordWildCards+--                     , TemplateHaskell+--                     , TypeFamilies+--                     , TypeOperators+--   ghc-options:+--     -O2+--     -funbox-strict-fields++-- executable AffineEditNewickTrees+--   if flag(examples)+--     buildable:+--       True+--     build-depends: base+--                  , cmdargs                >= 0.10+--                  , containers+--                  , filepath+--                  , log-domain             >= 0.10+--                  , text+--                  , vector+--                  --+--                  , ADPfusion+--                  , ADPfusionForest+--                  , BiobaseNewick          >= 0.0.0.1+--                  , ForestStructures+--                  , FormalGrammars         >= 0.3+--                  , PrimitiveArray+--                  , PrimitiveArray-Pretty  >= 0.0+--   else+--     buildable:+--       False+--   hs-source-dirs:+--     src+--   main-is:+--     AffineEditNewickTrees.hs+--   default-language:+--     Haskell2010+--   default-extensions: BangPatterns+--                     , DataKinds+--                     , DeriveDataTypeable+--                     , FlexibleContexts+--                     , GADTs+--                     , MultiParamTypeClasses+--                     , OverloadedStrings+--                     , QuasiQuotes+--                     , RecordWildCards+--                     , TemplateHaskell+--                     , TypeFamilies+--                     , TypeOperators+--   ghc-options:+--     -O2+--     -funbox-strict-fields++++-- executable EditNew+--   if flag(examples)+--     buildable:+--       True+--     build-depends: base+--                  , cmdargs                >= 0.10+--                  , containers+--                  , filepath+--                  , log-domain             >= 0.10+--                  , text+--                  , vector+--                  --+--                  , ADPfusion+--                  , ADPfusionForest+--                  , BiobaseNewick          >= 0.0.0.1+--                  , ForestStructures+--                  , FormalGrammars         >= 0.3+--                  , PrimitiveArray+--                  , PrimitiveArray-Pretty  >= 0.0+--   else+--     buildable:+--       False+--   hs-source-dirs:+--     src+--   main-is:+--     EditNew.hs+--   default-language:+--     Haskell2010+--   default-extensions: BangPatterns+--                     , DataKinds+--                     , DeriveDataTypeable+--                     , FlexibleContexts+--                     , GADTs+--                     , MultiParamTypeClasses+--                     , OverloadedStrings+--                     , QuasiQuotes+--                     , RecordWildCards+--                     , TemplateHaskell+--                     , TypeFamilies+--                     , TypeOperators+--   ghc-options:+--     -O2+--     -funbox-strict-fields++++-- executable SingleEdit+--   if flag(examples)+--     buildable:+--       True+--     build-depends: base+--                  , cmdargs                >= 0.10+--                  , containers+--                  , filepath+--                  , log-domain             >= 0.10+--                  , text+--                  , vector+--                  --+--                  , ADPfusion+--                  , ADPfusionForest+--                  , BiobaseNewick          >= 0.0.0.1+--                  , ForestStructures+--                  , FormalGrammars         >= 0.3+--                  , PrimitiveArray+--                  , PrimitiveArray-Pretty  >= 0.0+--   else+--     buildable:+--       False+--   hs-source-dirs:+--     src+--   main-is:+--     SingleEdit.hs+--   default-language:+--     Haskell2010+--   default-extensions: BangPatterns+--                     , DataKinds+--                     , DeriveDataTypeable+--                     , FlexibleContexts+--                     , GADTs+--                     , MultiParamTypeClasses+--                     , OverloadedStrings+--                     , QuasiQuotes+--                     , RecordWildCards+--                     , TemplateHaskell+--                     , TypeFamilies+--                     , TypeOperators+--   ghc-options:+--     -O2+--     -funbox-strict-fields++++test-suite properties+  type:+    exitcode-stdio-1.0+  main-is:+    properties.hs+  ghc-options:+    -threaded -rtsopts -with-rtsopts=-N -O2 -funbox-strict-fields+  hs-source-dirs:+    tests+  default-language:+    Haskell2010+  default-extensions: BangPatterns+  build-depends: base+               , QuickCheck+               , tasty              >= 0.11+               , tasty-quickcheck   >= 0.8+               , tasty-th           >= 0.1+               --+               , ADPfusionForest++++benchmark benchmark+  build-depends:  base+               ,  criterion   >=  1.0.2+               ,  ForestStructures+  default-language:+    Haskell2010+  hs-source-dirs:+    tests+  main-is:+    benchmark.hs+  type:+    exitcode-stdio-1.0+  ghc-options:+    -O2++++source-repository head+  type: git+  location: git://github.com/choener/ADPfusionForest+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Christian Hoener zu Siederdissen 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Christian Hoener zu Siederdissen nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,18 @@+[![Build Status](https://travis-ci.org/choener/ADPfusionForest.svg?branch=master)](https://travis-ci.org/choener/ADPfusionForest)++# ADPfusionForest: Dynamic and static tree and forest structures++This library extents ADPfusion to accept input in the form of trees and+forests.++WARNING: Building with examples will leading to somewhat long compilation+times.+++#### Contact++Christian Hoener zu Siederdissen  +Leipzig University, Leipzig, Germany  +choener@bioinf.uni-leipzig.de  +http://www.bioinf.uni-leipzig.de/~choener/  +
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,6 @@+0.0.0.1+-------++- initial checkin+- stack.yaml file+
+ examples/t1.nwk view
@@ -0,0 +1,1 @@+(((a,f)x,(a,e,f)w)t,((a,f)v,(g,h)u)s)r;
+ examples/t2.nwk view
@@ -0,0 +1,1 @@+(((a,b,c),(d,e,f)),(g,h))r;
+ src/AffineAlignNewickTreesSmall.hs view
@@ -0,0 +1,387 @@++module Main where++import           Control.Monad(forM_,unless)+import           Data.Char (toLower)+import           Data.List (nub,tails)+import           Data.List (sortBy)+import           Data.Ord (comparing)+import           Data.Vector.Fusion.Util+import           Debug.Trace+import           Numeric.Log+import qualified Data.Text as Text+import qualified Data.Tree as T+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import           System.Console.CmdArgs+import           System.Exit (exitFailure)+import           System.FilePath+import           Text.Printf+import           Unsafe.Coerce++import           ADP.Fusion.Core+import           Biobase.Newick+import           Data.Forest.Static (TreeOrder(..),Forest)+import           Data.PrimitiveArray as PA hiding (map)+import qualified Diagrams.TwoD.ProbabilityGrid as PG+import           FormalLanguage.CFG+import qualified Data.Forest.Static as F++import           ADP.Fusion.Forest.Align.RL++++[formalLanguage|+Verbose++Grammar: Global+N: T -- tree+N: F -- forest+N: Z -- tree for gaps+N: Q -- sibling gap mode+N: R -- parent gap mode+N: E+T: n+S: [F,F]+[F,F] -> iter    <<< [T,T] [F,F]+[F,F] -> fgap    <<< [T,Z] [Q,Q]+[F,F] -> fgap    <<< [Z,T] [Q,Q]+[Z,T] -> indel   <<< [-,n] [R,R]+[T,Z] -> delin   <<< [n,-] [R,R]+[T,T] -> align   <<< [n,n] [F,F]+[F,F] -> done    <<< [E,E]+[R,R] -> done    <<< [E,E]+[R,R] -> pgap <<< [T,T] [R,R]+[R,R] -> pgap <<< [T,Z] [R,R]+[R,R] -> pgap <<< [Z,T] [R,R]+[Q,Q] -> done    <<< [E,E]+[Q,Q] -> siter <<< [T,T] [F,F]+[Q,Q] -> sgap <<< [T,Z] [Q,Q]+[Q,Q] -> sgap <<< [Z,T] [Q,Q]+[E,E] -> finalDone <<< [e,e]+//+Outside: Labolg+Source: Global+//++Emit: Global+Emit: Labolg+|]++makeAlgebraProduct ''SigGlobal++resig :: Monad m => SigGlobal m a b c d -> SigLabolg m a b c d+resig (SigGlobal gdo git gsi gal gin gde gfg gpg gsg gfi gh) = SigLabolg gdo git gsi gal gin gde gfg gpg gsg gfi gh+{-# Inline resig #-}+++score :: Monad m => Int -> Int -> Int -> Int -> SigGlobal m Int Int Info Info+score matchSc notmatchSc delinSc affinSc = SigGlobal -- match affine deletion +  { gDone  = \ f -> f --  (Z:.():.()) -> 0 -- traceShow "EEEEEEEEEEEEE" 0+  , gFinalDone  = \ (Z:.():.()) -> 0 -- traceShow "EEEEEEEEEEEEE" 0+  , gIter  = \ t f -> t+f+  , gSiter  = \ t f -> t+f+  , gAlign = \ (Z:.c:.b) f -> tSI glb ("ALIGN",f,c,b) $ f + if label c == label b then matchSc else notmatchSc+  , gIndel = \ (Z:.():.b) f -> tSI glb ("INDEL",f,b) $ f+  , gDelin = \ (Z:.c:.()) f -> tSI glb ("DELIN",f,c) $ f+  , gFgap = \ t f -> tSI glb ("gap",f+t,delinSc) $ t + f + delinSc --gap open+  , gPgap = \ t f -> tSI glb ("gap",f+t,affinSc) $ t + f + affinSc --gap extension+  , gSgap = \ t f -> tSI glb ("gap",f+t,affinSc) $ t + f + affinSc --gap extension+  , gH     = SM.foldl' max (-88888)+  }+{-# Inline score #-}++part :: Monad m => Log Double -> Log Double -> Log Double -> Log Double -> Log Double -> SigGlobal m (Log Double) (Log Double) Info Info+part matchSc mismatchSc delinSc affinSc temp = SigGlobal+  { gDone  = \ f -> f +  , gIter  = \ t f -> tSI glb ("TFTFTFTFTF",t,f) $ t * f+  , gFinalDone  = \ (Z:.():.()) -> 1+  , gSiter  = \ t f -> tSI glb ("TFTFTFTFTF",t,f) $ t * f+  , gAlign = \ (Z:.a:.b) f -> tSI glb ("ALIGN",f,a,b) $ f * if label a == label b then matchSc else mismatchSc+  , gIndel = \ (Z:.():.b) f -> tSI glb ("INDEL",f,b) $ f+  , gDelin = \ (Z:.a:.()) f -> tSI glb ("DELIN",f,a) $ f+  , gFgap = \ t f -> t * f * delinSc+  , gPgap = \ t f -> t * f * affinSc+  , gSgap = \ t f -> t * f * affinSc+  , gH     = SM.foldl' (+) 0.000000+  }+{-# Inline part #-}++++type Pretty' = [[T.Tree (Info,Info)]]+pretty' :: Monad m => SigGlobal m [T.Tree (Info,Info)] [[T.Tree ((Info,Info))]] Info Info+pretty' = SigGlobal+  { gDone  = \ f -> f -- (Z:.():.()) -> []+  , gFinalDone  = \ (Z:.():.()) -> []+  , gIter  = \ t f -> t++f+  , gSiter  = \ t f -> t++f+  , gAlign = \ (Z:.a:.b) f -> [T.Node (a,b) f]+  , gIndel = \ (Z:.():.b) f -> [T.Node (Info "-" 0,b) f]+  , gDelin = \ (Z:.a:.()) f -> [T.Node (a,Info "-" 0) f]+  , gPgap = \ t f -> t ++ f+  , gSgap = \ t f -> t ++ f+  , gFgap = \ t f -> t ++ f+  , gH     = SM.toList+  }+{-# Inline pretty' #-}++++type Trix = TreeIxR Pre V.Vector Info I+type Tbl x = TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Trix:.Trix) x+type Frst = Forest Pre V.Vector Info+type TblBt x = TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Trix:.Trix) Int Id Id [x]+type B = T.Tree (Info,Info)+++-- | likelihood part+--+--NOTE for an explanation which ITbl gets @0@ or @1@ check @runInside@,+--they have the same order requirements.++runForward :: Frst -> Frst -> Int -> Int -> Int -> Int -> Z:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int+runForward f1 f2 matchSc notmatchSc delinSc affinSc = let+                         in+                           mutateTablesST $+                           gGlobal (score matchSc notmatchSc delinSc affinSc) -- costs+                           (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                           (ITbl 1 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                           (ITbl 1 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                           (ITbl 1 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                           (ITbl 1 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                           (ITbl 1 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                           (ITbl 1 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                           (node NTany $ F.label f1)+                           (node NTany $ F.label f2)+{-# NoInline runForward #-}+++-- |inside part+--+-- NOTE : Each @ITbl@ has a big-order (1st index) and a little-order index.+-- We need these indices because we operate on unboxed tables internally+-- for efficiency reasons.+--+-- The big-order index is for full table calculations. All @ITbl@s with+-- smaller "big order" are fully calculated before any @ITbl@s with larger+-- big orders.+--+-- The little-order influences per-cell calculations. Cells with the same+-- index are sorted by order and those with a smaller index calculated+-- first.+--+-- For this calculation we have the following:+--+-- @EE@ has only one rule: @EE -> ε@, the full table is filled before any+-- other table and has big order @0@.+--+-- Now, we only have tables with big order @1@ left.+--+-- @TT@, @TZ@, and @ZT@ have only rules that each have at least one+-- non-empty terminal in play. @TZ@ for example has @TZ -> [n,-] RR@.+-- They are executed first for a given index, because they are guaranteed+-- to get "smaller" during recursion. Hence little order @0@.+--+-- Finally, @FF@, @QQ@, @RR@ all combine *only* syntactic symbols on the+-- right-hand side. In addition these symbols can be empty. They need to+-- come last and have little order @1@.++runInside :: Frst -> Frst -> Log Double -> Log Double -> Log Double -> Log Double -> Log Double -> Z:.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double)+runInside f1 f2 matchSc notmatchSc delinSc affinSc temperature = let+                         in+                           mutateTablesDefault $+                           gGlobal (part matchSc notmatchSc delinSc affinSc temperature) -- costs+                           (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))   -- EE+                           (ITbl 1 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))   -- FF+                           (ITbl 1 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))   -- QQ+                           (ITbl 1 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))   -- RR+                           (ITbl 1 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))   -- TT+                           (ITbl 1 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))   -- TZ+                           (ITbl 1 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))   -- ZT+                           (node NTany $ F.label f1)+                           (node NTany $ F.label f2)+{-# NoInline runInside #-}++++-- outside part+type Trox = TreeIxR Pre V.Vector Info O+type OTbl x = TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Trox:.Trox) x++-- | Actual outside calculations.+--+-- NOTE: The big and little order indices are reversed compared to+-- @runInside@. We need to evaluate the tables outside in now.++runOutside :: Frst -> Frst -> Log Double -> Log Double -> Log Double -> Log Double -> Log Double -> Z:.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double) -> Z:.OTbl (Log Double):.OTbl (Log Double):.OTbl (Log Double):.OTbl (Log Double):.OTbl (Log Double):.OTbl (Log Double):.OTbl (Log Double)+runOutside f1 f2 matchSc mismatchSc indelSc affinSc temperature (Z:.iE:.iF:.iQ:.iR:.iT:.iS:.iZ)+  = mutateTablesDefault $+    gLabolg (resig (part matchSc mismatchSc indelSc affinSc temperature))+    (ITbl 1 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    iF+    iQ+    iR+    iT+    iS+    iZ+    (node NTany $ F.label f1)+    (node NTany $ F.label f2)+{-# NoInline runOutside #-}++++-- inside part+run :: Frst -> Frst -> Int -> Int -> Int -> Int -> (Z:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int:.Tbl Int,Int,Pretty')+run f1 f2 matchSc notmatchSc delinSc affinSc = (fwd,unId $ axiom a2, unId $ axiom b2)+  where fwd@(Z:.a1:.a2:.a3:.a4:.a5:.a6:.a7) = runForward f1 f2 matchSc notmatchSc delinSc affinSc+        Z:.b1:.b2:.b3:.b4:.b5:.b6:.b7 +                    = gGlobal ((score matchSc notmatchSc delinSc affinSc) <|| pretty') +                    (toBacktrack a1 (undefined :: Id a -> Id a)) +                    (toBacktrack a2 (undefined :: Id a -> Id a))  +                    (toBacktrack a3 (undefined :: Id a -> Id a))  +                    (toBacktrack a4 (undefined :: Id a -> Id a))  +                    (toBacktrack a5 (undefined :: Id a -> Id a))  +                    (toBacktrack a6 (undefined :: Id a -> Id a))  +                    (toBacktrack a7 (undefined :: Id a -> Id a))  +                    (node NTany $ F.label f1) (node NTany $ F.label f2)+                    :: Z:.TblBt B:.TblBt B:.TblBt B:.TblBt B:.TblBt B:.TblBt B:.TblBt B+{-# NoInline run #-}++++-- outside part++runIO f1 f2 matchSc mismatchSc indelSc affinSc temperature = (fwd,out,unId $ axiom f)+  where fwd@(Z:.e:.f:.q:.r:.t:.s:.z) = runInside f1 f2 matchSc mismatchSc indelSc affinSc temperature+        out@(Z:.oet:.oft:.oqt:.ort:.ott:.ost:.ozt) = runOutside f1 f2 matchSc mismatchSc indelSc affinSc temperature fwd+{-# NoInline runIO #-}++--         a            a+--        / \          / \+--       e   d        b   f+--      / \              / \+--     b   c            c   d+--+--                  (a,a)                 100+--              /          \+--         (e,-)            (-,f)         (-3) (-5)+--        /     \          /     \+--   (b,b)       (c,-) (-,c)      (d,d)   100  (-3) (-5) 100+--+--+--+--             (a,a)                          100+--            /     \+--       (e,-)       (d,-)                    (-3) (-3)+--      /     \+-- (b,b)       (-,f)                          100  (-5)+--            /     \+--       (c,c)       (-,d)                    100  (-5)++-- all new from here++data PFT = SVG | EPS+  deriving (Show,Data,Typeable)++data Options = Options+  { inputFiles  :: [String]+  , probFile    :: String+  , probFileTy  :: PFT+  , linearScale :: Bool+  , matchSc     :: Double+  , notmatchSc  :: Double+  , delinSc     :: Double+  , affinSc     :: Double+  , temperature :: Double+  }+  deriving (Show,Data,Typeable)++oOptions = Options+  { inputFiles  = def &= args+  , probFile    = def &= help "probability file prefix" -- &= explicit &= name "probfile" &= name "p" --to not guessing names +  , probFileTy  = EPS &= help "svg, eps; def=eps "+  , linearScale = False &= help "use linear, not logarithmic scaling; def=false"+  , matchSc     = 10   &= help "score for match cases, positive number; def=10"+  , notmatchSc  = -30 &= help "score for mismatches, negative number; def=-30"+  , delinSc     = -10 &= help "score for deletions and insertions, negative number; def=-10"+  , affinSc     = -1 &= help "score for affine gap costs, negative number; def=-1"+  , temperature = 0.1 &= help "'temperature', strict (0.001) to less strict (0.99); def=0.1"+  }++main :: IO ()+main = do+  o@Options{..} <- cmdArgs oOptions+  unless (length inputFiles >= 2) $ do+    putStrLn "give at least two Newick files on the command line"+    exitFailure+  let ts = init $ init $ tails inputFiles+      f z = Exp $ z/temperature +  forM_ ts $ \(n1:hs) -> do+    forM_ hs $ \n2 -> do+      putStrLn n1+      putStrLn n2+      f1 <- readFile n1+      f2 <- readFile n2+      runAlignS f1 f2 (round matchSc) (round notmatchSc) (round delinSc) (round affinSc)+      unless (null probFile) $ do+        runAlignIO (if linearScale then PG.FWlinear else PG.FWlog) probFileTy (probFile ++ "-" ++ takeBaseName n1 ++ "-" ++ takeBaseName n2 ++ "." ++ (map toLower $ show probFileTy)) f1 f2 (f matchSc) (f notmatchSc) (f delinSc) (f affinSc) (Exp temperature)+++test n1 n2 = do+  f1 <- readFile n1+  f2 <- readFile n2+  runAlignS f1 f2 10 (-30) (-10) (-1)+{-# NoInline test #-}++runAlignS t1' t2' matchSc notmatchSc delinSc affinSc = do+  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x+      t1 = f $ Text.pack t1'+      t2 = f $ Text.pack t2'+  let (fwd,sc,bt') = run t1 t2 matchSc notmatchSc delinSc affinSc+  let (Z:.TW (ITbl _ _ _ iet) _ :.TW (ITbl _ _ _ ift) _ :.TW (ITbl _ _ _ iqt) _ :.TW (ITbl _ _ _ irt) _ :.TW (ITbl _ _ _ itt) _ :.TW (ITbl _ _ _ ist) _ :.TW (ITbl _ _ _ izt) _) = fwd+  let bt = take 1 bt' -- nub bt'+  printf "Score: %10d\n" sc+--  forM_ bt $ \b -> do+--    putStrLn ""+--    forM_ b $ \x -> putStrLn $ T.drawTree $ fmap show x+{-# NoInline runAlignS #-}++runAlignIO fw probFileTy probFile t1' t2' matchSc mismatchSc indelSc affinSc temperature = do+  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x+      t1 = f $ Text.pack t1'+      t2 = f $ Text.pack t2'+  let (inn,out,_) = runIO t1 t2 matchSc mismatchSc indelSc affinSc temperature -- (t2 {F.lsib = VG.fromList [-1,-1], F.rsib = VG.fromList [-1,-1]})+  let (Z:.TW (ITbl _ _ _ iet) _ :.TW (ITbl _ _ _ ift) _ :.TW (ITbl _ _ _ iqt) _ :.TW (ITbl _ _ _ irt) _ :.TW (ITbl _ _ _ itt) _ :.TW (ITbl _ _ _ ist) _ :.TW (ITbl _ _ _ izt) _) = inn+  let (Z:.TW (ITbl _ _ _ iet) _ :.TW (ITbl _ _ _ oft) _ :.TW (ITbl _ _ _ oqt) _ :.TW (ITbl _ _ _ ort) _ :.TW (ITbl _ _ _ ott) _ :.TW (ITbl _ _ _ ost) _ :.TW (ITbl _ _ _ ozt) _) = out+  let (Z:.(TreeIxR frst1 lb1 _):.(TreeIxR frst2 lb2 _), Z:.(TreeIxR _ ub1 _):.(TreeIxR _ ub2 _)) = bounds oft+  let ix = (Z:.TreeIxR frst1 lb1 F:.TreeIxR frst2 lb2 F)+  let sc = ift ! ix+  print sc+  let ps = map (\(k,k1,k2) ->+            let k' = unsafeCoerce k+            in  ( k1+                , k2+                , ((itt!k) * (ott!k') / sc)+                , (maybe "-" label $ F.label t1 VG.!? k1)+                , (maybe "-" label $ F.label t2 VG.!? k2)+                )) [ (Z:.TreeIxR frst1 k1 T:.TreeIxR frst2 k2 T,k1,k2) | k1 <- [lb1 .. ub1 - 1], k2 <- [lb2 .. ub2 - 1] ]+  --+  let gsc = map (\(k1,k2,sc,l1,l2) -> sc) ps+  let fillText [] = " "+      fillText xs = xs+  mapM_ print gsc+  let gl1 = map (\k1 -> fillText . Text.unpack $ (maybe "-" label $ F.label t1 VG.!? k1)) [lb1 .. ub1 - 1]+  let gl2 = map (\k2 -> fillText . Text.unpack $ (maybe "-" label $ F.label t2 VG.!? k2)) [lb2 .. ub2 - 1]+  case probFileTy of+         SVG -> PG.svgGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc+         EPS -> PG.epsGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc+{-# NoInline runAlignIO #-}+
+ src/AlignNewickTrees.hs view
@@ -0,0 +1,286 @@++module Main where++import           Control.Monad(forM_, unless)+import           Data.Char (toLower)+import           Data.List (nub, tails)+import           Data.List (sortBy)+import           Data.Ord (comparing)+import           Data.Vector.Fusion.Util+import           Debug.Trace+import           Numeric.Log+import qualified Data.Text as Text+import qualified Data.Tree as T+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import           System.Console.CmdArgs+import           System.Exit (exitFailure)+import           System.FilePath+import           Text.Printf+import           Unsafe.Coerce++import           ADP.Fusion.Core+import           Biobase.Newick+import           Data.Forest.Static (TreeOrder(..),Forest)+import           Data.PrimitiveArray as PA hiding (map)+import qualified Diagrams.TwoD.ProbabilityGrid as PG+import           FormalLanguage.CFG+import qualified Data.Forest.Static as F++import           ADP.Fusion.Forest.Align.RL++++[formalLanguage|+Verbose++Grammar: Global+N: T+N: F+N: M+T: n+S: [F,F]+[F,F] -> iter  <<< [T,T] [F,F]+[F,F] -> iter  <<< [M,M] [F,F]+[T,T] -> indel <<< [-,n] [F,F]+[T,T] -> delin <<< [n,-] [F,F]+[M,M] -> align <<< [n,n] [F,F]+[F,F] -> done  <<< [e,e]+//+Outside: Labolg+Source: Global+//++Emit: Global+Emit: Labolg+|]++makeAlgebraProduct ''SigGlobal++resig :: Monad m => SigGlobal m a b c d -> SigLabolg m a b c d+resig (SigGlobal gdo git gal gin gde gh) = SigLabolg gdo git gal gin gde gh+{-# Inline resig #-}++score :: Monad m => Int -> Int -> Int -> SigGlobal m Int Int Info Info+score matchSc notmatchSc delinSc = SigGlobal+  { gDone  = \ (Z:.():.()) -> 0 -- traceShow "EEEEEEEEEEEEE" 0+  , gIter  = \ t f -> tSI glb ("TFTFTFTFTF",t,f) $ t+f+  , gAlign = \ (Z:.a:.b) f -> tSI glb ("ALIGN",f,a,b) $ f + if label a == label b then matchSc else notmatchSc+  , gIndel = \ (Z:.():.b) f -> tSI glb ("INDEL",f,b) $ f + delinSc+  , gDelin = \ (Z:.a:.()) f -> tSI glb ("DELIN",f,a) $ f + delinSc+  , gH     = SM.foldl' max (-88888)+  }+{-# Inline score #-}++part :: Monad m => Log Double -> Log Double -> Log Double -> Log Double -> SigGlobal m (Log Double) (Log Double) Info Info+part matchSc mismatchSc indelSc temp = SigGlobal+  { gDone  = \ (Z:.():.()) -> 1+  , gIter  = \ t f -> tSI glb ("TFTFTFTFTF",t,f) $ t * f+  , gAlign = \ (Z:.a:.b) f -> tSI glb ("ALIGN",f,a,b) $ f * if label a == label b then matchSc else mismatchSc+  , gIndel = \ (Z:.():.b) f -> tSI glb ("INDEL",f,b) $ f * indelSc --exp(-indelSc/temp)+  , gDelin = \ (Z:.a:.()) f -> tSI glb ("DELIN",f,a) $ f * indelSc --exp(-indelSc/temp)+  , gH     = SM.foldl' (+) 0.0000001+  }+{-# Inline part #-}++type Pretty = [[T.Tree (Info,Info)]]+pretty :: Monad m => SigGlobal m [T.Tree (Info,Info)] [[T.Tree ((Info,Info))]] Info Info+pretty = SigGlobal+  { gDone  = \ (Z:.():.()) -> []+  , gIter  = \ t f -> t++f+  , gAlign = \ (Z:.a:.b) f -> [T.Node (a,b) f]+  , gIndel = \ (Z:.():.b) f -> [T.Node (Info "-" 0,b) f]+  , gDelin = \ (Z:.a:.()) f -> [T.Node (a,Info "-" 0) f]+  , gH     = SM.toList+  }+{-# Inline pretty #-}++++type Trix = TreeIxR Pre V.Vector Info I+type Tbl x = TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Trix:.Trix) x+type Frst = Forest Pre V.Vector Info+type TblBt x = TwITblBt Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Trix:.Trix) Int Id Id [x]+type B = T.Tree (Info,Info)++runForward :: Frst -> Frst -> Int -> Int -> Int -> Z:.Tbl Int :.Tbl Int:.Tbl Int+runForward f1 f2 matchSc notmatchSc delinSc = mutateTablesDefault $+                   gGlobal (score matchSc notmatchSc delinSc)+                   (ITbl 0 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (-99999) [] ))+                   (node NTany $ F.label f1)+                   (node NTany $ F.label f2)+{-# NoInline runForward #-}++runInside :: Frst -> Frst -> Log Double -> Log Double -> Log Double -> Log Double -> Z:.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double)+runInside f1 f2 matchSc mismatchSc indelSc temperature = mutateTablesDefault $+                   gGlobal (part matchSc mismatchSc indelSc temperature)+                   (ITbl 0 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+                   (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+                   (node NTany $ F.label f1)+                   (node NTany $ F.label f2)+{-# NoInline runInside #-}++type Trox = TreeIxR Pre V.Vector Info O+type OTbl x = TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.Trox:.Trox) x++runOutside :: Frst -> Frst -> Log Double -> Log Double -> Log Double -> Log Double -> Z:.Tbl (Log Double):.Tbl (Log Double):.Tbl (Log Double) -> Z:.OTbl (Log Double):.OTbl (Log Double):.OTbl (Log Double)+runOutside f1 f2 matchSc mismatchSc indelSc temperature (Z:.iF:.iM:.iT)+  = mutateTablesDefault $+    gLabolg (resig (part matchSc mismatchSc indelSc temperature))+    (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    (ITbl 0 1 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.minIx f1:.minIx f2) (Z:.maxIx f1:.maxIx f2) (0) [] ))+    iF+    iM+    iT+    (node NTany $ F.label f1)+    (node NTany $ F.label f2)+{-# NoInline runOutside #-}++runS :: Frst -> Frst -> Int -> Int -> Int -> (Z:.Tbl Int :.Tbl Int:.Tbl Int, Int ,[[T.Tree (Info, Info)]] )+runS f1 f2 matchSc notmatchSc delinSc = (fwd,unId $ axiom f, unId $ axiom fb)+  where fwd@(Z:.f:.m:.t) = runForward f1 f2 matchSc notmatchSc delinSc+        Z:.fb:.fm:.tb = gGlobal ((score matchSc notmatchSc delinSc) <|| pretty) (toBacktrack f (undefined :: Id a -> Id a)) (toBacktrack m (undefined :: Id a -> Id a)) (toBacktrack t (undefined :: Id a -> Id a))+                        (node NTany $ F.label f1) (node NTany $ F.label f2)+                        :: Z:.TblBt B:.TblBt B:.TblBt B++runIO f1 f2 matchSc mismatchSc indelSc temperature = (fwd,out,unId $ axiom f)+  where fwd@(Z:.f:.m:.t) = runInside f1 f2 matchSc mismatchSc indelSc temperature+        out@(Z:.oft:.omt:.ott) = runOutside f1 f2 matchSc mismatchSc indelSc temperature fwd+++--         a            a+--        / \          / \+--       e   d        b   f+--      / \              / \+--     b   c            c   d+--+--                  (a,a)                 100+--              /          \+--         (e,-)            (-,f)         (-3) (-5)+--        /     \          /     \+--   (b,b)       (c,-) (-,c)      (d,d)   100  (-3) (-5) 100+--+--+--+--             (a,a)                          100+--            /     \+--       (e,-)       (d,-)                    (-3) (-3)+--      /     \+-- (b,b)       (-,f)                          100  (-5)+--            /     \+--       (c,c)       (-,d)                    100  (-5)++t11 = "a;"+t12 = "a;"+t21 = "(b,c)a;"+t22 = "(b,c)a;"+t31 = "((d,e,f)b,(z)c)a;"  --+t32 = "(((d,e)y,f)b,(c,(x)i)g)a;"  --+t41 = "d;(b)e;" -- (b,c)e;"    -- '-3'+t42 = "(d)f;b;" -- b;"+t51 = "(b:1,c:1)a:1;"+t52 = "b:2;c:2;"+t61 = "((b,c)e,d)a;"+t62 = "(b,(c,d)f)a;"+t71 = "(b)a;"+t72 = "(b)a;"++data PFT = SVG | EPS+  deriving (Show,Data,Typeable)++data Options = Options+  { inputFiles  :: [String]+  , probFile    :: String+  , probFileTy  :: PFT+  , linearScale :: Bool+  , matchSc     :: Double+  , notmatchSc  :: Double+  , delinSc     :: Double+  , temperature :: Double+  }+  deriving (Show,Data,Typeable)++oOptions = Options+  { inputFiles  = def &= args+  , probFile    = def &= help "probability file prefix" -- &= explicit &= name "probfile" &= name "p" --to not guessing names +  , probFileTy  = EPS &= help "svg, eps; def=eps"+  , linearScale = False &= help "use linear, not logarithmic scaling; def=false"+  , matchSc     = 10  &= help "score for match cases, positive number; def=10"+  , notmatchSc  = -30 &= help "score for mismatches, negative number; def=-30"+  , delinSc     = -10 &= help "score for deletions and insertions, negative number; def=-10"+  , temperature = 0.1 &= help "'temperature', strict (0.001) to less strict (0.99); def=0.1"+  }++main :: IO ()+main = do+  o@Options{..} <- cmdArgs oOptions+  unless (length inputFiles >= 2) $ do+    putStrLn "give at least two Newick files on the command line"+    exitFailure+  let ts = init $ init $ tails inputFiles+      f z = Exp $ z/temperature +  forM_ ts $ \(n1:hs) -> do+    forM_ hs $ \n2 -> do+      putStrLn n1+      putStrLn n2+      f1 <- readFile n1+      f2 <- readFile n2+      runAlignS f1 f2 (round matchSc) (round notmatchSc) (round delinSc)+      unless (null probFile) $ do+        runAlignIO (if linearScale then PG.FWlinear else PG.FWlog) probFileTy (probFile ++ "-" ++ takeBaseName n1 ++ "-" ++ takeBaseName n2 ++ "." ++ (map toLower $ show probFileTy)) f1 f2 (f matchSc) (f notmatchSc) (f delinSc) (Exp temperature)+++++runAlignS t1' t2' matchSc notmatchSc delinSc = do+  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x+      t1 = f $ Text.pack t1'+      t2 = f $ Text.pack t2'+  let (fwd,sc,bt') = runS t1 t2 matchSc notmatchSc delinSc+  let (Z:.TW (ITbl _ _ _ ift) _ :. TW (ITbl _ _ _ imt) _ :. TW (ITbl _ _ _ itt) _) = fwd+  let bt = take 1 bt' -- TODO make nice !!! nub bt'+  printf "Score: %10d\n" sc+  forM_ bt $ \b -> do+    putStrLn ""+    forM_ b $ \x -> putStrLn $ T.drawTree $ fmap show x++runAlignIO fw probFileTy probFile t1' t2' matchSc mismatchSc indelSc temperature = do+  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x+      t1 = f $ Text.pack t1'+      t2 = f $ Text.pack t2'+  let (inn,out,_) = runIO t1 t2 matchSc mismatchSc indelSc temperature -- (t2 {F.lsib = VG.fromList [-1,-1], F.rsib = VG.fromList [-1,-1]})+  let (Z:.TW (ITbl _ _ _ ift) _ :. TW (ITbl _ _ _ imt) _ :. TW (ITbl _ _ _ itt) _) = inn+  let (Z:.TW (ITbl _ _ _ oft) _ :. TW (ITbl _ _ _ omt) _ :. TW (ITbl _ _ _ ott) _) = out+  let (Z:.(TreeIxR frst1 lb1 _):.(TreeIxR frst2 lb2 _), Z:.(TreeIxR _ ub1 _):.(TreeIxR _ ub2 _)) = bounds oft+  let ix = (Z:.TreeIxR frst1 lb1 F:.TreeIxR frst2 lb2 F)+  let scift = ift ! ix+  print scift+  let scoft = Prelude.sum [ oft ! (Z:.TreeIxR frst1 b1 F :. TreeIxR frst2 b2 F) | b1 <- [lb1 .. ub1], b2 <- [lb2 .. ub2] ]+  print scoft+  let scimt = Prelude.sum [ imt ! (Z:.TreeIxR frst1 b1 T :. TreeIxR frst2 b2 T) | b1 <- [lb1 .. ub1], b2 <- [lb2 .. ub2] ]+  print scimt+  let scomt = Prelude.sum [ omt ! (Z:.TreeIxR frst1 b1 T :. TreeIxR frst2 b2 T) | b1 <- [lb1 .. ub1], b2 <- [lb2 .. ub2] ]+  print scomt+  let ps = map (\(k,k1,k2) ->+            let k' = unsafeCoerce k+            in  ( k1+                , k2+                , ((imt!k) * (omt!k') / scift)+                , (maybe "-" label $ F.label t1 VG.!? k1)+                , (maybe "-" label $ F.label t2 VG.!? k2)+                )) [ (Z:.TreeIxR frst1 k1 T:.TreeIxR frst2 k2 T,k1,k2) | k1 <- [lb1 .. ub1 - 1], k2 <- [lb2 .. ub2 - 1] ]+  --+  let gsc = map (\(k1,k2,sc,l1,l2) -> sc) ps+  let fillText [] = " "+      fillText xs = xs+  let gl1 = map (\k1 -> fillText . Text.unpack $ (maybe "-" label $ F.label t1 VG.!? k1)) [lb1 .. ub1 - 1]+  let gl2 = map (\k2 -> fillText . Text.unpack $ (maybe "-" label $ F.label t2 VG.!? k2)) [lb2 .. ub2 - 1]+  case probFileTy of+         SVG -> PG.svgGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc+         EPS -> PG.epsGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc+
+ stack.yaml view
@@ -0,0 +1,25 @@+resolver: lts-5.2++packages:+- '.'++extra-deps:+- ADPfusion-0.5.1.0+- BiobaseNewick-0.0.0.1+- cereal-text-0.1.0.1+- ForestStructures-0.0.0.1+- FormalGrammars-0.3.0.0+- GrammarProducts-0.1.1.2+- hybrid-vectors-0.2.1+- OneTuple-0.2.1+- OrderedBits-0.0.1.0+- PrimitiveArray-0.7.0.1+- PrimitiveArray-Pretty-0.0.0.1+- tuple-0.3.0.2++flags:+  ADPfusionForest:+    examples: true++extra-package-dbs: []+
+ tests/benchmark.hs view
@@ -0,0 +1,8 @@++module Main where++++main :: IO ()+main = return ()+
+ tests/properties.hs view
@@ -0,0 +1,8 @@++module Main where++++main :: IO ()+main = return ()+