ADPfusionSet (empty) → 0.0.0.1

raw patch · 22 files changed

+1421/−0 lines, 22 filesdep +ADPfusiondep +ADPfusionSetdep +DPutilssetup-changed

Dependencies added: ADPfusion, ADPfusionSet, DPutils, OrderedBits, PrimitiveArray, QuickCheck, base, bits, containers, mmorph, mtl, primitive, smallcheck, strict, tasty, tasty-quickcheck, tasty-smallcheck, tasty-th, template-haskell, th-orphans, transformers, tuple, vector

Files

ADP/Fusion/Boundary.hs +3/−0
ADP/Fusion/Core/Boundary.hs +41/−0
ADP/Fusion/Core/EdgeBoundary.hs +56/−0
ADP/Fusion/Core/Set1.hs +82/−0
ADP/Fusion/EdgeBoundary.hs +11/−0
ADP/Fusion/Set1.hs +25/−0
ADP/Fusion/SynVar/Indices/Set1.hs +339/−0
ADP/Fusion/Term/Edge/EdgeBoundary.hs +50/−0
ADP/Fusion/Term/Edge/Set1.hs +116/−0
ADP/Fusion/Term/EdgeWithSet.hs +11/−0
ADP/Fusion/Term/EdgeWithSet/EdgeBoundary.hs +73/−0
ADP/Fusion/Term/EdgeWithSet/Set1.hs +121/−0
ADP/Fusion/Term/EdgeWithSet/Type.hs +38/−0
ADP/Fusion/Term/Epsilon/Set1.hs +74/−0
ADP/Fusion/Term/Singleton/Set1.hs +77/−0
ADP/Fusion/Term/Singleton/Type.hs +38/−0
ADPfusionSet.cabal +157/−0
LICENSE +30/−0
README.md +56/−0
Setup.hs +2/−0
changelog.md +7/−0
tests/properties.hs +14/−0

+ ADP/Fusion/Boundary.hs view

@@ -0,0 +1,3 @@++module ADP.Fusion.Boundary where+

+ ADP/Fusion/Core/Boundary.hs view

