diff --git a/ADP/Fusion.hs b/ADP/Fusion.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | Pure combinators along the lines of original ADP. We simply re-export the +-- monadic interface without the monadic function application combinator. + +module ADP.Fusion + ( module ADP.Fusion.Monadic + , module ADP.Fusion.Monadic.Internal + ) where + +import ADP.Fusion.Monadic hiding ((#<<)) +import ADP.Fusion.Monadic.Internal (Scalar(..)) diff --git a/ADP/Fusion/Monadic.hs b/ADP/Fusion/Monadic.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Monadic.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PackageImports #-} + +-- | Monadic combinators. Code like +-- +-- @f <<< xs ~~~ ys ... Stream.sum@ +-- +-- will generate efficient GHC core for a dynamic program comparable to +-- +-- @sum [ f (xs!(i,k)) (ys!(k,j)) | k<-[i..j]]@. + +module ADP.Fusion.Monadic where + +import "PrimitiveArray" Data.Array.Repa.Index +import qualified Data.Vector.Fusion.Stream.Monadic as S + +import ADP.Fusion.Monadic.Internal + + + +-- * Apply functions to arguments. + +-- | A monadic version of the function application combinator. Applies 'f' +-- which has a monadic effect. + +infixl 8 #<< +(#<<) f t ij = S.mapM (\(_,_,c) -> apply f c) $ streamGen t ij +{-# INLINE (#<<) #-} + +-- | Pure function application combinator. Applies 'f' which is pure. The +-- arguments to 'f', meaning 't' can be monadic, however! + +infixl 8 <<< +(<<<) f t ij = S.map (\(_,_,c) -> apply f c) $ streamGen t ij +{-# INLINE (<<<) #-} + + + +-- * Combine multiple right-hand sides of a non-terminal in a context-free +-- grammar. + +-- | If both, 'xs' and 'ys' are streams of candidate answers, they can be +-- combined here. The answer (or sort) type of 'xs' and 'ys' has to be the +-- same. Works like @(++)@ for lists. + +infixl 7 ||| +(|||) xs ys ij = xs ij S.++ ys ij +{-# INLINE [1] (|||) #-} + + + +-- * Reduce streams to single answers. +-- +-- NOTE "Single answers" can be of a vector-type! One is not constrained to +-- scalar results. This allows for many exiting algorithms. + +-- | Reduces a streams of answers to the type of stored answers. The resulting +-- type could be scalar, which it will be for highest-performance algorithms, +-- or it could be a subset of answers stored in some kind of data structure. + +infixl 6 ... +(...) stream h ij = h $ stream ij +{-# INLINE [2] (...) #-} + +-- | Specialized version of choice function application, with a choice function +-- that needs to know the subword index it is working on. + +infixl 6 ..@ +(..@) stream h ij = h ij $ stream ij +{-# INLINE (..@) #-} + + + +-- * Combinators to chain function arguments. + + + +-- ** General combinator creation. + +-- | General function to create combinators. The left-hand side @xs@ in @xs +-- `comb` ys@ will have a size between @minL@ and @maxL@, while @ys@ and +-- /everything to its right will be guaranteed @minR@ size. + +makeLeft_MinRight (minL,maxL) minR = comb where + {-# INLINE comb #-} + comb xs ys = Box mk step xs ys + {-# INLINE mk #-} + mk (z:.k:.j,a,b) = return (z:.k:.k+minL:.j,a,b) + {-# INLINE step #-} + step (z:.k:.l:.j,a,b) + | l<=j-minR && l<=k+maxL = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b) + | otherwise = return $ S.Done +{-# INLINE makeLeft_MinRight #-} + +-- | Create combinators which are to be used in the right-most position of a +-- chain. 1st, they make sure that the second to last region has a size of at +-- least 'minL'. 2nd, they constrain the last argument to a size between 'minR' +-- and 'maxR'. + +makeMinLeft_Right minL (minR,maxR) = comb where + {-# INLINE comb #-} + comb xs ys = Box mk step xs ys + {-# INLINE mk #-} + mk (z:.k:.j,a,b) = let l = max (k+minL) (j-maxR) in return (z:.k:.l:.j,a,b) + {-# INLINE step #-} + step (z:.k:.l:.j,a,b) + | l<=j-minR = return $ S.Yield (z:.k:.l:.j,a,b) (z:.k:.l+1:.j,a,b) + | otherwise = return $ S.Done +{-# INLINE makeMinLeft_Right #-} + + + +-- ** A number of often-used combinators. + +infixl 9 -~+, +~-, -~~, ~~- + +(-~+) = makeLeft_MinRight (1,1) 1 +{-# INLINE (-~+) #-} + +(+~-) = makeMinLeft_Right 1 (1,1) +{-# INLINE (+~-) #-} + +(-~~) = makeLeft_MinRight (1,1) 0 +{-# INLINE (-~~) #-} + +(~~-) = makeMinLeft_Right 0 (1,1) +{-# INLINE (~~-) #-} + +(+~--) = makeMinLeft_Right 1 (2,2) +{-# INLINE (+~--) #-} + +infixl 9 ~~~ +(~~~) xs ys = Box mk step xs ys where + {-# INLINE mk #-} + mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k:.j,vidx,vstack) + {-# INLINE step #-} + step (z:.k:.l:.j,vidx,vstack) + | l<=j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack) + | otherwise = return $ S.Done +{-# INLINE (~~~) #-} + +-- | @xs +~+ ys@ with @xs@ and @ys@ non-empty. The non-emptyness constraint on +-- @ys@ works only for two arguments. With three or more arguments, a +-- left-leaning combinator to the right of @ys@ is required to establish +-- non-emptyness. + +infixl 9 +~+ +(+~+) xs ys = Box mk step xs ys where + {-# INLINE mk #-} + mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack) + {-# INLINE step #-} + step (z:.k:.l:.j,vidx,vstack) + | l+1<=j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack) + | otherwise = return $ S.Done +{-# INLINE (+~+) #-} + +-- | @ls ~~~ xs !-~+ ys@ with xs having a size of one and @ls@ further to the +-- left having a size of one or more. + +infixl 9 !-~+ +(!-~+) xs ys = Box mk step xs ys where + {-# INLINE mk #-} + mk (z:.k:.j,vidx,vstack) + | k>0 = return $ (z:.k:.k+1:.j,vidx,vstack) + | otherwise = return $ (z:.k:.j+1:.j,vidx,vstack) + {-# INLINE step #-} + step (z:.k:.l:.j,vidx,vstack) + | l+1<=j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack) + | otherwise = return $ S.Done +{-# INLINE (!-~+) #-} + +-- | @xs +~-! ys ~~~ rs@ with @ys@ having a size of one and @rs@ further to the +-- right having a size of one. + +infixl 9 +~-! +(+~-!) xs ys = Box mk step xs ys where + {-# INLINE mk #-} + mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.j-2:.j,vidx,vstack) + {-# INLINE step #-} + step (z:.k:.l:.j,vidx,vstack) + | l+2==j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.j+1:.j,vidx,vstack) + | otherwise = return $ S.Done +{-# INLINE (+~-!) #-} + +-- | @xs -~- ys@ produces an answer only if both @xs@ and @ys@ have size one. +-- The total size here then is two. + +infixl 9 -~- +(-~-) xs ys = Box mk step xs ys where + {-# INLINE mk #-} + mk (z:.k:.j,vidx,vstack) = return $ (z:.k:.k+1:.j,vidx,vstack) + {-# INLINE step #-} + step (z:.k:.l:.j,vidx,vstack) + | k+1==l && l+1==j = return $ S.Yield (z:.k:.l:.j,vidx,vstack) (z:.k:.l+1:.j,vidx,vstack) + | otherwise = return $ S.Done +{-# INLINE (-~-) #-} + diff --git a/ADP/Fusion/Monadic/Internal.hs b/ADP/Fusion/Monadic/Internal.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/Monadic/Internal.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- | The internal working of ADPfusion. All combinator applications are turned +-- into efficient code during compile time. +-- +-- If you have a data structure to be used as an argument in a combinator +-- chain, derive an instance 'ExtractValue', 'StreamGen', and 'PreStreamGen'. +-- +-- NOTE: If this doesn't happen, it is a possible bug, or GHC changed its +-- optimizer (like with GHC 7.2 -> 7.4). +-- +-- TODO If possible, instance generation will be using the Generics system in +-- the future. + +module ADP.Fusion.Monadic.Internal where + +import Control.Monad.Primitive +import Control.Monad.ST +import Data.List (intersperse) +import Data.Primitive.Types +import Data.Vector.Fusion.Stream.Size +import "PrimitiveArray" Data.Array.Repa.Index +import "PrimitiveArray" Data.Array.Repa.Shape +import qualified Data.Vector.Fusion.Stream.Monadic as S +import qualified Data.Vector.Unboxed as VU +import Text.Printf + +import qualified Data.PrimitiveArray as PA +import qualified Data.PrimitiveArray.Unboxed.Zero as UZ +import qualified Data.PrimitiveArray.Zero as Z + + + +-- * StreamGen + +-- | Generate stream from either one (DIM2 -> m cnt) or some combination of +-- terminals derived from uses of nextTo. + +class Monad m => StreamGen m t r | t -> r where + streamGen :: t -> DIM2 -> S.Stream m r + +#define mkStreamGen(cnt) \ +instance (Monad m, ExtractValue m (cnt), Asor (cnt) ~ k, Elem (cnt) ~ elm) \ +=> StreamGen m (cnt) (DIM2,Z:.k,Z:.elm) where { \ + {-# INLINE streamGen #-} \ +; streamGen x ij = extractStreamLast x $ preStreamGen x ij } + +mkStreamGen(DIM2 -> Scalar elm) +mkStreamGen(DIM2 -> ScalarM elm) +mkStreamGen(DIM2 -> Vect elm) +mkStreamGen(DIM2 -> VectM elm) +mkStreamGen(UZ.MArr0 s sh elm) +mkStreamGen(UZ.Arr0 sh elm) + +mkStreamGen(Z.MArr0 s sh (VU.Vector elm)) +mkStreamGen(Z.Arr0 sh (VU.Vector elm)) + +-- | two or more elements combined by NextTo (~~~), "xs" as anything, "ys" is +-- monadic. + +instance + ( Monad m + , ExtractValue m cntY, Asor cntY ~ cY, Elem cntY ~ eY + , cntY ~ ys + , PreStreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX,arg:.eX) + , Idx2 _idx ~ idx + ) => StreamGen m (Box mk step xs ys) (idx:.Int,adx:.cX:.cY,arg:.eX:.eY) where + streamGen (Box mk step xs ys) ij + = extractStreamLast ys + $ preStreamGen (Box mk step xs ys) ij + {-# INLINE streamGen #-} + + + +-- * PreStreamGen + +-- | Required by most 'StreamGen' instances just before 'extractStreamLast' is +-- called. + +class Monad m => PreStreamGen m s q | s -> q where + preStreamGen + :: s -- ^ the composite type of the arguments + -> DIM2 -- ^ the original index @(Z:.i:.j)@ + -> S.Stream m q -- ^ the stream we get out of it + +-- | Creates the single step on the left which does nothing more then set the +-- outermost indices to (i,j). This does not use the alpha/omega's + +singlePreStreamGen ij = S.unfoldr step ij where + {-# INLINE step #-} + step (Z:.i:.j) + | i<=j = Just ((Z:.i:.j ,Z,Z), Z:.j+1:.j) + | otherwise = Nothing +{-# INLINE singlePreStreamGen #-} + +#define mkPreStreamGen(s) \ +instance (Monad m) => PreStreamGen m (s) (DIM2,Z,Z) where { \ + {-# INLINE preStreamGen #-} \ +; preStreamGen _ = singlePreStreamGen } + +mkPreStreamGen(DIM2 -> Scalar elm) +mkPreStreamGen(DIM2 -> ScalarM elm) +mkPreStreamGen(DIM2 -> Vect elm) +mkPreStreamGen(DIM2 -> VectM elm) +mkPreStreamGen(UZ.MArr0 s sh elm) +mkPreStreamGen(UZ.Arr0 sh elm) + +mkPreStreamGen(Z.MArr0 s sh (VU.Vector elm)) +mkPreStreamGen(Z.Arr0 sh (VU.Vector elm)) + +-- | the first two arguments from nextTo, monadic xs. + +instance ( Monad m + , ExtractValue m cntX, Asor cntX ~ cX, Elem cntX ~ eX + , cntX ~ xs + , PreStreamGen m xs xsStack + , (idxX,adxX,argX) ~ xsStack + , (z0:.Int:.Int) ~ idxX + , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk + , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step + ) => PreStreamGen m (Box mk step xs ys) (idxX:.Int,adxX:.cX,argX:.eX) where + preStreamGen (Box mk step xs ys) ij + = extractStream xs + $ S.flatten mk step Unknown + $ preStreamGen xs ij + {-# INLINE preStreamGen #-} + +-- | Pre-stream generation for deeply nested boxes. + +instance + ( Monad m + , ExtractValue m cntX, Asor cntX ~ cX, Elem cntX ~ eX + , cntX ~ xs + , PreStreamGen m (Box box2 box3 box1 xs) xsStack + , (idxX,adxX,argX) ~ xsStack + , (z0:.Int:.Int) ~ idxX + , ((idxX,adxX,argX) -> m (idxX:.Int,adxX,argX)) ~ mk + , ((idxX:.Int,adxX,argX) -> m (S.Step (idxX:.Int,adxX,argX) (idxX:.Int,adxX,argX))) ~ step + ) => PreStreamGen m (Box mk step (Box box2 box3 box1 xs) ys) (idxX:.Int,adxX:.cX,argX:.eX) where + preStreamGen (Box mk step box@(Box _ _ _ xs) ys) ij + = extractStream xs + $ S.flatten mk step Unknown + $ preStreamGen box ij + {-# INLINE preStreamGen #-} + + + +-- * ExtractValue: extract values from data structures. + +class (Monad m) => ExtractValue m cnt where + type Asor cnt :: * + type Elem cnt :: * + extractValue :: () + => cnt + -> DIM2 + -> Asor cnt + -> m (Elem cnt) + extractStream :: () + => cnt + -> S.Stream m (Idx3 z,astack,vstack) + -> S.Stream m (Idx3 z,astack:.Asor cnt,vstack:.Elem cnt) + extractStreamLast :: () + => cnt + -> S.Stream m (Idx2 z,astack,vstack) + -> S.Stream m (Idx2 z,astack:.Asor cnt,vstack:.Elem cnt) + +-- | Mutable arrays. + +instance + ( PrimMonad m + , Prim elm + , PrimState m ~ s + , DIM2 ~ sh + ) => ExtractValue m (UZ.MArr0 s sh elm) where + type Asor (UZ.MArr0 s sh elm) = Z + type Elem (UZ.MArr0 s sh elm) = elm + extractValue cnt ij z = do + x <- PA.readM cnt ij + x `seq` return x + extractStream cnt stream = S.mapM addElm stream where + addElm (z:.k:.x:.l, astack, vstack) = do + vadd <- extractValue cnt (Z:.k:.x) Z + vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd) + extractStreamLast sngl stream = S.mapM addElm stream where + addElm (z:.k:.x, astack, vstack) = do + vadd <- extractValue sngl (Z:.k:.x) Z + vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd) + {-# INLINE extractValue #-} + {-# INLINE extractStream #-} + {-# INLINE extractStreamLast #-} + +-- | Immutable arrays. + +instance + ( Monad m + , Prim elm + , DIM2 ~ sh + ) => ExtractValue m (UZ.Arr0 sh elm) where + type Asor (UZ.Arr0 sh elm) = Z + type Elem (UZ.Arr0 sh elm) = elm + extractValue cnt ij z = do + let x = PA.index cnt ij + x `seq` return x + extractStream cnt stream = S.map addElm stream where + addElm (z:.k:.x:.l, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in + vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd) + extractStreamLast cnt stream = S.map addElm stream where + addElm (z:.k:.x, astack, vstack) = let vadd = PA.index cnt (Z:.k:.x) in + vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd) + {-# INLINE extractValue #-} + {-# INLINE extractStream #-} + {-# INLINE extractStreamLast #-} + +-- | Function with 'Scalar' return value. + +instance + ( Monad m + ) => ExtractValue m (DIM2 -> Scalar elm) where + type Asor (DIM2 -> Scalar elm) = Z + type Elem (DIM2 -> Scalar elm) = elm + extractValue cnt ij z = do + let Scalar x = cnt ij + x `seq` return x + extractStream cnt stream = S.map addElm stream where + addElm (z:.k:.x:.l, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in + vadd `seq` (z:.k:.x:.l, astack:.Z, vstack :. vadd) + extractStreamLast cnt stream = S.map addElm stream where + addElm (z:.k:.x, astack, vstack) = let Scalar vadd = cnt (Z:.k:.x) in + vadd `seq` (z:.k:.x, astack:.Z, vstack:.vadd) + {-# INLINE extractValue #-} + {-# INLINE extractStream #-} + {-# INLINE extractStreamLast #-} + +-- | Function with monadic 'Scalar' return value. + +instance + ( Monad m + ) => ExtractValue m (DIM2 -> ScalarM (m elm)) where + type Asor (DIM2 -> ScalarM (m elm)) = Z + type Elem (DIM2 -> ScalarM (m elm)) = elm + extractValue cnt ij z = do + let ScalarM x' = cnt ij + x <- x' + x `seq` return x + extractStream cnt stream = S.mapM addElm stream where + addElm (z:.k:.x:.l, astack, vstack) = do + let ScalarM vadd' = cnt (Z:.k:.x) + vadd <- vadd' + vadd `seq` return (z:.k:.x:.l, astack:.Z, vstack :. vadd) + extractStreamLast cnt stream = S.mapM addElm stream where + addElm (z:.k:.x, astack, vstack) = do + let ScalarM vadd' = cnt (Z:.k:.x) + vadd <- vadd' + vadd `seq` return (z:.k:.x, astack:.Z, vstack:.vadd) + {-# INLINE extractValue #-} + {-# INLINE extractStream #-} + {-# INLINE extractStreamLast #-} + +-- | This instance is a bit crazy, since the accessor is the current stream +-- itself. No idea how efficient this is (need to squint at CORE), but I plan +-- to use it for backtracking only. +-- +-- TODO Using this instance tends to break to optimizer ;-) -- don't use it +-- yet! + +instance + ( Monad m + ) => ExtractValue m (DIM2 -> S.Stream m elm) where + type Asor (DIM2 -> S.Stream m elm) = S.Stream m elm + type Elem (DIM2 -> S.Stream m elm) = elm + extractValue cnt ij z = error "this function is not well-defined for these streams" + extractStream cnt stream = S.flatten mk step Unknown $ stream where + mk (z:.k:.l:.j,as,vs) = do + let strm = cnt (Z:.k:.l) + return (z:.k:.l:.j,as:.strm,vs) + step (idx,as:.strm,vs) = do + isNull <- S.null strm + if isNull + then return $ S.Done + else do hd <- S.head strm + hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs) + extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where + mk (z:.l:.j,as,vs) = do + let strm = cnt (Z:.l:.j) + return (z:.l:.j,as:.strm,vs) + step (idx,as:.strm,vs) = do + isNull <- S.null strm + if isNull + then return $ S.Done + else do hd <- S.head strm + hd `seq` return $ S.Yield (idx,as:.strm,vs:.hd) (idx,as:.S.tail strm,vs) + {-# INLINE extractValue #-} + {-# INLINE extractStream #-} + {-# INLINE extractStreamLast #-} + +-- | Instance of boxed array with vector-valued cells. We assume that we want +-- to store multiple results for each cell. If the intent is to store one +-- scalar result, use the 'Scalar' wrapper. + +instance + ( PrimMonad m + , Prim elm + , VU.Unbox elm + , PrimState m ~ s + , DIM2 ~ sh + ) => ExtractValue m (Z.MArr0 s sh (VU.Vector elm)) where + type Asor (Z.MArr0 s sh (VU.Vector elm)) = Int + type Elem (Z.MArr0 s sh (VU.Vector elm)) = elm + extractValue cnt ij z = do + x <- PA.readM cnt ij + let y = x `VU.unsafeIndex` z + y `seq` return y + extractStream cnt stream = S.flatten mk step Unknown $ stream where + mk (idx,as,vs) = return (idx,as:.0,vs) + step (z:.k:.l:.j,as:.a,vs) = do + x <- PA.readM cnt (Z:.k:.l) + case (x VU.!? a) of + Just v -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs) + Nothing -> return $ S.Done + extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where + mk (idx,as,vs) = return (idx,as:.0,vs) + step (z:.l:.j,as:.a,vs) = do + x <- PA.readM cnt (Z:.l:.j) + case (x VU.!? a) of + Just v -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs) + Nothing -> return $ S.Done + {-# INLINE extractValue #-} + {-# INLINE extractStream #-} + {-# INLINE extractStreamLast #-} + +-- | vector-based cells + +instance + ( Monad m + , Prim elm + , VU.Unbox elm + , DIM2 ~ sh + ) => ExtractValue m (Z.Arr0 sh (VU.Vector elm)) where + type Asor (Z.Arr0 sh (VU.Vector elm)) = Int + type Elem (Z.Arr0 sh (VU.Vector elm)) = elm + extractValue cnt ij z = do + let x = PA.index cnt ij + let y = x `VU.unsafeIndex` z + y `seq` return y + extractStream cnt stream = S.flatten mk step Unknown $ stream where + mk (idx,as,vs) = return (idx,as:.0,vs) + step (z:.k:.l:.j,as:.a,vs) = do + let x = PA.index cnt (Z:.k:.l) + case (x VU.!? a) of + Just v -> v `seq` return $ S.Yield (z:.k:.l:.j,as:.a,vs:.v) (z:.k:.l:.j,as:.(a+1),vs) + Nothing -> return $ S.Done + extractStreamLast cnt stream = S.flatten mk step Unknown $ stream where + mk (idx,as,vs) = return (idx,as:.0,vs) + step (z:.l:.j,as:.a,vs) = do + let x = PA.index cnt (Z:.l:.j) + case (x VU.!? a) of + Just v -> v `seq` return $ S.Yield (z:.l:.j,as:.a,vs:.v) (z:.l:.j,as:.(a+1),vs) + Nothing -> return $ S.Done + {-# INLINE extractValue #-} + {-# INLINE extractStream #-} + {-# INLINE extractStreamLast #-} + + +-- * Apply function 'f' with arguments on a stack 'x'. +-- +-- NOTE look at the end of this part for mkApply before writing instances by +-- hand... ;-) + +class Apply x where + type Fun x :: * + apply :: Fun x -> x + +instance Apply (Z:.a -> res) where + type Fun (Z:.a -> res) = a -> res + apply fun (Z:.a) = fun a + {-# INLINE apply #-} + +instance Apply (Z:.a:.b -> res) where + type Fun (Z:.a:.b -> res) = a->b -> res + apply fun (Z:.a:.b) = fun a b + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c -> res) where + type Fun (Z:.a:.b:.c -> res) = a->b->c -> res + apply fun (Z:.a:.b:.c) = fun a b c + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d -> res) where + type Fun (Z:.a:.b:.c:.d -> res) = a->b->c->d -> res + apply fun (Z:.a:.b:.c:.d) = fun a b c d + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e -> res) where + type Fun (Z:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res + apply fun (Z:.a:.b:.c:.d:.e) = fun a b c d e + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res + apply fun (Z:.a:.b:.c:.d:.e:.f) = fun a b c d e f + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n + {-# INLINE apply #-} + +instance Apply (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where + type Fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res + apply fun (Z:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o + {-# INLINE apply #-} + +{- +mkApply to = do + let xs = ['a' .. to] + let args = concat . (":.":) . intersperse ":." . map (:[]) $ xs + let arga = concat . intersperse "->" . map (:[]) $ xs + let args' = intersperse ' ' xs + printf "instance Apply (Z%s -> res) where\n" args + printf " type Fun (Z%s -> res) = %s -> res\n" args arga + printf " apply fun (Z%s) = fun %s\n" args args' + printf " {-# INLINE apply #-}\n" +-} + + + +-- * helper stuff + +data Box mk step xs ys = Box mk step xs ys + +type Idx3 z = z:.Int:.Int:.Int + +type Idx2 z = z:.Int:.Int + + + +-- * wrappers for functions instead of arrays as arguments. It can be much +-- cheaper in terms of writing code to just provide a function @DIM2 -> Scalar +-- a@ instead of writing instances for your data structure. + +newtype Scalar a = Scalar {unScalar :: a} + +newtype ScalarM a = ScalarM {unScalarM :: a} + +newtype Vect a = Vect {unVect :: a} + +newtype VectM a = VectM {unVectM :: a} diff --git a/ADP/Fusion/QuickCheck.hs b/ADP/Fusion/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/ADP/Fusion/QuickCheck.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | QuickCheck properties for a number of ADPfusion combinators. Each test is +-- once written using ADPfusion and once using list comprehensions. Typing +-- @allProps@ in ghci will run all tests, prefixed @prop_@ with a thousand +-- tests each. + +module ADP.Fusion.QuickCheck where + +import Data.List +import Data.Vector.Fusion.Stream.Size +import Data.Vector.Fusion.Util +import qualified Data.Vector.Fusion.Stream as S +import qualified Data.Vector.Unboxed as VU +import Test.QuickCheck +import Test.QuickCheck.All + +import "PrimitiveArray" Data.Array.Repa.Index + +import ADP.Fusion.QuickCheck.Arbitrary +import qualified ADP.Fusion as F +import qualified ADP.Fusion.Monadic as M +import qualified ADP.Fusion.Monadic.Internal as F + + + +options = stdArgs {maxSuccess = 1000} + +customCheck = quickCheckWithResult options + +allProps = $forAllProperties customCheck + + + +-- * Some definitions: +-- +-- @O@ means one +-- @M@ means many +-- @P@ means one or more +-- @ML_x_y@ is for a makeLeftCombinator with boundaries x and y + +-- ** @xs -~+ ys@, size @xs@ = 1, size @ys@ >= 1. + +fOP (i,j) = S.toList $ (,) F.<<< fRegion F.-~+ fRegion F.... id $ Z:.i:.j + +lOP (i,j) = [ ((i,i+1), (i+1,j)) | i+1<=j-1 ] + +prop_OP = fOP === lOP + +-- ** @xs -~~ ys -~~ zs@, size @xs@ = 1, size @ys@ = 1, size @zs@ >= 0. + +fOOP (i,j) = S.toList $ (,,) F.<<< fRegion F.-~~ fRegion F.-~~ fRegion F.... id $ Z:.i:.j + +lOOP (i,j) = [ ( (i,i+1), (i+1,i+2), (i+2,j) ) | i+2<=j ] + +prop_OOP = fOOP === lOOP + +-- ** @xs +~- ys@, size @xs@ >= 1, size @ys@ = 1. + +fPO (i,j) = S.toList $ (,) F.<<< fRegion F.+~- fRegion F.... id $ Z:.i:.j + +lPO (i,j) = [ ( (i,j-1), (j-1,j) ) | i+1<=j-1 ] + +prop_PO (Small i, Small j) = fPO (i,j) == lPO (i,j) + +-- ** @xs -~+ ys +~- zs@, size @xs@ = 1, size @ys@ >= 1, size @zs@ = 1. This is +-- a "hairpin" in RNA bioinformatics. + +fOPO (i,j) = S.toList $ (,,) F.<<< fRegion F.-~+ fRegion F.+~- fRegion F.... id $ Z:.i:.j + +lOPO (i,j) = [ ( (i,i+1), (i+1,j-1), (j-1,j) ) | i+2<=j, i+1 (F.Scalar Int) +fAchar (Z:.i:.j) = F.Scalar $ (i+1) + +fRegion :: DIM2 -> (F.Scalar (Int,Int)) +fRegion (Z:.i:.j) = F.Scalar $ (i,j) + +-- * quickcheck stuff + +newtype Small = Small Int + deriving (Show) + +instance Arbitrary Small where + arbitrary = Small `fmap` choose (0,50) + shrink (Small x) + | x>0 = [Small $ x-1] + | otherwise = [] + +small x = x>=0 && x <=50 + +(===) f g (Small i, Small j) = f (i,j) == g (i,j) + diff --git a/ADPfusion.cabal b/ADPfusion.cabal new file mode 100644 --- /dev/null +++ b/ADPfusion.cabal @@ -0,0 +1,92 @@ +name: ADPfusion +version: 0.0.1.0 +author: Christian Hoener zu Siederdissen, 2011-2012 +copyright: Christian Hoener zu Siederdissen, 2011-2012 +homepage: http://www.tbi.univie.ac.at/~choener/adpfusion +maintainer: choener@tbi.univie.ac.at +category: Algorithms, Data Structures, Bioinformatics +license: BSD3 +license-file: LICENSE +build-type: Simple +stability: experimental +cabal-version: >= 1.6.0 +synopsis: + Efficient, high-level dynamic programming. +description: + ADPfusion combines stream-fusion (using the stream interface + provided by the vector library) and type-level programming to + provide highly efficient dynamic programming combinators. + . + From the programmers' viewpoint, ADPfusion behaves very much + like the original ADP implementation + developed by + Robert Giegerich and colleagues, though both combinator + semantics and backtracking are different. + . + The library internals, however, are designed not only to speed + up ADP by a large margin (which this library does), but also to + provide further runtime improvements by allowing the programmer + to switch over to other kinds of data structures with better + time and space behaviour. Most importantly, dynamic programming + tables can be strict, removing indirections present in lazy, + boxed tables. + . + As an example, even rather complex ADP code tends to be + completely optimized to loops that use only unboxed variables + (Int# and others, indexIntArray# and others). + . + Completely novel (compared to ADP), is the idea of allowing + efficient monadic combinators. This facilitates writing code + that performs backtracking, or samples structures + stochastically, among others things. + . + This version is still highly experimental and makes use of + multiple recent improvements in GHC. This is particularly true + for the monadic interface. + . + Long term goals: Outer indices with more than two dimensions, + specialized table design, a combinator library, a library for + computational biology. + . + If possible, build using the GHC llvm backend, and GHC-7.2.2. + GHC-7.4.x produces very bad code on my system, please benchmark + using 7.2.2. + . + Two algorithms from the realm of computational biology are + provided as examples on how to write dynamic programming + algorithms using this library: + and + . + +Extra-Source-Files: + README.md + ADP/Fusion/QuickCheck.hs + ADP/Fusion/QuickCheck/Arbitrary.hs + +Flag llvm + description: build using llvm backend + default: True + +library + build-depends: + base >= 4 && < 5, + primitive == 0.4.* , + vector == 0.9.* , + PrimitiveArray == 0.2.1.1 + exposed-modules: + ADP.Fusion + ADP.Fusion.Monadic + ADP.Fusion.Monadic.Internal + + ghc-options: + -Odph -funbox-strict-fields -fspec-constr + if flag(llvm) + ghc-options: + -fllvm -optlo-O3 -optlo-inline -optlo-std-compile-opts + + + +source-repository head + type: git + location: git://github.com/choener/ADPfusion + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Christian Hoener zu Siederdissen 2011-2012 + +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,121 @@ + +ADPfusion +(c) 2012, Christian Hoener zu Siederdissen +University of Vienna, Vienna, Austria +choener@tbi.univie.ac.at +LICENSE: BSD3 + + + +Introduction +============ + +ADPfusion combines stream-fusion (using the stream interface provided by the +vector library) and type-level programming to provide highly efficient dynamic +programming combinators. + +From the programmers' viewpoint, ADPfusion behaves very much like the original +ADP implementation developed by +Robert Giegerich and colleagues, though both combinator semantics and +backtracking are different. + +The library internals, however, are designed not only to speed up ADP by a +large margin (which this library does), but also to provide further runtime +improvements by allowing the programmer to switch over to other kinds of data +structures with better time and space behaviour. Most importantly, dynamic +programming tables can be strict, removing indirections present in lazy, boxed +tables. + +As an example, even rather complex ADP code tends to be completely optimized to +loops that use only unboxed variables (Int# and others, indexIntArray# and +others). + +Completely novel (compared to ADP), is the idea of allowing efficient monadic +combinators. This facilitates writing code that performs backtracking, or +samples structures stochastically, among others things. + +This version is still highly experimental and makes use of multiple recent +improvements in GHC. This is particularly true for the monadic interface. + +Long term goals: Outer indices with more than two dimensions, specialized table +design, a combinator library, a library for computational biology. + +If possible, build using the GHC llvm backend, and GHC-7.2.2. GHC-7.4.x +produces very bad code on my system, please benchmark using 7.2.2. + +Two algorithms from the realm of computational biology are provided as examples +on how to write dynamic programming algorithms using this library: + and +. + + +Installation +============ + +Please use GHC-7.2.2, if possible. GHC-7.4 currently seems to have problems +optimizing vector-dependent code: +http://hackage.haskell.org/trac/ghc/ticket/5539 +(and others?) + +If GHC-7.2.2, LLVM and cabal-install are available, you should be all set. I +recommend using cabal-dev as it provides a very nice sandbox (replace cabal-dev +with cabal otherwise). + +If you go with cabal-dev, no explicit installation is necessary and ADPfusion +will be installed in the sandbox together with the example algorithms or your +own. + +For a more global installation, "cabal install ADPfusion" should do the trick. + +To run the Quickcheck tests, do an additional "cabal-dev install QuickCheck", +then "cabal-dev ghci", ":l ADP/Fusion/QuickCheck.hs", and "allProps". Loading +the quickcheck module should take a bit due to compilation. "allProps" tests +all properties and should yield no errors. + + + +Notes +===== + +If you have problems, find bugs, or want to use this library to write your own +DP algorithms, please send me a mail. I'm very interested in hearing what is +missing. + +One of the things I'll be integrating is an extension to higher dimensions +(more than two). + +Right now, I am not quite happy with the construction and destruction of the +"Box" representations. These will change soon. In addition, an analysis of the +actual combinators should remove the need for nested applications of objective +functions in many cases. + + + +VERSION HISTORY +=============== + +- 0.0.0.3: + - initial version, together with submitted paper + +- 0.0.0.4: + - based most combinators on just two generalized Box creators + - cleaned up and simplified RNAfold example + - RNAfold execution now a bit slower. Simplified energy functions typically + only have three arguments now, which can be of 'Primary' type. While this + reduces speed because we will repeatedly ask for the same value, it is much + easier to handle the different functions and ``play'' with fusion + properties. + - RNAfold compilation massively faster: execution/compilation tradoff is + worth it for experimenting with ADPfusion; still faster than anything + except RNAfold itself. We are now now 2.8x times slower, but 3.5x times + slower + - Quickcheck properties for many combinators + - Unit tests for RNAfold functions + - will soon split off RNAfold and Nussinov and publish three hackage + libraries + - this version was never available, after being done, a split into library + and examples was performed. + +- 0.0.1.0 + - providing just the library. Examples are found in different libraries. + 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