diff --git a/ADP/Fusion/Boundary.hs b/ADP/Fusion/Boundary.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Boundary.hs @@ -0,0 +1,3 @@ + +module ADP.Fusion.Boundary where + diff --git a/ADP/Fusion/Core/Boundary.hs b/ADP/Fusion/Core/Boundary.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Boundary.hs @@ -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 #-} + diff --git a/ADP/Fusion/Core/EdgeBoundary.hs b/ADP/Fusion/Core/EdgeBoundary.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/EdgeBoundary.hs @@ -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 #-} + diff --git a/ADP/Fusion/Core/Set1.hs b/ADP/Fusion/Core/Set1.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Core/Set1.hs @@ -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 #-} + diff --git a/ADP/Fusion/EdgeBoundary.hs b/ADP/Fusion/EdgeBoundary.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/EdgeBoundary.hs @@ -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 + diff --git a/ADP/Fusion/Set1.hs b/ADP/Fusion/Set1.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Set1.hs @@ -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 + diff --git a/ADP/Fusion/SynVar/Indices/Set1.hs b/ADP/Fusion/SynVar/Indices/Set1.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/SynVar/Indices/Set1.hs @@ -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 #-} + diff --git a/ADP/Fusion/Term/Edge/EdgeBoundary.hs b/ADP/Fusion/Term/Edge/EdgeBoundary.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Edge/EdgeBoundary.hs @@ -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 #-} + diff --git a/ADP/Fusion/Term/Edge/Set1.hs b/ADP/Fusion/Term/Edge/Set1.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Edge/Set1.hs @@ -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 #-} + diff --git a/ADP/Fusion/Term/EdgeWithSet.hs b/ADP/Fusion/Term/EdgeWithSet.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/EdgeWithSet.hs @@ -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 + diff --git a/ADP/Fusion/Term/EdgeWithSet/EdgeBoundary.hs b/ADP/Fusion/Term/EdgeWithSet/EdgeBoundary.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/EdgeWithSet/EdgeBoundary.hs @@ -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 #-} + + diff --git a/ADP/Fusion/Term/EdgeWithSet/Set1.hs b/ADP/Fusion/Term/EdgeWithSet/Set1.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/EdgeWithSet/Set1.hs @@ -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 #-} + diff --git a/ADP/Fusion/Term/EdgeWithSet/Type.hs b/ADP/Fusion/Term/EdgeWithSet/Type.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/EdgeWithSet/Type.hs @@ -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) + diff --git a/ADP/Fusion/Term/Epsilon/Set1.hs b/ADP/Fusion/Term/Epsilon/Set1.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Epsilon/Set1.hs @@ -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 #-} +-} + diff --git a/ADP/Fusion/Term/Singleton/Set1.hs b/ADP/Fusion/Term/Singleton/Set1.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Singleton/Set1.hs @@ -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 #-} + diff --git a/ADP/Fusion/Term/Singleton/Type.hs b/ADP/Fusion/Term/Singleton/Type.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Term/Singleton/Type.hs @@ -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) + diff --git a/ADPfusionSet.cabal b/ADPfusionSet.cabal new file mode 100644 --- /dev/null +++ b/ADPfusionSet.cabal @@ -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: + + . + 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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 + diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,14 @@ + +module Main where + +import Test.Tasty +import Test.Tasty.TH + + + +main :: IO () +main = do + defaultMain $ testGroup "" + [ + ] +