adp-multi 0.1.0 → 0.1.1
raw patch · 11 files changed
+1054/−39 lines, 11 filesdep +adp-multidep −mtldep ~containers
Dependencies added: adp-multi
Dependencies removed: mtl
Dependency ranges changed: containers
Files
- adp-multi.cabal +48/−39
- src/ADP/Debug.hs +6/−0
- tests/ADP/Combinators.hs +149/−0
- tests/ADP/Tests/AlignmentExample.hs +90/−0
- tests/ADP/Tests/CopyExample.hs +73/−0
- tests/ADP/Tests/CopyTwoTrackExample.hs +62/−0
- tests/ADP/Tests/MonadicCpRegression.hs +49/−0
- tests/ADP/Tests/MonadicCpTest.hs +55/−0
- tests/ADP/Tests/Nussinov.lhs +191/−0
- tests/ADP/Tests/NussinovExample.hs +67/−0
- tests/ADP/Tests/RGExampleDim2.hs +264/−0
adp-multi.cabal view
@@ -1,5 +1,5 @@ name: adp-multi -version: 0.1.0 +version: 0.1.1 cabal-version: >= 1.8 build-type: Simple author: Maik Riechert @@ -30,87 +30,96 @@ library build-depends: base == 4.*, array == 0.4.*, - containers == 0.5.*, + containers >= 0.4 && <= 0.5, htrace == 0.1.*, - mtl == 2.1.*, monadiccp == 0.7.* hs-source-dirs: src ghc-options: -Wall - exposed-modules: ADP.Multi.Combinators, + exposed-modules: ADP.Debug, + ADP.Multi.Combinators, ADP.Multi.Helpers, ADP.Multi.Parser, + ADP.Multi.Rewriting, ADP.Multi.Rewriting.ConstraintSolver, ADP.Multi.Rewriting.Explicit, + ADP.Multi.Rewriting.YieldSize, ADP.Multi.SimpleParsers, ADP.Multi.Tabulation + other-modules: ADP.Multi.Rewriting.MonadicCpHelper test-suite MainTestSuite type: exitcode-stdio-1.0 x-uses-tf: true build-depends: base == 4.*, + array == 0.4.*, + containers >= 0.4 && <= 0.5, + adp-multi, + monadiccp == 0.7.*, HUnit == 1.2.*, QuickCheck == 2.5.*, test-framework == 0.6.*, test-framework-quickcheck2 == 0.2.*, test-framework-hunit == 0.2.*, random-shuffle == 0.0.4 - hs-source-dirs: src, - tests + hs-source-dirs: tests ghc-options: -Wall -rtsopts other-modules: - ADP.Multi.Combinators, - ADP.Multi.Helpers, - ADP.Multi.Parser, - ADP.Multi.Rewriting, - ADP.Multi.Rewriting.ConstraintSolver, - ADP.Multi.Rewriting.Explicit, - ADP.Multi.Rewriting.MonadicCpHelper, + ADP.Combinators, ADP.Multi.Rewriting.Tests.YieldSize, - ADP.Multi.Rewriting.YieldSize, - ADP.Multi.SimpleParsers, - ADP.Multi.Tabulation, + ADP.Tests.AlignmentExample, + ADP.Tests.CopyExample, + ADP.Tests.CopyTwoTrackExample, ADP.Tests.Main, + ADP.Tests.MonadicCpRegression, + ADP.Tests.MonadicCpTest, ADP.Tests.NestedExample, + ADP.Tests.Nussinov, + ADP.Tests.NussinovExample, ADP.Tests.OneStructureExample, ADP.Tests.RGExample, + ADP.Tests.RGExampleDim2, ADP.Tests.RIGExample, ADP.Tests.ZeroStructureTwoBackbonesExample main-is: ADP/Tests/Suite.hs executable adp-multi-benchmarks - if flag(buildTests) - build-depends: base == 4.*, - criterion == 0.6.* - else + if !flag(buildTests) buildable: False + build-depends: + base == 4.*, + array == 0.4.*, + containers >= 0.4 && <= 0.5, + adp-multi, + monadiccp == 0.7.*, + HUnit == 1.2.*, + QuickCheck == 2.5.*, + test-framework == 0.6.*, + test-framework-quickcheck2 == 0.2.*, + test-framework-hunit == 0.2.*, + random-shuffle == 0.0.4, + criterion == 0.6.* hs-source-dirs: benchmarks, - src, tests ghc-options: -Wall -rtsopts - other-modules: - ADP.Tests.RGExample, - ADP.Tests.NestedExample, - ADP.Tests.RIGExample, - ADP.Tests.OneStructureExample, - ADP.Tests.ZeroStructureTwoBackbonesExample main-is: Benchmarks.hs executable adp-test if !flag(buildTests) buildable: False - build-depends: base == 4.* - hs-source-dirs: - src, - tests + build-depends: + base == 4.*, + array == 0.4.*, + containers >= 0.4 && <= 0.5, + adp-multi, + monadiccp == 0.7.*, + HUnit == 1.2.*, + QuickCheck == 2.5.*, + test-framework == 0.6.*, + test-framework-quickcheck2 == 0.2.*, + test-framework-hunit == 0.2.*, + random-shuffle == 0.0.4 + hs-source-dirs: tests ghc-options: -Wall -rtsopts -O0 main-is: ADP/Tests/Main.hs - other-modules: - ADP.Multi.Rewriting.ConstraintSolver, - ADP.Multi.Rewriting.Explicit, - ADP.Tests.RGExample, - ADP.Tests.NestedExample, - ADP.Tests.RIGExample, - ADP.Tests.OneStructureExample, - ADP.Tests.ZeroStructureTwoBackbonesExample
+ src/ADP/Debug.hs view
@@ -0,0 +1,6 @@+module ADP.Debug where + +import Debug.HTrace (htrace) + +trace _ b = b +--trace = htrace
+ tests/ADP/Combinators.hs view
@@ -0,0 +1,149 @@+{- +ADP combinators and functions from: + +R. Giegerich, C. Meyer and P. Steffen. Towards a discipline of dynamic +programming. +-} + +module ADP.Combinators where +import Data.Array + +-- # Lexical parsers + + +type Subword = (Int,Int) +type Parser b = Subword -> [b] + +empty :: Parser () +empty (i,j) = [() | i == j] + +acharSep' :: Array Int Char -> Char -> Parser Char +acharSep' z s (i,j) = [z!j | i+1 == j, z!j /= s] + +achar' :: Array Int a -> Parser a +achar' z (i,j) = [z!j | i+1 == j] + +char' :: Eq a => Array Int a -> a -> Parser a +char' z c (i,j) = [c | i+1 == j, z!j == c] + +astring :: Parser Subword +astring (i,j) = [(i,j) | i <= j] + +string' :: Eq a => Array Int a -> [a] -> Parser Subword +string' z s (i,j) = [(i,j)| and [z!(i+k) == s!!(k-1) | k <-[1..(j-i)]]] + +-- # Parser combinators + +infixr 6 ||| +(|||) :: Parser b -> Parser b -> Parser b +(|||) r q (i,j) = r (i,j) ++ q (i,j) + +infix 8 <<< +(<<<) :: (b -> c) -> Parser b -> Parser c +(<<<) f q (i,j) = map f (q (i,j)) + +infixl 7 ~~~ +(~~~) :: Parser (b -> c) -> Parser b -> Parser c +(~~~) r q (i,j) = [f y | k <- [i..j], f <- r (i,k), y <- q (k,j)] + +infix 5 ... +(...) :: Parser b -> ([b] -> [b]) -> Parser b +(...) r h (i,j) = h (r (i,j)) + + +type Filter = (Int, Int) -> Bool +with :: Parser b -> Filter -> Parser b +with q c (i,j) = if c (i,j) then q (i,j) else [] + +axiom' :: Int -> Parser b -> [b] +axiom' l ax = ax (0,l) + +-- # Tabulation + +-- two-dimensional tabulation +table :: Int -> Parser b -> Parser b +table n q = (!) $ array ((0,0),(n,n)) + [((i,j),q (i,j)) | i<- [0..n], j<- [i..n]] + +-- one-dimensional tabulation; index j fixed +listi :: Int -> Parser b -> Parser b +listi n p = q $ array (0,n) [(i, p (i,n)) | i <- [0..n]] + where + q t (i,j) = if j==n then t!i else [] + +-- one-dimensional tabulation; index i fixed +listj :: Int -> Parser b -> Parser b +listj n p = q $ array (0,n) [(j, p (0,j)) | j <- [0..n]] + where + q t (i,j) = if i==0 then t!j else [] + +-- the most common listed type is listi (input read from left +-- to right), so we define a default list here: +list :: Int -> Parser b -> Parser b +list = listi + +-- # Variants of the <<< and ~~~ Combinators + +infix 8 ><< +infixl 7 ~~, ~~*, *~~, *~* +infixl 7 -~~, ~~-, +~~, ~~+, +~+ + +-- The operator ><< is the special case of <<< for a nullary function f + +(><<) :: c -> Parser b -> Parser c +(><<) f q (i,j) = [f|a <- (q (i,j))] + +-- Subwords on left and right of an explicit length range. + +(~~) :: (Int,Int) -> (Int,Int) + -> Parser (b -> c) -> Parser b -> Parser c +(~~) (l,u) (l',u') r q (i,j) + = [x y | k <- [max (i+l) (j-u') .. min (i+u) (j-l')], + x <- r (i,k), y <- q (k,j)] + +-- Subwords of explicit length range and unbounded length on one or on either side. + +(~~*) :: (Int,Int) -> Int + -> Parser (a -> b) -> Parser a -> Parser b +(~~*) (l, u) l' r q (i, j) + = [x y | k <- [(i + l) .. min (i + u) (j - l')], + x <- r (i, k), y <- q (k, j)] + +(*~~) :: Int -> (Int,Int) + -> Parser (a -> b) -> Parser a -> Parser b +(*~~) l (l', u') r q (i, j) + = [x y | k <- [max (i + l) (j - u') .. (j - l')], + x <- r (i, k), y <- q (k, j)] + +(*~*) :: Int -> Int + -> Parser (a -> b) -> Parser a -> Parser b +(*~*) l l' r q (i, j) + = [x y | k <- [(i + l) .. (j - l')], + x <- r (i, k), y <- q (k, j)] + +-- Single character on the lefthand (respectively righthand) side + +(-~~) :: Parser (b -> c) -> Parser b -> Parser c +(-~~) q r (i,j) = [x y | i<j, x <- q (i,i+1), y <- r (i+1,j)] + +(~~-) :: Parser (b -> c) -> Parser b -> Parser c +(~~-) q r (i,j) = [x y | i<j, x <- q (i,j-1), y <- r (j-1,j)] + +-- Nonempty sequence on the lefthand (respectively righthand) side + +(+~~) :: Parser (b -> c) -> Parser b -> Parser c +(+~~) r q (i,j) = [f y | k <- [i+1..j], f <- r (i,k), y <- q (k,j)] + +(~~+) :: Parser (b -> c) -> Parser b -> Parser c +(~~+) r q (i,j) = [f y | k <- [i..j-1], f <- r (i,k), y <- q (k,j)] + +-- Nonempty sequence on either side + +(+~+) :: Parser (b -> c) -> Parser b -> Parser c +(+~+) r q (i,j) = [f y | k <- [(i+1)..(j-1)], f <- r (i,k), y <- q (k,j)] + + +-- # Create array from List + +mk :: [a] -> Array Int a +mk xs = array (1,n) (zip [1..n] xs) where n = length xs
+ tests/ADP/Tests/AlignmentExample.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ImplicitParams #-} + +-- Needleman/Wunsch global alignment +module ADP.Tests.AlignmentExample where + +import ADP.Debug +import ADP.Multi.SimpleParsers +import ADP.Multi.Combinators +import ADP.Multi.Tabulation +import ADP.Multi.Helpers +import ADP.Multi.Rewriting + +type Alignment_Algebra alphabet answer = ( + (EPS,EPS) -> answer, -- nil + alphabet -> answer -> answer, -- del + alphabet -> answer -> answer, -- ins + alphabet -> alphabet -> answer -> answer, -- match + [answer] -> [answer] -- h + ) + +infixl *** +(***) :: (Eq b, Eq c) => Alignment_Algebra a b -> Alignment_Algebra a c -> Alignment_Algebra a (b,c) +alg1 *** alg2 = (nil,del,ins,match,h) where + (nil',del',ins',match',h') = alg1 + (nil'',del'',ins'',match'',h'') = alg2 + + nil a = (nil' a, nil'' a) + del a (s1,s2) = (del' a s1, del'' a s2) + ins a (s1,s2) = (ins' a s1, ins'' a s2) + match a b (s1,s2) = (match' a b s1, match'' a b s2) + h xs = [ (x1,x2) | + x1 <- h' [ y1 | (y1,_) <- xs] + , x2 <- h'' [ y2 | (y1,y2) <- xs, y1 == x1] + ] + +data Start = Nil + | Del Char Start + | Ins Char Start + | Match Char Char Start + deriving (Eq, Show) + +enum :: Alignment_Algebra Char Start +enum = (\_ -> Nil,Del,Ins,Match,id) + +count :: Alignment_Algebra Char Int +count = (nil,del,ins,match,h) where + nil _ = 1 + del _ s = s + ins _ s = s + match _ _ s = s + h [] = [] + h x = [sum x] + +unit :: Alignment_Algebra Char Int +unit = (nil,del,ins,match,h) where + nil _ = 0 + del _ s = s-1 + ins _ s = s-1 + match a b s = if (a==b) then s+1 else s-1 + h [] = [] + h x = [maximum x] + + +alignmentGr :: YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 + -> Alignment_Algebra Char answer -> (String,String) -> [answer] +alignmentGr _ _ _ inp | trace ("running alignmentGr on " ++ show inp) False = undefined +alignmentGr yieldAlg2 rangeAlg2 algebra (inp1,inp2) = + -- These implicit parameters are used by >>>. + -- They were introduced to allow for exchanging the algorithms and + -- they were made implicit so that they don't ruin our nice syntax. + let ?yieldAlg2 = yieldAlg2 + ?rangeAlg2 = rangeAlg2 + in let + + (nil,del,ins,match,h) = algebra + + rewriteDel [c,a1,a2] = ([c,a1],[a2]) + rewriteIns [c,a1,a2] = ([a1],[c,a2]) + rewriteMatch [c1,c2,a1,a2] = ([c1,a1],[c2,a2]) + a = tabulated2 $ + nil <<< (EPS,EPS) >>>|| id2 ||| + del <<< anychar ~~~|| a >>>|| rewriteDel ||| + ins <<< anychar ~~~|| a >>>|| rewriteIns ||| + match <<< anychar ~~~ anychar ~~~|| a >>>|| rewriteMatch + ... h + + z = mkTwoTrack inp1 inp2 + tabulated2 = table2 z + + in axiomTwoTrack z inp1 inp2 a
+ tests/ADP/Tests/CopyExample.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE ImplicitParams #-} + +-- Copy language L = { ww | w € {a,b}^* } +module ADP.Tests.CopyExample where + +import ADP.Multi.SimpleParsers +import ADP.Multi.Combinators +import ADP.Multi.Tabulation +import ADP.Multi.Helpers +import ADP.Multi.Rewriting + +type Copy_Algebra alphabet answerDim1 answerDim2 = ( + (EPS,EPS) -> answerDim2, -- nil + answerDim2 -> answerDim1, -- copy + alphabet -> alphabet -> answerDim2 -> answerDim2 -- copy' + ) + +data Start = Nil + | Copy Start + | Copy' Char Char Start + deriving (Eq, Show) + +-- without consistency checks +enum :: Copy_Algebra Char Start Start +enum = (nil,copy,copy') where + nil _ = Nil + copy = Copy + copy' = Copy' + +prettyprint :: Copy_Algebra Char String (String,String) +prettyprint = (nil,copy,copy') where + copy (l,r) = l ++ r + nil _ = ("","") + copy' c1 c2 (l,r) = (c1:l,c2:r) + +-- (count of a's, count of b's) +countABs :: Copy_Algebra Char (Int,Int) (Int,Int) +countABs = (nil,copy,copy') where + nil _ = (0,0) + copy (c1,c2) = (c1*2,c2*2) + copy' 'a' 'a' (c1,c2) = (c1+1,c2) + copy' 'b' 'b' (c1,c2) = (c1,c2+1) + + +copyGr :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 + -> YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 + -> Copy_Algebra Char answerDim1 answerDim2 -> String -> [answerDim1] +copyGr yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra inp = + -- These implicit parameters are used by >>>. + -- They were introduced to allow for exchanging the algorithms and + -- they were made implicit so that they don't ruin our nice syntax. + let ?yieldAlg1 = yieldAlg1 + ?rangeAlg1 = rangeAlg1 + ?yieldAlg2 = yieldAlg2 + ?rangeAlg2 = rangeAlg2 + in let + + (nil,copy,copy') = algebra + + s = tabulated1 $ + copy <<< c >>>| id + + rewriteCopy [a',a'',c1,c2] = ([a',c1],[a'',c2]) + c = tabulated2 $ + copy' <<< 'a' ~~~ 'a' ~~~|| c >>>|| rewriteCopy ||| + copy' <<< 'b' ~~~ 'b' ~~~|| c >>>|| rewriteCopy ||| + nil <<< (EPS,EPS) >>>|| id2 + + z = mk inp + tabulated1 = table1 z + tabulated2 = table2 z + + in axiom z s
+ tests/ADP/Tests/CopyTwoTrackExample.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ImplicitParams #-} + +-- Copy language L = { (w,w) | w € {a,b}^* } +module ADP.Tests.CopyTwoTrackExample where + +import ADP.Debug +import ADP.Multi.SimpleParsers +import ADP.Multi.Combinators +import ADP.Multi.Tabulation +import ADP.Multi.Helpers +import ADP.Multi.Rewriting + +type CopyTT_Algebra alphabet answer = ( + (EPS,EPS) -> answer, -- nil + alphabet -> alphabet -> answer -> answer -- copy + ) + +data Start = Nil + | Copy Char Char Start + deriving (Eq, Show) + +enum :: CopyTT_Algebra Char Start +enum = (nil,copy) where + nil _ = Nil + copy = Copy + +prettyprint :: CopyTT_Algebra Char (String,String) +prettyprint = (nil,copy) where + nil _ = ("","") + copy c1 c2 (l,r) = ([c1] ++ l,[c2] ++ r) + +-- (count of a's, count of b's) +countABs :: CopyTT_Algebra Char (Int,Int) +countABs = (nil,copy) where + nil _ = (0,0) + copy 'a' 'a' (c1,c2) = (c1+1,c2) + copy 'b' 'b' (c1,c2) = (c1,c2+1) + + +copyTTGr :: YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 + -> CopyTT_Algebra Char answer -> (String,String) -> [answer] +copyTTGr _ _ _ inp | trace ("running copyTTGr on " ++ show inp) False = undefined +copyTTGr yieldAlg2 rangeAlg2 algebra (inp1,inp2) = + -- These implicit parameters are used by >>>. + -- They were introduced to allow for exchanging the algorithms and + -- they were made implicit so that they don't ruin our nice syntax. + let ?yieldAlg2 = yieldAlg2 + ?rangeAlg2 = rangeAlg2 + in let + + (nil,copy) = algebra + + rewriteCopy [a',a'',c1,c2] = ([a',c1],[a'',c2]) + c = tabulated2 $ + copy <<< 'a' ~~~ 'a' ~~~|| c >>>|| rewriteCopy ||| + copy <<< 'b' ~~~ 'b' ~~~|| c >>>|| rewriteCopy ||| + nil <<< (EPS,EPS) >>>|| id2 + + z = mkTwoTrack inp1 inp2 + tabulated2 = table2 z + + in axiomTwoTrack z inp1 inp2 c
+ tests/ADP/Tests/MonadicCpRegression.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +module ADP.Tests.MonadicCpRegression where + +import Control.CP.FD.OvertonFD.OvertonFD +import Control.CP.FD.OvertonFD.Sugar() +import Control.CP.FD.FD (FDIntTerm, getMinimizeVar) +import Control.CP.FD.Model + +import Control.CP.FD.Interface +import Control.CP.SearchTree +import Control.CP.EnumTerm +import Control.CP.ComposableTransformers +import Control.CP.FD.Solvers + + +type FDModel = + forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) + => m ModelCol + +model :: FDModel +model = exists $ \col -> do + [len1,len2] <- colList col 2 + xsum col @= 2 + len1 @>= 0 + len2 @>= 1 + 2 @<= 1 + return col + +main :: IO () +main = print $ solveModel model + + + +-- returns the number of nodes visited and the actual result +-- if there's no solution, an empty list is returned +solveModel :: Tree (FDInstance OvertonFD) ModelCol -> (Int, [[Int]]) +solveModel f = solve dfs it $ f >>= labeller + +labeller col = + label $ do + minVar <- getMinimizeVar + case minVar of + Nothing -> return $ labelCol col + Just v -> return $ do + enumerate [v] + labelCol col
+ tests/ADP/Tests/MonadicCpTest.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +module ADP.Tests.MonadicCpTest where + +import Control.CP.FD.OvertonFD.OvertonFD +import Control.CP.FD.OvertonFD.Sugar() +import Control.CP.FD.FD (FDIntTerm, getMinimizeVar) +import Control.CP.FD.Model + +import Control.CP.FD.Interface +import Control.CP.SearchTree +import Control.CP.EnumTerm +import Control.CP.ComposableTransformers +import Control.CP.FD.Solvers + + +type FDModel = + forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ (FDInstance s)) + => m ModelCol + +model :: FDModel +model = exists $ \col -> do + [x1,x2] <- colList col 2 + allin col (cte 0,cte 8) + x1 + x2 @= 8 + x1 @>= 1 + x2 @>= 2 + x1 @<= 10 + x2 @<= 12 + -2 @<= x2 + -4 @<= x1 + x1 @<= 8 -- each unnecessary inequality leads to one more visited node + x2 @<= 8 + return col + +main :: IO () +main = print $ solveModel model + + + +-- returns the number of nodes visited and the actual result +-- if there's no solution, an empty list is returned +solveModel :: Tree (FDInstance OvertonFD) ModelCol -> (Int, [[Int]]) +solveModel f = solve dfs it $ f >>= labeller + +labeller col = + label $ do + minVar <- getMinimizeVar + case minVar of + Nothing -> return $ labelCol col + Just v -> return $ do + enumerate [v] + labelCol col
+ tests/ADP/Tests/Nussinov.lhs view
@@ -0,0 +1,191 @@+This file uses original ADP combinators and functions from:++R. Giegerich, C. Meyer and P. Steffen. Towards a discipline of dynamic+programming.++It is here to serve as comparison to adp-multi (atm for benchmarking purposes)++> module ADP.Tests.Nussinov where++> import Data.Array+> import Data.List+> import ADP.Combinators++The signature:++> data Pairing = Nil |+> Left' Char Pairing |+> Right' Pairing Char |+> Pair Char Pairing Char |+> Split Pairing Pairing+> deriving (Eq, Show)++Algebra type:++> type Nussinov_Algebra alphabet answer = (+> () -> answer, -- nil+> alphabet -> answer -> answer, -- left+> answer -> alphabet -> answer, -- right+> alphabet -> answer -> alphabet -> answer, -- pair+> answer -> answer -> answer, -- split+> [answer] -> [answer] -- h+> ) ++Enumeration algebra:++> enum :: Nussinov_Algebra Char Pairing+> enum = (nil,left,right,pair,split,h) where+> nil _ = Nil+> left = Left'+> right = Right'+> pair = Pair+> split = Split+> h = id++Pretty printing algebra:++> prettyprint :: Nussinov_Algebra Char (String,String)+> prettyprint = (nil,left,right,pair,split,h) where+> nil _ = ("","")+> left a (l,r) = ('.':l, a:r)+> right (l,r) b = (l++".", r++[b])+> pair a (l,r) b = ('(':l++")",a:r++[b])+> split (l1,r1) (l2,r2) = (l1++l2,r1++r2)+> h = id++Counting algebra:++> count :: Nussinov_Algebra Char Integer+> count = (nil,left,right,pair,split,h) where+> nil _ = 1+> left _ i = i+> right i _ = i+> pair _ i _ = i+> split i1 i2 = i1 * i2+> h xs = [sum xs]++Base Pair Algebra:++> pairmax :: Nussinov_Algebra Char Int++> pairmax = (nil,left,right,pair,split,h) where+> nil _ = 0+> left _ x = x+> right x _ = x+> pair _ x _ = x + 1+> split x y = x + y+> h xs = [maximum xs]++Algebra product operation:++> infix ***+> alg1 *** alg2 = (nil,left,right,pair,split,h) where+> (nil1,left1,right1,pair1,split1,h1) = alg1+> (nil2,left2,right2,pair2,split2,h2) = alg2+> nil a = (nil1 a, nil2 a)+> left a (x1,x2) = (left1 a x1, left2 a x2)+> right (x1,x2) a = (right1 x1 a, right2 x2 a)+> pair a (x1,x2) b = (pair1 a x1 b, pair2 a x2 b)+> split (x1,x2) (y1,y2) = (split1 x1 y1, split2 x2 y2) +> h xs = [(x1,x2)| x1 <- nub $ h1 [ y1 | (y1,y2) <- xs],+> x2 <- h2 [ y2 | (y1,y2) <- xs, y1 == x1]]+++Nussinov's original grammar:++> nussinov78 :: Nussinov_Algebra Char answer -> String -> [answer]+> nussinov78 alg inp = axiom s where+> (nil,left,right,pair,split,h) = alg++> s = tabulated (+> nil <<< empty |||+> right <<< s ~~- base |||+> split <<< s ~~+ t ... h+> )++> t = tabulated (+> (pair <<< base -~~ s ~~- base) `with` basepairing +> )++Bind input:++> z = mk inp+> (_,n) = bounds z++> base = achar' z+> tabulated = table n+> axiom = axiom' n++> basepairing :: Filter+> basepairing = match inp+> match inp (i,j) = i+1<j && basepair (z!(i+1), z!(j))++> nussinov78' :: Nussinov_Algebra Char answer -> String -> [answer]+> nussinov78' alg inp = axiom s where+> (nil,left,right,pair,split,h) = alg++> s = tabulated (+> nil <<< empty |||+> right <<< s ~~- b |||+> split <<< s ~~+ t ... h+> )++> t = tabulated $+> pair <<< char 'a' -~~ s ~~- char 'u' |||+> pair <<< char 'u' -~~ s ~~- char 'a' |||+> pair <<< char 'c' -~~ s ~~- char 'g' |||+> pair <<< char 'g' -~~ s ~~- char 'c' |||+> pair <<< char 'g' -~~ s ~~- char 'u' |||+> pair <<< char 'u' -~~ s ~~- char 'g'++> b = tabulated $+> undefined <<< char 'a' |||+> undefined <<< char 'u' |||+> undefined <<< char 'c' |||+> undefined <<< char 'g'++Bind input:++> z = mk inp+> (_,n) = bounds z++> char = char' z+> tabulated = table n+> axiom = axiom' n+++Durbin's variant of nussinov78++> durbin alg inp = axiom s where+> (nil,left,right,pair,split,h) = alg++> s = tabulated (+> nil <<< empty |||+> left <<< base -~~ s |||+> right <<< s ~~- base |||+> (pair <<< base -~~ s ~~- base)+> `with` basepairing |||+> split <<< s +~+ s ... h)++Bind input:++> z = mk (inp)+> (_,n) = bounds z++> base = achar' z+> tabulated = table n+> axiom = axiom' n++> basepairing :: Filter+> basepairing = match inp+> match inp (i,j) = i+1<j && basepair (z!(i+1), z!(j))++Baseparing function:++> basepair ('a','u') = True+> basepair ('u','a') = True+> basepair ('c','g') = True+> basepair ('g','c') = True+> basepair ('g','u') = True+> basepair ('u','g') = True+> basepair ( x , y ) = False
+ tests/ADP/Tests/NussinovExample.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ImplicitParams #-} + +module ADP.Tests.NussinovExample where + +import ADP.Multi.SimpleParsers +import ADP.Multi.Combinators +import ADP.Multi.Tabulation +import ADP.Multi.Helpers +import ADP.Multi.Rewriting + +type Nussinov_Algebra alphabet answer = ( + EPS -> answer, -- nil + alphabet -> answer, -- base + alphabet -> answer -> answer, -- left + answer -> answer -> answer, -- right + alphabet -> answer -> alphabet -> answer, -- pair + answer -> answer -> answer, -- split + [answer] -> [answer] -- h + ) + +pairmax :: Nussinov_Algebra Char Int +pairmax = (nil,base,left,right,pair,split,h) where + nil _ = 0 + base _ = undefined + left _ x = x + right x _ = x + pair _ x _ = x + 1 + split x y = x + y + h xs = [maximum xs] + + +nussinov78 :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 + -> Nussinov_Algebra Char answer -> String -> [answer] +nussinov78 yieldAlg1 rangeAlg1 algebra inp = + -- These implicit parameters are used by >>>. + -- They were introduced to allow for exchanging the algorithms and + -- they were made implicit so that they don't ruin our nice syntax. + let ?yieldAlg1 = yieldAlg1 + ?rangeAlg1 = rangeAlg1 + in let + + (nil,base,left,right,pair,split,h) = algebra + + s = tabulated $ + nil <<< EPS >>>| id ||| + right <<<| s ~~~ b >>>| id ||| + split <<<| s ~~~ t >>>| id + ... h + + t = tabulated $ + pair <<< 'a' ~~~| s ~~~ 'u' >>>| id ||| + pair <<< 'u' ~~~| s ~~~ 'a' >>>| id ||| + pair <<< 'c' ~~~| s ~~~ 'g' >>>| id ||| + pair <<< 'g' ~~~| s ~~~ 'c' >>>| id ||| + pair <<< 'g' ~~~| s ~~~ 'u' >>>| id ||| + pair <<< 'u' ~~~| s ~~~ 'g' >>>| id + + b = tabulated $ + base <<< 'a' >>>| id ||| + base <<< 'u' >>>| id ||| + base <<< 'c' >>>| id ||| + base <<< 'g' >>>| id + + z = mk inp + tabulated = table1 z + + in axiom z s
+ tests/ADP/Tests/RGExampleDim2.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ImplicitParams #-} + +{- +Example using the Reeder&Giegerich class of pseudoknots. + +The grammar was taken from: + +Markus E. Nebel and Frank Weinberg. Algebraic and Combinatorial Properties of Common +RNA Pseudoknot Classes with Applications. (submitted), 2012. + +The original algorithm (not in grammar form) can be found in: + +Jens Reeder and Robert Giegerich. Design, implementation and evaluation of a practical +pseudoknot folding algorithm based on thermodynamics. BMC Bioinformatics, 5:104, 2004. +-} +module ADP.Tests.RGExampleDim2 where + +{- +S -> € | BS | P_1 S P_2 S | K_1^1 S K_1^2 S K_2^1 S K_2^2 S +[K_1,K_2] -> [K_1 P_1, P_2 K_2] | [P_1, P_2] +[P_1,P_2] -> [a,u] | [u,a] | [g,c] | [c,g] | [g,u] | [u,g] +B -> a | u | c | g +-} + +import Data.Array (bounds) +import qualified Control.Arrow as A +import Data.Typeable +import Data.Data +import Data.Array +import ADP.Multi.Parser +import ADP.Multi.SimpleParsers +import ADP.Multi.Combinators +import ADP.Multi.Tabulation +import ADP.Multi.Helpers +import ADP.Multi.Rewriting + +type RG_Algebra alphabet answer = ( + (EPS,EPS) -> answer, -- nil + answer -> answer -> answer, -- left + answer -> answer -> answer -> answer, -- pair + answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knot + answer -> answer -> answer, -- knot1 + answer -> answer, -- knot2 + (alphabet, alphabet) -> answer, -- basepair + (EPS, alphabet) -> answer, -- base + [answer] -> [answer] -- h + ) + +infixl *** +(***) :: (Eq b, Eq c) => RG_Algebra a b -> RG_Algebra a c -> RG_Algebra a (b,c) +alg1 *** alg2 = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where + (nil',left',pair',knot',knot1',knot2',basepair',base',h') = alg1 + (nil'',left'',pair'',knot'',knot1'',knot2'',basepair'',base'',h'') = alg2 + + nil = nil' A.&&& nil'' + left b s = (left', left'') **** b **** s + pair p s1 s2 = (pair', pair'') **** p **** s1 **** s2 + knot k1 k2 s1 s2 s3 s4 = (knot', knot'') **** k1 **** k2 **** s1 **** s2 **** s3 **** s4 + knot1 p k = (knot1', knot1'') **** p **** k + knot2 p = (knot2', knot2'') **** p + basepair = basepair' A.&&& basepair'' + base = base' A.&&& base'' + h xs = [ (x1,x2) | + x1 <- h' [ y1 | (y1,_) <- xs] + , x2 <- h'' [ y2 | (y1,y2) <- xs, y1 == x1] + ] + + (****) = uncurry (A.***) + +{- + nil a = (nil' a, nil'' a) + left (b1,b2) (s1,s2) = (left' b1 s1, left'' b2 s2) + pair (p1,p2) (s11,s21) (s12,s22) = (pair' p1 s11 s12, pair'' p2 s21 s22) + knot (k11,k21) (k12,k22) (s11,s21) (s12,s22) (s13,s23) (s14,s24) = + (knot' k11 k12 s11 s12 s13 s14, knot'' k21 k22 s21 s22 s23 s24) + knot1 (p1,p2) (k1,k2) = (knot1' p1 k1, knot1'' p2 k2) + knot2 (p1,p2) = (knot2' p1, knot2'' p2) + basepair a = (basepair' a, basepair'' a) + base a = (base' a, base'' a) + h xs = [ (x1,x2) | + x1 <- h' [ y1 | (y1,_) <- xs] + , x2 <- h'' [ y2 | (y1,y2) <- xs, y1 == x1] + ] +-} + +-- This data type is used only for the enum algebra. +-- The type allows invalid trees which would be impossible to build +-- with the given grammar rules. +-- As an additional (programming) error check, a second debug enum algebra checks +-- the types via pattern-matching. +data Start = Nil + | Left' Start Start + | Pair Start Start Start + | Knot Start Start Start Start Start Start + | Knot1 Start Start + | Knot2 Start + | BasePair (Char, Char) + | Base (EPS, Char) + deriving (Eq, Show, Data, Typeable) + +-- without consistency checks +enum :: RG_Algebra Char Start +enum = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where + nil _ = Nil + left = Left' + pair = Pair + knot = Knot + knot1 = Knot1 + knot2 = Knot2 + basepair = BasePair + base = Base + h = id + +-- with consistency checks +enumDebug :: RG_Algebra Char Start +enumDebug = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where + + s' = [Nil, Left'{}, Pair{}, Knot{}] + k' = [Knot1 {}, Knot2 {}] + + nil _ = Nil + left b@(Base _) s + | s `isOf` s' = Left' b s + + pair p@(BasePair _) s1 s2 + | [s1,s2] `areOf` s' = Pair p s1 s2 + + knot k1 k2 s1 s2 s3 s4 + | [k1,k2] `areOf` k' && [s1,s2,s3,s4] `areOf` s' = Knot k1 k2 s1 s2 s3 s4 + + knot1 p@(BasePair _) k + | k `isOf` k' = Knot1 p k + + knot2 p@(BasePair _) = Knot2 p + basepair = BasePair + base = Base + h = id + + isOf l r = toConstr l `elem` map toConstr r + areOf l r = all (`isOf` r) l + +maxBasepairs :: RG_Algebra Char Int +maxBasepairs = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where + nil _ = 0 + left a b = a + b + pair a b c = a + b + c + knot a b c d e f = a + b + c + d + e + f + knot1 a b = a + b + knot2 a = a + basepair _ = 1 + base _ = 0 + h [] = [] + h xs = [maximum xs] + +maxKnots :: RG_Algebra Char Int +maxKnots = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where + nil _ = 0 + left _ b = b + pair _ b c = b + c + knot _ _ c d e f = 1 + c + d + e + f + knot1 _ _ = 0 + knot2 _ = 0 + basepair _ = 0 + base _ = 0 + h [] = [] + h xs = [maximum xs] + +-- TODO don't need [String] here as it's all dim2, use (String,String) instead +-- The left part is the structure and the right part the reconstructed input. +prettyprint :: RG_Algebra Char ([String],[String]) +prettyprint = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where + nil _ = ([""],[""]) + left (bl,br) (sl,sr) = + ( + [concat $ bl ++ sl], + [concat $ br ++ sr] + ) + pair ([p1l,p2l],[p1r,p2r]) (s1l,s1r) (s2l,s2r) = + ( + [concat $ [p1l] ++ s1l ++ [p2l] ++ s2l], + [concat $ [p1r] ++ s1r ++ [p2r] ++ s2r] + ) + knot ([k11l,k12l],[k11r,k12r]) ([k21l,k22l],[k21r,k22r]) (s1l,s1r) (s2l,s2r) (s3l,s3r) (s4l,s4r) = + let (k11l',k12l') = square k11l k12l + in + ( + [concat $ [k11l'] ++ s1l ++ [k21l] ++ s2l ++ [k12l'] ++ s3l ++ [k22l] ++ s4l], + [concat $ [k11r] ++ s1r ++ [k21r] ++ s2r ++ [k12r] ++ s3r ++ [k22r] ++ s4r] + ) + knot1 ([p1l,p2l],[p1r,p2r]) ([k1l,k2l],[k1r,k2r]) = + ( + [concat $ [k1l] ++ [p1l], concat $ [p2l] ++ [k2l]], + [concat $ [k1r] ++ [p1r], concat $ [p2r] ++ [k2r]] + ) + knot2 (pl,pr) = (pl, pr) + basepair (b1,b2) = (["(",")"], [[b1],[b2]]) + base (EPS,b) = (["."], [[b]]) + h = id + + square l r = (map (const '[') l, map (const ']') r) + +rgknot :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 + -> YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 + -> RG_Algebra Char answer -> String -> [answer] +rgknot yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra inp = + -- These implicit parameters are used by >>>. + -- They were introduced to allow for exchanging the algorithms and + -- they were made implicit so that they don't ruin our nice syntax. + let ?yieldAlg1 = yieldAlg1 + ?rangeAlg1 = rangeAlg1 + ?yieldAlg2 = yieldAlg2 + ?rangeAlg2 = rangeAlg2 + in let + + (nil,left,pair,knot,knot1,knot2,basepair,base,h) = algebra + + s1,s2,s3,s4,p',k1,k2 :: Dim2 + + -- all s are 1-dim simulated as 2-dim + s1 [c1,c2] = ([],[c1,c2]) + s2 [b1,b2,s1,s2] = ([],[b1,b2,s1,s2]) + s3 [p1,p2,s11,s12,s21,s22] = ([],[p1,s11,s12,p2,s21,s22]) + s4 [k11,k12,k21,k22,s11,s12,s21,s22,s31,s32,s41,s42] = + ([],[k11,s11,s12,k21,s21,s22,k12,s31,s32,k22,s41,s42]) + + s = tabulated2 $ + nil <<< (EPS,EPS) >>>|| s1 ||| + left <<< b ~~~|| s >>>|| s2 ||| + pair <<< p ~~~|| s ~~~|| s >>>|| s3 ||| + knot <<< k ~~~ k ~~~|| s ~~~|| s ~~~|| s ~~~|| s >>>|| s4 + ... h + + b = tabulated2 $ + base <<< (EPS, 'a') >>>|| s1 ||| + base <<< (EPS, 'u') >>>|| s1 ||| + base <<< (EPS, 'c') >>>|| s1 ||| + base <<< (EPS, 'g') >>>|| s1 + + p' [c1,c2] = ([c1],[c2]) + p = tabulated2 $ + basepair <<< ('a', 'u') >>>|| p' ||| + basepair <<< ('u', 'a') >>>|| p' ||| + basepair <<< ('c', 'g') >>>|| p' ||| + basepair <<< ('g', 'c') >>>|| p' ||| + basepair <<< ('g', 'u') >>>|| p' ||| + basepair <<< ('u', 'g') >>>|| p' + + k1 [p1,p2,k1,k2] = ([k1,p1],[p2,k2]) + k2 [p1,p2] = ([p1],[p2]) + + k = tabulated2 $ + knot1 <<< p ~~~|| k >>>|| k1 ||| + knot2 <<< p >>>|| k2 + + z = mk inp + tabulated1 = table1 z + tabulated2 = table2 z + + axiom' :: Array Int a -> RichParser a b -> [b] + axiom' z (_,ax) = + let (_,l) = bounds z + in ax z [0,0,0,l] + in axiom' z s