@@ -0,0 +1,41 @@++-- | Core structures for using 'Boundary' indices. These are isomorphic to+-- @Int@ but are to be used to indicate "boundary" elements in sets.+--+-- Immediate use is given, if one for example wants to extract posterior+-- scores for each possible endpoint in a set.++module ADP.Fusion.Core.Boundary where++import Data.Vector.Fusion.Stream.Monadic (singleton)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++instance RuleContext (Boundary i I) where+  type Context (Boundary i I) = InsideContext ()+  initialContext _ = IStatic ()+  {-# Inline initialContext #-}++newtype instance RunningIndex (Boundary i I) = RiBI (Boundary i I)++instance+  ( Monad m+  ) => MkStream m S (Boundary i I) where+  -- In case of @X -> ε@ or @X -> Singleton@, we have a static case here+  -- and allow the rule to succeed.+  -- TODO is this right? I don't think so+  mkStream S _ u k+    = singleton . ElmS . RiBI $ k+  {-# Inline mkStream #-}++instance TableStaticVar u c (Boundary i I) where+  tableStaticVar _ c _ _ = IVariable ()+  tableStreamIndex _ c _ z = z+  {-# Inline tableStaticVar #-}+  {-# Inline tableStreamIndex #-}+

+ ADP/Fusion/Core/EdgeBoundary.hs view

@@ -0,0 +1,56 @@++-- | ++module ADP.Fusion.Core.EdgeBoundary where++import Data.Vector.Fusion.Stream.Monadic (singleton)+import Data.Bits (zeroBits)++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++instance RuleContext (EdgeBoundary I) where+  type Context (EdgeBoundary I) = InsideContext Int+  initialContext _ = IStatic 0+  {-# Inline initialContext #-}++instance RuleContext (EdgeBoundary C) where+  type Context (EdgeBoundary C) = ExtComplementContext ()+  initialContext _ = CStatic ()+  {-# Inline initialContext #-}++data instance RunningIndex (EdgeBoundary I) = RiEBI !(BitSet I) !(EdgeBoundary I)++data instance RunningIndex (EdgeBoundary C) = RiEBC !(BitSet C) !(EdgeBoundary C)++instance+  ( Monad m+  ) => MkStream m S (EdgeBoundary I) where+  mkStream S _ u k+    = singleton . ElmS $ RiEBI zeroBits k+  {-# Inline mkStream #-}++instance+  ( Monad m+  ) => MkStream m S (EdgeBoundary C) where+  mkStream S _ u k+    = singleton . ElmS $ RiEBC zeroBits k+  {-# Inline mkStream #-}++instance TableStaticVar u c (EdgeBoundary I) where+  tableStaticVar _ c (IStatic   k) _ = IVariable k+  tableStaticVar _ c (IVariable k) _ = IVariable k+  tableStreamIndex _ c _ z = z+  {-# Inline tableStaticVar #-}+  {-# Inline tableStreamIndex #-}++instance TableStaticVar u c (EdgeBoundary C) where+  tableStaticVar _ _ comp _ = comp+  tableStreamIndex _ c _ z = z+  {-# Inline tableStaticVar #-}+  {-# Inline tableStreamIndex #-}+

+ ADP/Fusion/Core/Set1.hs view

@@ -0,0 +1,82 @@++-- | Bitsets @BS1 i@ are bitsets where one of the active bits is annotated+-- as the first or last bit that has been set. In principle, being first or+-- last is exchangeable, but is made explicit to allow for type-different+-- sets.++module ADP.Fusion.Core.Set1 where++import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (singleton,filter,enumFromStepN,map,unfoldr)+import Debug.Trace+import Prelude hiding (map,filter)+import Data.Bits+import Data.Bits.Ordered++import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++instance RuleContext (BS1 i I) where+  type Context (BS1 i I) = InsideContext Int+  initialContext _ = IStatic 0+  {-# Inline initialContext #-}++instance RuleContext (BS1 i O) where+  type Context (BS1 i O) = OutsideContext Int+  initialContext _ = OStatic 0+  {-# Inline initialContext #-}++newtype instance RunningIndex (BS1 i I) = RiBs1I (BS1 i I)++-- Only allow linear languages for now!++newtype instance RunningIndex (BS1 i O) = RiBs1O (BS1 i O)++instance+  ( Monad m+  ) => MkStream m S (BS1 i I) where+  -- In case of @X -> ε@ or @X -> Singleton@, we have a static case here+  -- and allow the rule to succeed.+  -- TODO is this right? I don't think so+  mkStream S (IStatic z) u sk@(BS1 s (Boundary k))+    = let pc = popCount s+      in  staticCheck (pc <= 1 && pc == z) . singleton . ElmS . RiBs1I $ sk+  --+  mkStream S (IVariable rp) u sk@(BS1 s (Boundary k))+    = staticCheck (popCount s >= rp) . singleton . ElmS . RiBs1I $ BS1 0 (Boundary $ -1)+  {-# Inline mkStream #-}++instance+  ( Monad m+  ) => MkStream m S (BS1 i O) where+  mkStream S (OStatic z) (BS1 uset (Boundary ubnd)) (BS1 cset (Boundary cbnd))+    = let pcc = popCount cset+          pcu = popCount uset+      in  staticCheck (pcu - pcc <= z && z <= 1) . singleton . ElmS . RiBs1O $ BS1 cset (Boundary cbnd)+  mkStream S (OFirstLeft z) (BS1 uset (Boundary ubnd)) (BS1 cset (Boundary cbnd))+    = let ------------V--- TODO ???+      in+#if ADPFUSION_DEBUGOUTPUT+          traceShow "O" .+#endif+          staticCheck True . singleton . ElmS . RiBs1O $ BS1 uset (Boundary $ -1)+  {-# Inline mkStream #-}++instance (MinSize c) => TableStaticVar u c (BS1 s I) where+  tableStaticVar _ c (IStatic   k) _ = IVariable $ k + minSize c+  tableStaticVar _ c (IVariable k) _ = IVariable $ k + minSize c+  tableStreamIndex _ c _ z = z+  {-# Inline tableStaticVar #-}+  {-# Inline tableStreamIndex #-}++instance (MinSize c) => TableStaticVar u c (BS1 s O) where+  tableStaticVar   _ _ (OStatic  d) _ = OFirstLeft d+  tableStaticVar   _ _ (ORightOf d) _ = OFirstLeft d+  tableStreamIndex _ c _ z = z+  {-# Inline tableStaticVar #-}+  {-# Inline tableStreamIndex #-}+

+ ADP/Fusion/EdgeBoundary.hs view

@@ -0,0 +1,11 @@++module ADP.Fusion.EdgeBoundary+  ( module ADP.Fusion.Core.EdgeBoundary+  , module ADP.Fusion.Term.Edge.EdgeBoundary+  , module ADP.Fusion.Term.Edge.Type+  ) where++import ADP.Fusion.Core.EdgeBoundary+import ADP.Fusion.Term.Edge.EdgeBoundary+import ADP.Fusion.Term.Edge.Type+

+ ADP/Fusion/Set1.hs view

@@ -0,0 +1,25 @@++-- |+--+-- TODO Import and re-export all required modules for sets with one+-- boundary node.++module ADP.Fusion.Set1+  ( module ADP.Fusion.Set1+  , module ADP.Fusion.Core.Set1+  , module ADP.Fusion.SynVar.Indices.Set1+  , module ADP.Fusion.Term.Edge.Set1+  , module ADP.Fusion.Term.EdgeWithSet+  , module ADP.Fusion.Term.Epsilon.Set1+  , module ADP.Fusion.Term.Singleton.Set1+  , module ADP.Fusion.Term.Singleton.Type+  ) where++import ADP.Fusion.Core.Set1+import ADP.Fusion.SynVar.Indices.Set1+import ADP.Fusion.Term.Edge.Set1+import ADP.Fusion.Term.EdgeWithSet+import ADP.Fusion.Term.Epsilon.Set1+import ADP.Fusion.Term.Singleton.Set1+import ADP.Fusion.Term.Singleton.Type+

+ ADP/Fusion/SynVar/Indices/Set1.hs view

@@ -0,0 +1,339 @@++module ADP.Fusion.SynVar.Indices.Set1 where++import Control.Exception (assert)+import Data.Proxy+import Data.Vector.Fusion.Stream.Monadic (map,Stream,head,mapM,Step(..))+import Data.Vector.Fusion.Util (delay_inline)+import Debug.Trace+import Prelude hiding (map,head,mapM)+import Data.Bits.Extras+import Data.Bits++import ADP.Fusion.Core+import ADP.Fusion.Core.Unit+import Data.Bits.Ordered+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Boundary+import ADP.Fusion.Core.EdgeBoundary+import ADP.Fusion.Core.Set1++++-- | Since there is only one boundary, it doesn't matter if @k==First@ or+-- @k==Last@. As a result, the "name" of the boundary is kept variable.+--+-- Given the outer (set,bnd) system, we try all boundaries α for+-- (set-bnd,α) for the smaller set @Y@ in @X -> Y e@.+--+-- TODO After this case we should only allow @S@, since we write, in+-- essence, left-linear grammars here.+--+-- TODO we should try to statically assure that @rb==0@ holds always in+-- this case. It should because every other symbol moves to @IVariable@+-- once the number of of reserved bits is @>0@.+--+-- TODO kind-of hacked and should be written in a better way++instance+  ( IndexHdr s x0 i0 us (BS1 k I) cs c is (BS1 k I)+  ) => AddIndexDense s (us:.BS1 k I) (cs:.c) (is:.BS1 k I) where+  -- This rule should only be active if we have @X -> Y@ rules. Neither @X+  -- -> Y Z@ nor @X -> e Y@ are possible in a left-linear grammar.+  addIndexDenseGo (cs:.c) (vs:.IStatic rb) (lbs:._) (ubs:._) (us:.BS1 uSet uBnd) (is:.BS1 set bnd)+    = map (\(SvS s t y') ->+        let RiBs1I (BS1 cset (Boundary to)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k I))+        in  assert (cset == 0 && to == (-1)) $ SvS s (t:.BS1 set bnd) (y' :.: RiBs1I (BS1 set bnd)))+    . addIndexDenseGo cs vs lbs ubs us is+    . assert (rb==0)+  -- Deal with @X -> Y e@ type rules.+  addIndexDenseGo (cs:.c) (vs:.IVariable rb) (lbs:._) (ubs:._) (us:.BS1 uSet uBnd) (is:.BS1 set bnd)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is . assert (rb==1) -- only works with one element+          -- Extract how many bits are already set -- should be zero (!) --+          -- and prepare the list of all possibilities.+          -- In addition, at least one bit should be reserved, hence+          -- @rb>0@. The boundary bit is one of those reserved and+          -- constitutes a mask to be used further down.+    where mk (SvS s t y') =+            let+            in  +#if ADPFUSION_DEBUGOUTPUT+                traceShow (set,bnd,rb) $+#endif+                return (SvS s t y', Just $ set `clearBit` getBoundary bnd)+          step (_, Nothing) = return Done+          step (SvS s t y', Just 0 ) = return $ Yield (SvS s (t:.BS1 0 0) (y':.:RiBs1I (BS1 0 0)))+                                                      (SvS s t y', Nothing)+          step (SvS s t y', Just bits) =+            let nbnd = lsbZ bits+                nset = set `clearBit` getBoundary bnd+                bs1  = BS1 nset (Boundary nbnd)+            in  -- traceShow (Boundary nbnd == bnd,bs1) $+                return $ Yield (SvS s (t:.bs1) (y':.:RiBs1I bs1))+                               (SvS s t y', Just $ bits `clearBit` nbnd)+          {-# Inline [0] mk       #-}+          {-# Inline [0] step     #-}+  {-# Inline addIndexDenseGo #-}++-- | For the inside case, we try all possible boundaries for @Y@ in @X ->+-- Y e@. For the outside case we now have: @Y -> X e@ where @Y@ is now+-- extended. @(yset,ybnd) -> (yset + α,α)@ for all @α@ that are not in+-- @yset@.+--+-- TODO 17.2.2017 added++instance+  ( IndexHdr s x0 i0 us (BS1 k O) cs c is (BS1 k O)+  ) => AddIndexDense s (us:.BS1 k O) (cs:.c) (is:.BS1 k O) where+  addIndexDenseGo (cs:.c) (vs:.ORightOf rb) (lbs:._) (ubs:._) (us:.BS1 uSet uBnd) (is:.BS1 cSet cBnd)+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is . assert (rb==1) -- only works with one element to the right+          -- Extract how many bits are already set -- should be zero (!) --+          -- and prepare the list of all possibilities.+          -- In addition, at least one bit should be reserved, hence+          -- @rb>0@. The boundary bit is one of those reserved and+          -- constitutes a mask to be used further down.+    where mk (SvS s t y') =+            let possible = uSet .&. complement cSet+            in+#if ADPFUSION_DEBUGOUTPUT+                traceShow ("aIDG/BS1/O/mk",(BS1 uSet uBnd), (BS1 cSet cBnd), possible) $+#endif+                return (SvS s t y', possible)+          -- in this case, the current set does not yield something to+          -- "make smaller".+          step (_, k) | popCount uSet == popCount cSet = return Done+          -- exhausted all options+          step (_, 0) = return Done+          step (SvS s t y', bits) =+            let nbnd = lsbZ bits+                nset = cSet `setBit` nbnd+                bs1  = BS1 nset (Boundary nbnd)+            in+#if ADPFUSION_DEBUGOUTPUT+                traceShow ("aIDG/BS1/O/step",(BS1 nset (Boundary nbnd))) $+#endif+                return $ Yield (SvS s (t:.bs1) (y':.:RiBs1O bs1))+                               (SvS s t y', bits `clearBit` nbnd)+          {-# Inline [0] mk       #-}+          {-# Inline [0] step     #-}+  {-# Inline addIndexDenseGo #-}+++-- | ++instance+  ( IndexHdr s x0 i0 us (BS1 k I) cs c is (BS1 k O)+  ) => AddIndexDense s (us:.BS1 k I) (cs:.c) (is:.BS1 k O) where++-- | A @Unit@ index expands to the full set with all possible boundaries+-- tried in order.++instance+  ( IndexHdr s x0 i0 us (BS1 k I) cs c is (Unit I)+  ) => AddIndexDense s (us:.BS1 k I) (cs:.c) (is:.Unit I) where+  addIndexDenseGo (cs:.c) (vs:.IStatic ()) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:._) -- unit has only one index value+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk (SvS s t y') = return $ (SvS s t y', fullSet)+          -- no more active bits+          step (_, 0) = return Done+          step (SvS s t y', bits)+            | b <- lsb bits = return $ Yield (SvS s (t:.BS1 fullSet (Boundary b)) (y':.:RiU))+                                             (SvS s t y', bits `clearBit` b)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++-- | A single @Boundary@ index allows us to get the optimal results ending+-- on each individual boundary.++instance+  ( IndexHdr s x0 i0 us (BS1 k I) cs c is (Boundary k I)+  ) => AddIndexDense s (us:.BS1 k I) (cs:.c) (is:.Boundary k I) where+  addIndexDenseGo (cs:.c) (vs:.IStatic ()) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:.i)+    = map (\(SvS s t y') -> SvS s (t:.BS1 fullSet i) (y':.:RiBI i))+    . addIndexDenseGo cs vs lbs ubs us is+  {-# Inline addIndexDenseGo #-}++-- | Given indices that index _only_ the current edge @First -> Last@, we+-- want to go over all possible set combinations.+--+-- The @to@ element from an edge boundary will serve as the @First@ element+-- in a rule+-- @X -> Last (from :-> to) First++instance+  ( IndexHdr s x0 i0 us (BS1 First I) cs c is (EdgeBoundary I)+  ) => AddIndexDense s (us:.BS1 First I) (cs:.c) (is:.EdgeBoundary I) where+  addIndexDenseGo (cs:.c) (vs:.IStatic k) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:.(from :-> to))+    = map (\(SvS s t y') ->+        let RiEBI usedSet (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary I))+            hereBits = fullSet .&. complement usedSet+            hereSet  = hereBits `setBit` to+        in  SvS s (t:.BS1 hereSet (Boundary to)) (y':.:RiEBI fullSet (from :-> to)))+    . addIndexDenseGo cs vs lbs ubs us is+  {-# Inline addIndexDenseGo #-}++-- | Generate all possible bitsets until 'fullSet' is reached. @from@ is+-- our @Last@, and @to@ may not be set.++instance+  ( IndexHdr s x0 i0 us (BS1 Last I) cs c is (EdgeBoundary I)+  ) => AddIndexDense s (us:.BS1 Last I) (cs:.c) (is:.EdgeBoundary I) where+  addIndexDenseGo (cs:.c) (vs:.IVariable rb) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:.(from :-> to))+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk (SvS s t y') =+            let RiEBI usedBits (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary I))+            in  assert (usedBits == 0) . return $ (SvS s t y', Just (zeroBits :: BitSet I))+          step (_, (Nothing :: Maybe (BitSet I))) = return $ Done+          step (SvS s t y', Just cbits)+            | popCount cbits > maxCount = return $ Done+            | otherwise =+                let sbits = popShiftL shiftMask cbits+                    cset  = sbits `setBit` from+                in  return $ Yield (SvS s (t:.BS1 cset (Boundary from)) (y':.:RiEBI cset (from :-> to)))+                                   (SvS s t y', setSucc zeroBits (BitSet $ 2^maxCount-1) cbits)+          !maxCount = popCount fullSet - rb - 1 -- remove one for @from@, the @to@ bit should be in @rb@+          !shiftMask = fullSet `clearBit` from `clearBit` to+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++-- | TODO 17.2.2017 added++instance+  ( IndexHdr s x0 i0 us (BS1 First I) cs c is (EdgeBoundary C)+  ) => AddIndexDense s (us:.BS1 First I) (cs:.c) (is:.EdgeBoundary C) where+  addIndexDenseGo (cs:.c) (vs:.CStatic()) (lbs:._) (ubs:.BS1 (BitSet fullSet) _) (us:._) (is:.(from :-> to))+    = map (\(SvS s t y') ->+        let RiEBC (BitSet usedSet) (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            hereBits = fullSet .&. complement usedSet+            hereSet  = hereBits `setBit` to+        in  SvS s (t:.BS1 (BitSet hereSet) (Boundary to)) (y':.:RiEBC (BitSet fullSet) (from :-> to)))+    . addIndexDenseGo cs vs lbs ubs us is+  addIndexDenseGo (cs:.c) (vs:.CVariable ()) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:.(from :-> to))+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk (SvS s t y') =+            let RiEBC usedBits (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            in  assert (usedBits == 0) . return $ (SvS s t y', Just (zeroBits :: BitSet I))+          step (_, Nothing) = return $ Done+          step (SvS s t y', Just cbits)+            | popCount cbits > maxCount = return $ Done+            | otherwise =+                let sbits = popShiftL shiftMask cbits+                    cset  = getBitSet $ sbits `setBit` from+                in  return $ Yield (SvS s (t:.BS1 (BitSet cset) (Boundary from)) (y':.:RiEBC (BitSet cset) (from :-> to)))+                                   (SvS s t y', setSucc zeroBits (BitSet $ 2^maxCount-1) cbits)+          !maxCount = popCount fullSet - 1 -- remove one for @from@, the @to@ bit should be in @rb@+          !shiftMask = fullSet `clearBit` from `clearBit` to+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++-- | TODO 17.2.2017 added++instance+  ( IndexHdr s x0 i0 us (BS1 First O) cs c is (EdgeBoundary C)+  ) => AddIndexDense s (us:.BS1 First O) (cs:.c) (is:.EdgeBoundary C) where+  addIndexDenseGo (cs:.c) (vs:.CStatic()) (lbs:._) (ubs:.BS1 (BitSet fullSet) _) (us:._) (is:.(from :-> to))+    = map (\(SvS s t y') ->+        let RiEBC (BitSet usedSet) (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            hereBits = fullSet .&. complement usedSet+            hereSet  = hereBits `setBit` to+        in  SvS s (t:.BS1 (BitSet hereSet) (Boundary to)) (y':.:RiEBC (BitSet fullSet) (from :-> to)))+    . addIndexDenseGo cs vs lbs ubs us is+  addIndexDenseGo (cs:.c) (vs:.CVariable ()) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:.(from :-> to))+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk (SvS s t y') =+            let RiEBC usedBits (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            in  assert (usedBits == 0) . return $ (SvS s t y', Just (zeroBits :: BitSet O))+          step (_, Nothing) = return $ Done+          step (SvS s t y', Just cbits)+            | popCount cbits > maxCount = return $ Done+            | otherwise =+                let sbits = popShiftL shiftMask cbits+                    cset  = getBitSet $ sbits `setBit` from+                in  return $ Yield (SvS s (t:.BS1 (BitSet cset) (Boundary from)) (y':.:RiEBC (BitSet cset) (from :-> to)))+                                   (SvS s t y', setSucc zeroBits (BitSet $ 2^maxCount-1) cbits)+          !maxCount = popCount fullSet - 1 -- remove one for @from@, the @to@ bit should be in @rb@+          !shiftMask = fullSet `clearBit` from `clearBit` to+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++-- | TODO 18.2.2017 added++instance+  ( IndexHdr s x0 i0 us (BS1 Last I) cs c is (EdgeBoundary C)+  ) => AddIndexDense s (us:.BS1 Last I) (cs:.c) (is:.EdgeBoundary C) where+{-+  addIndexDenseGo (cs:.c) (vs:.CStatic()) (lbs:._) (ubs:.BS1 (BitSet fullSet) _) (us:._) (is:.(from :-> to))+    = map (\(SvS s t y') ->+        let RiEBC (BitSet usedSet) (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            hereBits = fullSet .&. complement usedSet+            hereSet  = hereBits `setBit` to+        in  SvS s (t:.BS1 (BitSet hereSet) (Boundary to)) (y':.:RiEBC (BitSet fullSet) (from :-> to)))+    . addIndexDenseGo cs vs lbs ubs us is+    -}+  addIndexDenseGo (cs:.c) (vs:.CVariable ()) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:.(from :-> to))+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk (SvS s t y') =+            let RiEBC usedBits (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            in  assert (usedBits == 0) . return $ (SvS s t y', Just (zeroBits :: BitSet I))+          step (_, Nothing) = return $ Done+          step (SvS s t y', Just cbits)+            | popCount cbits > maxCount = return $ Done+            | (zeroBits `setBit` from `setBit` to) .&. cbits > 0 =+                return $ Skip (SvS s t y', setSucc zeroBits (BitSet $ 2^maxCount-1) cbits)+            | otherwise =+                let sbits = cbits -- popShiftL shiftMask cbits+                    cset  = getBitSet $ sbits `setBit` from -- `setBit` to+                in+#if ADPFUSION_DEBUGOUTPUT+                    traceShow ("EB/BS1-Last-I/C/step",(BS1 (BitSet cset) (Boundary from))) $+#endif+                    return $ Yield (SvS s (t:.BS1 (BitSet cset) (Boundary from)) (y':.:RiEBC (BitSet cset) (from :-> to)))+                                   (SvS s t y', setSucc zeroBits (BitSet $ 2^maxCount-1) cbits)+          !maxCount = popCount fullSet - 1 -- remove one for @from@, the @to@ bit should be in @rb@+          !shiftMask = fullSet `clearBit` from `clearBit` to+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline addIndexDenseGo #-}++-- | TODO 18.2.2017 added++instance+  ( IndexHdr s x0 i0 us (BS1 Last O) cs c is (EdgeBoundary C)+  ) => AddIndexDense s (us:.BS1 Last O) (cs:.c) (is:.EdgeBoundary C) where+  addIndexDenseGo (cs:.c) (vs:.CStatic()) (lbs:._) (ubs:.BS1 (BitSet fullSet) _) (us:._) (is:.(from :-> to))+    = map (\(SvS s t y') ->+        let RiEBC (BitSet usedSet) (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            hereBits = usedSet -- fullSet .&. complement usedSet+            hereSet  = hereBits `setBit` to `setBit` from+        in+#if ADPFUSION_DEBUGOUTPUT+            traceShow ("EB/BS1-Last-O/C/step",(BS1 (BitSet hereSet) (Boundary to))) $+#endif+            SvS s (t:.BS1 (BitSet hereSet) (Boundary to)) (y':.:RiEBC (BitSet fullSet) (from :-> to)))+    . addIndexDenseGo cs vs lbs ubs us is+{-+  addIndexDenseGo (cs:.c) (vs:.CVariable ()) (lbs:._) (ubs:.BS1 fullSet _) (us:._) (is:.(from :-> to))+    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is+    where mk (SvS s t y') =+            let RiEBC usedBits (_ :-> _) = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+            in  assert (usedBits == 0) . return $ (SvS s t y', Just (zeroBits :: BitSet O))+          step (_, Nothing) = return $ Done+          step (SvS s t y', Just cbits)+            | popCount cbits > maxCount = return $ Done+            | otherwise =+                let sbits = popShiftL shiftMask cbits+                    cset  = getBitSet $ sbits `setBit` from+                in  return $ Yield (SvS s (t:.BS1 (BitSet cset) (Boundary from)) (y':.:RiEBC (BitSet cset) (from :-> to)))+                                   (SvS s t y', setSucc zeroBits (BitSet $ 2^maxCount-1) cbits)+          !maxCount = popCount fullSet - 1 -- remove one for @from@, the @to@ bit should be in @rb@+          !shiftMask = fullSet `clearBit` from `clearBit` to+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+-}+  {-# Inline addIndexDenseGo #-}+

+ ADP/Fusion/Term/Edge/EdgeBoundary.hs view

@@ -0,0 +1,50 @@++module ADP.Fusion.Term.Edge.EdgeBoundary where++import Data.Bits+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Debug.Trace+import Prelude hiding (map)++import ADP.Fusion.Core+import Data.Bits.Ordered+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.EdgeBoundary+import ADP.Fusion.Term.Edge.Type++++instance+  ( TmkCtx1 m ls Edge (EdgeBoundary k)+  ) => MkStream m (ls :!: Edge) (EdgeBoundary k) where+  mkStream (ls :!: Edge) sv us is+    = map (\(ss,ee,ii) -> ElmEdge ee ii ss)+    . addTermStream1 Edge sv us is+    $ mkStream ls (termStaticVar Edge sv is) us (termStreamIndex Edge sv is)+  {-# Inline mkStream #-}++-- Only allow an edge between @from /= to@++instance+  ( TstCtx m ts s x0 i0 is (EdgeBoundary I)+  ) => TermStream m (TermSymbol ts Edge) s (is:.EdgeBoundary I) where+  termStream (ts:|Edge) (cs:._) (us:.u) (is:.(from :-> to))+    = map (\(TState s ii ee) ->+        let RiEBI cset _ = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary I))+        in  TState s (ii:.:RiEBI (cset `setBit` to) (from :-> to))+                     (ee:.(From from:.To to)) )+    . termStream ts cs us is+    . staticCheck (from /= to)+  {-# Inline termStream #-}++++instance TermStaticVar Edge (EdgeBoundary I) where+  termStaticVar   _ (IStatic   d) _ = IVariable $ d+1+  termStaticVar   _ (IVariable d) _ = IVariable $ d+1+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}+

+ ADP/Fusion/Term/Edge/Set1.hs view

@@ -0,0 +1,116 @@++-- | Insert an edge into a set. @X -> Y e@ with @e == Edge@ extends @Y@+-- with the edge partially overlapping @Y@.+--+-- The semantic meaning of the overlap depends on what the @k@ type in @BS1+-- k i@ is. For @First@, the edge will go from @First@ in @X@ to @First@ in+-- the smaller @Y@.+--+-- TODO @X -> e X@ vs @X -> X e@.+--+-- Sidenote: can we actually have @X -> Y Z@ with @Set1@ structures?+-- I don't think so, at least not easily, since the boundary between @Y Z@+-- is unclear.++module ADP.Fusion.Term.Edge.Set1 where++import Data.Bits+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Debug.Trace+import Prelude hiding (map,filter)++import ADP.Fusion.Core+import Data.Bits.Ordered+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Set1+import ADP.Fusion.Term.Edge.Type++++instance+  ( TmkCtx1 m ls Edge (BS1 k t)+  ) => MkStream m (ls :!: Edge) (BS1 k t) where+  mkStream (ls :!: Edge) sv us is+    = map (\(ss,ee,ii) -> ElmEdge ee ii ss)+    . addTermStream1 Edge sv us is+    $ mkStream ls (termStaticVar Edge sv is) us (termStreamIndex Edge sv is)+  {-# Inline mkStream #-}++-- | We need to separate out the two cases of having @BS1 First@ and @BS1+-- Last@ as this changes how we fill the Edge.+--+-- TODO separate out these cases into an Edge-Choice class ...++instance+  ( TstCtx m ts s x0 i0 is (BS1 k I)+  , EdgeFromTo k+  ) => TermStream m (TermSymbol ts Edge) s (is:.BS1 k I) where+  -- Begin the edge on @First == b@, and end it somewhere in the set.+  termStream (ts:|Edge) (cs:.IStatic r) (us:.u) (is:.BS1 i (Boundary newNode))+    = map (\(TState s ii ee) ->+        let RiBs1I (BS1 cset (Boundary setNode)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k I))+        in  TState s (ii:.:RiBs1I (BS1 i (Boundary newNode)))+                     (ee:.edgeFromTo (Proxy :: Proxy k) (SetNode setNode) (NewNode newNode)) )+    . filter (\(TState s ii ee) ->+        let RiBs1I (BS1 cset (Boundary setNode)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k I))+        in  popCount cset >= 1)+    . termStream ts cs us is+    . staticCheck (popCount i >= 2)+  -- Begin the edge somewhere, because in the variable case we do not end+  -- on @b@+  termStream (ts:|Edge) (cs:.IVariable r) (us:.u) (is:.BS1 i b)+    = flatten mk step . termStream ts cs us is+          -- get us the inner set, build an edge @avail -> to@+    where mk tstate@(TState s ii ee) =+            let RiBs1I (BS1 cset (Boundary setNode)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k I))+                avail = activeBitsL $ (i .&. complement cset) `clearBit` getBoundary b+            in  return $ (tstate,cset,setNode,avail)+          -- in @X -> Y e Z@, @e == Edge@ will only be active, if @Y@ has+          -- at least one active bit. This means that @X -> e ...@ will+          -- never be active.+          step (_,_,_,[]) = return $ Done+          step (TState s ii ee,cset,setNode,(newNode:xs))+            | setNode < 0  = error "Edge/Set1: source boundary is '-1'. Move all terminals to the right of syntactic variables!"+            | otherwise =+              let ix = RiBs1I $ BS1 (cset `setBit` newNode) (Boundary newNode)+              in  return $ Yield (TState s (ii:.:ix) (ee:.edgeFromTo (Proxy :: Proxy k) (SetNode setNode) (NewNode newNode)))+                                 (TState s ii ee,cset,setNode,xs)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline termStream #-}++-- |+--+-- TODO move to definition of 'Edge'++class EdgeFromTo k where+  edgeFromTo :: Proxy k -> SetNode -> NewNode -> (From:.To)++newtype SetNode = SetNode Int++newtype NewNode = NewNode Int++-- | In case our sets have a @First@ boundary, then we always point from+-- the boundary "into" the set. Hence @SetNode == To@ and @NewNode ==+-- From@.++instance EdgeFromTo First where+  edgeFromTo Proxy (SetNode to) (NewNode from) = From from :. To to+  {-# Inline edgeFromTo #-}++-- | And if the set has a @Last@ boundary, then we point from somewhere in+-- the set @To@ the @NewNode@, which is @Last@.++instance EdgeFromTo Last where+  edgeFromTo Proxy (SetNode from) (NewNode to) = From from :. To to+  {-# Inline edgeFromTo #-}++instance TermStaticVar Edge (BS1 k I) where+  termStaticVar   _ (IStatic   d) _ = IVariable $ d+1+  termStaticVar   _ (IVariable d) _ = IVariable $ d+1+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}+

+ ADP/Fusion/Term/EdgeWithSet.hs view

@@ -0,0 +1,11 @@++module ADP.Fusion.Term.EdgeWithSet+  ( module ADP.Fusion.Term.EdgeWithSet.Type+  , module ADP.Fusion.Term.EdgeWithSet.EdgeBoundary+  , module ADP.Fusion.Term.EdgeWithSet.Set1+  ) where++import ADP.Fusion.Term.EdgeWithSet.EdgeBoundary+import ADP.Fusion.Term.EdgeWithSet.Set1+import ADP.Fusion.Term.EdgeWithSet.Type+

+ ADP/Fusion/Term/EdgeWithSet/EdgeBoundary.hs view

@@ -0,0 +1,73 @@++module ADP.Fusion.Term.EdgeWithSet.EdgeBoundary where++import Data.Bits+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Debug.Trace+import Prelude hiding (map)++import ADP.Fusion.Core+import Data.Bits.Ordered+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.EdgeBoundary+import ADP.Fusion.Term.EdgeWithSet.Type++++instance+  ( TmkCtx1 m ls EdgeWithSet (EdgeBoundary k)+  ) => MkStream m (ls :!: EdgeWithSet) (EdgeBoundary k) where+  mkStream (ls :!: EdgeWithSet) sv us is+    = map (\(ss,ee,ii) -> ElmEdgeWithSet ee ii ss)+    . addTermStream1 EdgeWithSet sv us is+    $ mkStream ls (termStaticVar EdgeWithSet sv is) us (termStreamIndex EdgeWithSet sv is)+  {-# Inline mkStream #-}++-- Only allow an edge between @from /= to@++instance+  ( TstCtx m ts s x0 i0 is (EdgeBoundary I)+  ) => TermStream m (TermSymbol ts EdgeWithSet) s (is:.EdgeBoundary I) where+  termStream (ts:|EdgeWithSet) (cs:._) (us:.u) (is:.(from :-> to))+    = map (\(TState s ii ee) ->+        let RiEBI cset _ = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary I))+        in  TState s (ii:.:RiEBI (cset `setBit` to) (from :-> to))+                     (ee:.(getBitSet cset:.From from:.To to)) )+    . termStream ts cs us is+    . staticCheck (from /= to)+  {-# Inline termStream #-}++-- TODO 17.2.2017 added++instance+  ( TstCtx m ts s x0 i0 is (EdgeBoundary C)+  ) => TermStream m (TermSymbol ts EdgeWithSet) s (is:.EdgeBoundary C) where+  termStream (ts:|EdgeWithSet) (cs:._) (us:.u) (is:.(from :-> to))+    = map (\(TState s ii ee) ->+        let RiEBC cset _ = getIndex (getIdx s) (Proxy :: PRI is (EdgeBoundary C))+        in  TState s (ii:.:RiEBC (cset `setBit` to) (from :-> to))+                     (ee:.(getBitSet cset:.From from:.To to)) )+    . termStream ts cs us is+    . staticCheck (from /= to)+  {-# Inline termStream #-}+++instance TermStaticVar EdgeWithSet (EdgeBoundary I) where+  termStaticVar   _ (IStatic   d) _ = IVariable $ d+1+  termStaticVar   _ (IVariable d) _ = IVariable $ d+1+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}++-- TODO 17.2.2017 added++instance TermStaticVar EdgeWithSet (EdgeBoundary C) where+  termStaticVar   _ (CStatic   d) _ = CVariable $ d+  termStaticVar   _ (CVariable d) _ = CVariable $ d+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}++

+ ADP/Fusion/Term/EdgeWithSet/Set1.hs view

@@ -0,0 +1,121 @@++module ADP.Fusion.Term.EdgeWithSet.Set1 where++import Data.Bits+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Debug.Trace+import Prelude hiding (map,filter)+import Control.Exception (assert)++import ADP.Fusion.Core+import Data.Bits.Ordered+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Set1+import ADP.Fusion.Term.EdgeWithSet.Type+import ADP.Fusion.Term.Edge.Set1 (EdgeFromTo(..), SetNode(..), NewNode(..))++++instance+  ( TmkCtx1 m ls EdgeWithSet (BS1 k t)+  ) => MkStream m (ls :!: EdgeWithSet) (BS1 k t) where+  mkStream (ls :!: EdgeWithSet) sv us is+    = map (\(ss,ee,ii) -> ElmEdgeWithSet ee ii ss)+    . addTermStream1 EdgeWithSet sv us is+    $ mkStream ls (termStaticVar EdgeWithSet sv is) us (termStreamIndex EdgeWithSet sv is)+  {-# Inline mkStream #-}+++-- | We need to separate out the two cases of having @BS1 First@ and @BS1+-- Last@ as this changes how we fill the Edge.+--+-- TODO separate out these cases into an Edge-Choice class ...++instance+  ( TstCtx m ts s x0 i0 is (BS1 k I)+  , EdgeFromTo k+  ) => TermStream m (TermSymbol ts EdgeWithSet) s (is:.BS1 k I) where+  -- Begin the edge on @First == b@, and end it somewhere in the set.+  termStream (ts:|EdgeWithSet) (cs:.IStatic r) (us:.u) (is:.BS1 i (Boundary newNode))+    = map (\(TState s ii ee) ->+        let RiBs1I (BS1 cset (Boundary setNode)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k I))+            (ef:.et) = edgeFromTo (Proxy :: Proxy k) (SetNode setNode) (NewNode newNode)+        in+#if ADPFUSION_DEBUGOUTPUT+            traceShow ("EWSI",i,newNode,'>',cset,setNode,ef,et) $+#endif+            TState s (ii:.:RiBs1I (BS1 i (Boundary newNode)))+                     (ee:.(getBitSet cset:.ef:.et) ) )+    . filter (\(TState s ii ee) ->+        let RiBs1I (BS1 cset (Boundary setNode)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k I))+        in  popCount cset >= 1)+    . termStream ts cs us is+    -- only insert edges, if there at least two active nodes!+    . staticCheck (popCount i >= 2)+  -- Begin the edge somewhere, because in the variable case we do not end+  -- on @b@+  termStream (ts:|EdgeWithSet) (cs:.IVariable r) (us:.u) (is:.BS1 i b)+    = flatten mk step . termStream ts cs us is+          -- get us the inner set, build an edge @avail -> to@+    where mk tstate@(TState s ii ee) =+            let RiBs1I (BS1 cset (Boundary setNode)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k I))+                avail = activeBitsL $ (i .&. complement cset) `clearBit` getBoundary b+            in  return $ (tstate,cset,setNode,avail)+          -- in @X -> Y e Z@, @e == Edge@ will only be active, if @Y@ has+          -- at least one active bit. This means that @X -> e ...@ will+          -- never be active.+          step (_,_,_,[]) = return $ Done+          step (TState s ii ee,cset,setNode,(newNode:xs))+            | setNode < 0  = error "Edge/Set1: source boundary is '-1'. Move all terminals to the right of syntactic variables!"+            | otherwise =+              let ix = RiBs1I $ BS1 (cset `setBit` newNode) (Boundary newNode)+                  (ef:.et) = edgeFromTo (Proxy :: Proxy k) (SetNode setNode) (NewNode newNode)+              in  return $ Yield (TState s (ii:.:ix) (ee:.(getBitSet cset:.ef:.et)))+                                 (TState s ii ee,cset,setNode,xs)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline termStream #-}++-- TODO 17.2.2017 added++instance+  ( TstCtx m ts s x0 i0 is (BS1 k O)+  , EdgeFromTo k+  ) => TermStream m (TermSymbol ts EdgeWithSet) s (is:.BS1 k O) where+  termStream (ts:|EdgeWithSet) (cs:.OStatic r) (us:.u) (is:.BS1 gset (Boundary gbnd))+    = map (\(TState s ii ee) ->+        let RiBs1O (BS1 cset (Boundary cbnd)) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k O))+            (ef:.et) = edgeFromTo (Proxy :: Proxy k) (SetNode gbnd) (NewNode cbnd)+        in+#if ADPFUSION_DEBUGOUTPUT+            traceShow ("EWSO",gset,gbnd,' ',cset,cbnd,ef,et) $+#endif+            TState s (ii:.:RiBs1O (BS1 gset (Boundary gbnd)))+                     (ee:.(getBitSet gset:.ef:.et) ) )+    . termStream ts cs us is+    -- TODO needs to be better!+    . assert (r==0)+    . staticCheck (popCount gset >= 1)++instance+  ( TstCtx m ts s x0 i0 is (BS1 k C)+  , EdgeFromTo k+  ) => TermStream m (TermSymbol ts EdgeWithSet) s (is:.BS1 k C) where+++instance TermStaticVar EdgeWithSet (BS1 k I) where+  termStaticVar   _ (IStatic   d) _ = IVariable $ d+1+  termStaticVar   _ (IVariable d) _ = IVariable $ d+1+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}++instance TermStaticVar EdgeWithSet (BS1 k O) where+  termStaticVar _ (OStatic  d) _ = ORightOf   $ d+1+  termStaticVar _ (ORightOf d) _ = OFirstLeft $ d+1+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}+

+ ADP/Fusion/Term/EdgeWithSet/Type.hs view

@@ -0,0 +1,38 @@++-- |+--+-- TODO merge with @Edge@ and handle via phantom typing?++module ADP.Fusion.Term.EdgeWithSet.Type where++import Data.Strict.Tuple++import Data.PrimitiveArray++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi+import ADP.Fusion.Term.Edge.Type (From(..), To(..))++++-- | An edge in a graph. As a parsing symbol, it will provide (From:.To)+-- pairs.++data EdgeWithSet = EdgeWithSet++instance Build EdgeWithSet++instance+  ( Element ls i+  ) => Element (ls :!: EdgeWithSet) i where+    data Elm (ls :!: EdgeWithSet) i = ElmEdgeWithSet !(Int:.From:.To) !(RunningIndex i) (Elm ls i)+    type Arg (ls :!: EdgeWithSet)   = Arg ls :. (Int:.From:.To)+    getArg (ElmEdgeWithSet e _ ls) = getArg ls :. e+    getIdx (ElmEdgeWithSet _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: EdgeWithSet) i)++type instance TermArg EdgeWithSet = (Int:.From:.To)+

+ ADP/Fusion/Term/Epsilon/Set1.hs view

@@ -0,0 +1,74 @@++module ADP.Fusion.Term.Epsilon.Set1 where++import Data.Proxy+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic as S+import Prelude hiding (map)+import Debug.Trace++import ADP.Fusion.Core+import Data.Bits.Ordered+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Set1++++instance+  ( TmkCtx1 m ls Epsilon (BS1 k t)+  ) => MkStream m (ls :!: Epsilon) (BS1 k 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 (BS1 k I)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.BS1 k I) where+  termStream (ts:|Epsilon) (cs:.IStatic r) (us:.BS1 uset ubnd) (is:.BS1 cset cbnd)+    = map (\(TState s ii ee) ->+#if ADPFUSION_DEBUGOUTPUT+            traceShow ("Empty/BS1/I",BS1 uset ubnd,BS1 cset cbnd) $+#endif+            TState s (ii:.:RiBs1I (BS1 0 0)) (ee:.())+          )+    . termStream ts cs us is+    . staticCheck (cset == 0)+  {-# Inline termStream #-}++instance+  ( TstCtx m ts s x0 i0 is (BS1 k O)+  ) => TermStream m (TermSymbol ts Epsilon) s (is:.BS1 k O) where+  termStream (ts:|Epsilon) (cs:.OStatic r) (us:.BS1 uset ubnd) (is:.BS1 cset cbnd)+    = map (\(TState s ii ee) ->+#if ADPFUSION_DEBUGOUTPUT+            traceShow ("Empty/BS1/O",BS1 uset ubnd,BS1 cset cbnd) $+#endif+            TState s (ii:.:RiBs1O (BS1 cset cbnd)) (ee:.())+          )+    . termStream ts cs us is+    . staticCheck (uset == cset)+  {-# Inline termStream #-}++instance TermStaticVar Epsilon (BS1 k I) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ b = b+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}++instance TermStaticVar Epsilon (BS1 k O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ b = b+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}++{-+instance TermStaticVar Epsilon (BitSet O) where+  termStaticVar _ sv _ = sv+  termStreamIndex _ _ b = b+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}+-}+

+ ADP/Fusion/Term/Singleton/Set1.hs view

@@ -0,0 +1,77 @@++-- | Singleton vertices are only introduced into a set structure, if no+-- vertex has been placed yet.+--+-- We explicitly check that @X -> s@ is the only allowed rule, with @s ==+-- Singleton@, apart from introducing "deletion" symbols like @X -> - s@.++module ADP.Fusion.Term.Singleton.Set1 where++import Data.Bits+import Data.Strict.Tuple+import Data.Vector.Fusion.Stream.Monadic hiding (flatten)+import Debug.Trace+import Prelude hiding (map)++import ADP.Fusion.Core+import Data.Bits.Ordered+import Data.PrimitiveArray hiding (map)++import ADP.Fusion.Core.Set1+import ADP.Fusion.Term.Singleton.Type++++instance+  ( TmkCtx1 m ls Singleton (BS1 k t)+  ) => MkStream m (ls :!: Singleton) (BS1 k t) where+  mkStream (ls :!: Singleton) sv us is+    = map (\(ss,ee,ii) -> ElmSingleton ee ii ss)+    . addTermStream1 Singleton sv us is+    $ mkStream ls (termStaticVar Singleton sv is) us (termStreamIndex Singleton sv is)+  {-# Inline mkStream #-}++instance+  ( TstCtx m ts s x0 i0 is (BS1 k I)+  ) => TermStream m (TermSymbol ts Singleton) s (is:.BS1 k I) where+  termStream (ts:|Singleton) (cs:.IStatic r) (us:.u) (is:.BS1 i b)+    = map (\(TState s ii ee) -> let Boundary bb = b in+              TState s (ii:.:RiBs1I (BS1 i b)) (ee:.(0:.To bb)) )+    . termStream ts cs us is+    . staticCheck (popCount i == 1)+  {-# Inline termStream #-}++-- |+--+-- TODO 17.2.2017 added; probably wrong together with the syntactic+-- variable instance in subtle ways.++instance+  ( TstCtx m ts s x0 i0 is (BS1 k O)+  ) => TermStream m (TermSymbol ts Singleton) s (is:.BS1 k O) where+  termStream (ts:|Singleton) (cs:.OStatic r) (us:.BS1 uset ubnd) (is:.BS1 cset cbnd)+    = map (\(TState s ii ee) -> +        let RiBs1O (BS1 pSet pBnd) = getIndex (getIdx s) (Proxy :: PRI is (BS1 k O))+            bb = getBoundary pBnd+        in+#if ADPFUSION_DEBUGOUTPUT+            traceShow ("TermStream/Singleton/O",(BS1 cset cbnd),(pSet,pBnd)) $+#endif+            TState s (ii:.:RiBs1O (BS1 cset cbnd)) (ee:.(0:.To bb)) )+    . termStream ts cs us is+    . staticCheck (popCount cset == 0)+  {-# Inline termStream #-}++instance TermStaticVar Singleton (BS1 k I) where+  termStaticVar   _ (IStatic   d) _ = IVariable $ d+1+  termStaticVar   _ (IVariable d) _ = IVariable $ d+1+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}++instance TermStaticVar Singleton (BS1 k O) where+  termStaticVar _ (OStatic d) _ = ORightOf $ d+1+  termStreamIndex _ _  ix = ix+  {-# Inline [0] termStaticVar #-}+  {-# Inline [0] termStreamIndex #-}+

+ ADP/Fusion/Term/Singleton/Type.hs view

@@ -0,0 +1,38 @@++-- | Type definition for singleton terminal symbols.++module ADP.Fusion.Term.Singleton.Type where++import Data.Strict.Tuple++import Data.PrimitiveArray+import ADP.Fusion.Term.Edge.Type (To(..))++import ADP.Fusion.Core.Classes+import ADP.Fusion.Core.Multi++++-- | A singleton vertex is successfully parsed only if no other vertex is+-- active yet. In particular, this allows us to insert "starting" points+-- into graphs that mostly deal with edges. As a parsing symbol, it+-- provides an @Int@ which is the node index.++data Singleton = Singleton++instance Build Singleton++instance+  ( Element ls i+  ) => Element (ls :!: Singleton) i where+    data Elm (ls :!: Singleton) i = ElmSingleton !(Int:.To) !(RunningIndex i) (Elm ls i)+    type Arg (ls :!: Singleton)   = Arg ls :. (Int:.To)+    getArg (ElmSingleton v _ ls) = getArg ls :. v+    getIdx (ElmSingleton _ i _ ) = i+    {-# Inline getArg #-}+    {-# Inline getIdx #-}++deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Singleton) i)++type instance TermArg Singleton = (Int:.To)+

+ ADPfusionSet.cabal view

@@ -0,0 +1,157 @@+name:           ADPfusionSet+version:        0.0.0.1+author:         Christian Hoener zu Siederdissen, 2016-2017+copyright:      Christian Hoener zu Siederdissen, 2016-2017+homepage:       https://github.com/choener/ADPfusionSet+bug-reports:    https://github.com/choener/ADPfusionSet/issues+maintainer:     choener@bioinf.uni-leipzig.de+category:       Algorithms, Data Structures, Bioinformatics, Formal Languages+license:        BSD3+license-file:   LICENSE+build-type:     Simple+stability:      experimental+cabal-version:  >= 1.10.0+tested-with:    GHC == 7.10.3, GHC == 8.0.1+synopsis:       Dynamic programming for Set data structures.+description:+                <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>+                .+                Extensions of ADPfusion for set-(like) data structures.+                .++++Extra-Source-Files:+  README.md+  changelog.md++++flag examples+  description:  build the examples+  default:      False+  manual:       True++flag debug+  description:  Enable bounds checking and various other debug operations at the cost of a significant performance penalty.+  default:      False+  manual:       True++flag debugoutput+  description:  Enable debug output, which spams the screen full of index information+  default:      False+  manual:       True+++library+  build-depends: base               >= 4.7      &&  < 5.0+               , bits               >= 0.4+               , containers+               , mmorph             >= 1.0+               , mtl                >= 2.0+               , primitive          >= 0.5.4+               , QuickCheck         >= 2.7+               , strict             >= 0.3+               , template-haskell   >= 2.0+               , th-orphans         >= 0.12+               , transformers       >= 0.3+               , tuple              >= 0.3+               , vector             >= 0.11+               --+               , ADPfusion          == 0.5.2.*+               , DPutils            == 0.0.1.*+               , OrderedBits        == 0.0.1.*+               , PrimitiveArray     == 0.8.0.*++  exposed-modules:+    -- multi imports+--    ADP.Fusion.Set+    ADP.Fusion.Boundary+    ADP.Fusion.EdgeBoundary+    ADP.Fusion.Set1+--    ADP.Fusion.Set2+    -- Set+--    ADP.Fusion.Core.Set+    ADP.Fusion.Core.Boundary+    ADP.Fusion.Core.EdgeBoundary+    ADP.Fusion.Core.Set1+--    ADP.Fusion.Core.Set2+--    ADP.Fusion.SynVar.Indices.Set0+    ADP.Fusion.SynVar.Indices.Set1+--    ADP.Fusion.Term.Chr.Set0+--    ADP.Fusion.Term.Edge.Set+    ADP.Fusion.Term.Edge.EdgeBoundary+    ADP.Fusion.Term.Edge.Set1+    ADP.Fusion.Term.EdgeWithSet+    ADP.Fusion.Term.EdgeWithSet.EdgeBoundary+    ADP.Fusion.Term.EdgeWithSet.Set1+    ADP.Fusion.Term.EdgeWithSet.Type+--    ADP.Fusion.Term.Edge.Set2+--    ADP.Fusion.Term.Epsilon.Set+    ADP.Fusion.Term.Epsilon.Set1+    ADP.Fusion.Term.Singleton.Set1+--    ADP.Fusion.Term.Singleton.Set2+    ADP.Fusion.Term.Singleton.Type++  default-extensions: BangPatterns+                    , ConstraintKinds+                    , CPP+                    , DataKinds+                    , DefaultSignatures+                    , FlexibleContexts+                    , FlexibleInstances+                    , GADTs+                    , KindSignatures+                    , MultiParamTypeClasses+                    , RankNTypes+                    , RecordWildCards+                    , ScopedTypeVariables+                    , StandaloneDeriving+                    , TemplateHaskell+                    , TupleSections+                    , TypeFamilies+                    , TypeOperators+                    , TypeSynonymInstances+                    , UndecidableInstances++  default-language:+    Haskell2010+  ghc-options:+    -O2 -funbox-strict-fields+  if flag(debug)+    cpp-options: -DADPFUSION_CHECKS+    ghc-options: -fno-ignore-asserts+  if flag(debugoutput)+    cpp-options: -DADPFUSION_DEBUGOUTPUT++++test-suite properties+  type:+    exitcode-stdio-1.0+  main-is:+    properties.hs+  ghc-options:+    -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs:+    tests+  default-language:+    Haskell2010+  default-extensions: CPP+                    , TemplateHaskell+  build-depends: base+               , QuickCheck+               , smallcheck+               , tasty              >= 0.11+               , tasty-quickcheck   >= 0.8+               , tasty-smallcheck   >= 0.8+               , tasty-th           >= 0.1+               --+               , ADPfusionSet++++source-repository head+  type: git+  location: git://github.com/choener/ADPfusionSet+

+ 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,56 @@+[![Build Status](https://travis-ci.org/choener/ADPfusionSet.svg?branch=master)](https://travis-ci.org/choener/ADPfusionSet)++# ADPfusionSet++[*generalized Algebraic Dynamic Programming Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)++Ideas implemented here are described in a couple of papers:++++1.  Christian Hoener zu Siederdissen  +    *Sneaking Around ConcatMap: Efficient Combinators for Dynamic Programming*  +    2012, Proceedings of the 17th ACM SIGPLAN international conference on Functional programming  +    [paper](http://doi.acm.org/10.1145/2364527.2364559) [preprint](http://www.tbi.univie.ac.at/newpapers/pdfs/TBI-p-2012-2.pdf)  +1.  Andrew Farmer, Christian Höner zu Siederdissen, and Andy Gill.  +    *The HERMIT in the stream: fusing stream fusion’s concatMap*  +    2014, Proceedings of the ACM SIGPLAN 2014 workshop on Partial evaluation and program manipulation.  +    [paper](http://dl.acm.org/citation.cfm?doid=2543728.2543736)  +1.  Christian Höner zu Siederdissen, Ivo L. Hofacker, and Peter F. Stadler.  +    *Product Grammars for Alignment and Folding*  +    2014, IEEE/ACM Transactions on Computational Biology and Bioinformatics. 99  +    [paper](http://ieeexplore.ieee.org/xpl/articleDetails.jsp?arnumber=6819790)  +1.  Christian Höner zu Siederdissen, Sonja J. Prohaska, and Peter F. Stadler  +    *Algebraic Dynamic Programming over General Data Structures*  +    2015, BMC Bioinformatics  +    [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/hoe-pro-2015.pdf)  +1.  Maik Riechert, Christian Höner zu Siederdissen, and Peter F. Stadler  +    *Algebraic dynamic programming for multiple context-free languages*  +    2015, submitted  +    [preprint](http://www.bioinf.uni-leipzig.de/Software/gADP/preprints/rie-hoe-2015.pdf)  ++++# Introduction++ADPfusionSet extends ADPfusion with index structures suitable for sets.+Included are sets, and sets with one and two boundaries. The classical example+for DP on sets with a single boundary is the travelling salesman problem. Here,+the set denotes the set of cities already visited, while the boundary is the+last city that was visited.++++# Installation++Follow the [gADP examples](http://www.bioinf.uni-leipzig.de/Software/gADP/index.html).++++#### 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,7 @@+0.0.0.1+-------++- initial split off the ADPfusion core package+- Boundary and EdgeBoundary index structures are handled to allow for summary+  statistics collection in set DP algorithms+

+ tests/properties.hs view

@@ -0,0 +1,14 @@++module Main where++import Test.Tasty+import Test.Tasty.TH++++main :: IO ()+main = do+  defaultMain $ testGroup ""+    [+    ]+