adp-multi 0.2.1 → 0.2.2
raw patch · 19 files changed
+181/−450 lines, 19 filesnew-component:exe:adp-multi-benchmarks2PVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- adp-multi.cabal +32/−6
- benchmarks/Benchmarks.hs +2/−5
- benchmarks/Benchmarks2.hs +15/−0
- tests/ADP/Tests/CopyExample.hs +3/−7
- tests/ADP/Tests/CopyTwoTrackExample.hs +1/−3
- tests/ADP/Tests/Main.hs +2/−0
- tests/ADP/Tests/MonadicCpRegression.hs +0/−49
- tests/ADP/Tests/MonadicCpTest.hs +0/−55
- tests/ADP/Tests/NestedExample.hs +9/−33
- tests/ADP/Tests/Nussinov.lhs +35/−32
- tests/ADP/Tests/NussinovExample.hs +0/−56
- tests/ADP/Tests/OneStructureExample.hs +6/−6
- tests/ADP/Tests/RGExample.hs +8/−38
- tests/ADP/Tests/RGExampleDim2.hs +4/−48
- tests/ADP/Tests/RGExampleStar.hs +15/−63
- tests/ADP/Tests/Suite.hs +25/−26
- tests/ADP/Tests/TermExample.hs +3/−1
- tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs +18/−18
- tests/MCFG/MCFG.hs +3/−4
adp-multi.cabal view
@@ -1,10 +1,10 @@ name: adp-multi -version: 0.2.1 +version: 0.2.2 cabal-version: >= 1.8 build-type: Simple author: Maik Riechert stability: experimental -bug-reports: https://github.com/neothemachine/adp-multi/issues +bug-reports: https://github.com/adp-multi/adp-multi/issues homepage: http://adp-multi.ruhoh.com copyright: Maik Riechert, 2012 license: BSD3 @@ -23,7 +23,7 @@ source-repository head type: git - location: git://github.com/neothemachine/adp-multi.git + location: git://github.com/adp-multi/adp-multi.git Flag buildTests description: Build test executable @@ -33,6 +33,10 @@ description: Build benchmark executable default: False +Flag buildBenchmark2 + description: Build second benchmark executable + default: False + Flag DEBUG description: Enable/disable debug output default: False @@ -85,11 +89,8 @@ 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, @@ -123,6 +124,31 @@ src ghc-options: -Wall -rtsopts main-is: Benchmarks.hs + other-modules: Criterion.Helpers + +executable adp-multi-benchmarks2 + if !flag(buildBenchmark2) + buildable: False + else + build-depends: + base == 4.*, + array == 0.4.*, + containers >= 0.4 && < 0.6, + htrace == 0.1.*, + HUnit == 1.2.*, + QuickCheck == 2.5.*, + test-framework == 0.8.*, + test-framework-quickcheck2 == 0.3.*, + test-framework-hunit == 0.3.*, + random-shuffle == 0.0.4, + mtl >= 2.0 && < 2.2, + criterion == 0.6.*, + deepseq >= 1.1.0.0 + hs-source-dirs: benchmarks, + tests, + src + ghc-options: -Wall -rtsopts + main-is: Benchmarks2.hs other-modules: Criterion.Helpers executable adp-test
benchmarks/Benchmarks.hs view
@@ -2,22 +2,19 @@ import Criterion.Helpers import ADP.Tests.Nussinov as Nuss-import ADP.Tests.NussinovExample as Nuss2+import ADP.Tests.NestedExample as Nuss2 import BioInf.GAPlike as Nuss3- --- TODO try to adapt ADPfusion test so that the grammar/algebra is the same -- run with -o report.html -u report.csv main :: IO () main = defaultMain [ bgroup "nussinov78 (Haskell-ADP)" (benchArray (Nuss.nussinov78' Nuss.pairmax) inputs),- bgroup "nussinov78 (adp-multi)" (benchArray (Nuss2.nussinov78 Nuss2.pairmax) inputs),+ bgroup "nussinov78 (adp-multi)" (benchArray (Nuss2.nested Nuss2.maxBasepairs) inputs), bgroup "nussinov78 (ADPfusion)" (benchArray (fst . Nuss3.nussinov78) inputs) ] where longInp = "ggcguaggcgccgugcuuuugcuccccgcgcgcuguuuuucucgcugacuuucagcgggcggaaaagccucggccugccgccuuccaccguucauucuag" infiniteInp = cycle longInp- inputs = [ (show i, take i infiniteInp) | i <- [100,200..1000] ]
+ benchmarks/Benchmarks2.hs view
@@ -0,0 +1,15 @@+import Criterion.Main+import Criterion.Helpers++import ADP.Tests.RGExample as RG+ +-- run with -u report.csv+main :: IO ()+main = defaultMain+ [+ bgroup "C2u (adp-multi)" (benchArray (RG.rgknot RG.maxBasepairs) inputs)+ ]+ where+ longInp = "ggcguaggcgccgugcuuuugcuccccgcgcgcuguuuuucucgcugacuuucagcgggcggaaaagccucggccugccgccuuccaccguucauucuag"+ infiniteInp = cycle longInp+ inputs = [ (show i, take i infiniteInp) | i <- [10,15..50] ]
tests/ADP/Tests/CopyExample.hs view
@@ -17,14 +17,10 @@ | 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'+enum = (\_ -> Nil,Copy,Copy') --- MCFG grammar in Waldmann's data types, used for consistency checking +-- MCFG grammar in Waldmann's data types, used for consistency checking in Suite.hs mcfg :: MCFG mcfg = MCFG { start = N 1 "S"@@ -54,7 +50,7 @@ } -- create derivation trees compatible to those generated by Waldmann's MCFG parser--- this works here as the grammar is unambiguous and there is only exactly one child derivation tree+-- this works here as the grammar is unambiguous and there is always exactly one derivation tree as child derivation :: Copy_Algebra Char Derivation Derivation derivation = (nil,copy,copy') where nil _ = Derivation undefined r3 []
tests/ADP/Tests/CopyTwoTrackExample.hs view
@@ -15,9 +15,7 @@ deriving (Eq, Show) enum :: CopyTT_Algebra Char Start-enum = (nil,copy) where- nil _ = Nil- copy = Copy+enum = (\_-> Nil,Copy) prettyprint :: CopyTT_Algebra Char (String,String) prettyprint = (nil,copy) where
tests/ADP/Tests/Main.hs view
@@ -10,6 +10,8 @@ import qualified ADP.Tests.TreeAlignExample as TreeAlign import qualified ADP.Tests.TermExample as Term +-- this file shows the usage of all the test grammars and can be +-- used for quick tests main::IO() main = do
− tests/ADP/Tests/MonadicCpRegression.hs
@@ -1,49 +0,0 @@-{-# 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
@@ -1,55 +0,0 @@-{-# 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/NestedExample.hs view
@@ -1,3 +1,4 @@+-- | Grammar for all pseudoknot-free RNA secondary structures module ADP.Tests.NestedExample where import ADP.Multi.All @@ -11,16 +12,6 @@ alphabet -> answer, -- base [answer] -> [answer] -- h ) - --- test using record syntax -data NestedAlgebra alphabet answer = NestedAlgebra { - nil :: EPS -> answer, - left :: answer -> answer -> answer, - pair :: answer -> answer -> answer, - basepair :: alphabet -> answer -> alphabet -> answer, - base :: alphabet -> answer, - h :: [answer] -> [answer] - } infixl *** (***) :: (Eq b, Eq c) => Nested_Algebra a b -> Nested_Algebra a c -> Nested_Algebra a (b,c) @@ -38,7 +29,6 @@ , x2 <- h'' [ y2 | (y1,y2) <- xs, y1 == x1] ] - data Start = Nil | Left' Start Start | Pair Start Start @@ -46,25 +36,8 @@ | Base Char deriving (Eq, Show) --- without consistency checks enum :: Nested_Algebra Char Start -enum = (nil,left,pair,basepair,base,h) where - nil _ = Nil - left = Left' - pair = Pair - basepair = BasePair - base = Base - h = id - -enum' :: NestedAlgebra Char Start -enum' = NestedAlgebra { - nil = \ _ -> Nil, -- hmm, this sucks - left = Left', - pair = Pair, - basepair = BasePair, - base = Base, - h = id - } +enum = (\_-> Nil,Left',Pair,BasePair,Base,id) maxBasepairs :: Nested_Algebra Char Int maxBasepairs = (nil,left,pair,basepair,base,h) where @@ -76,7 +49,7 @@ h [] = [] h xs = [maximum xs] --- The left part is the structure and the right part the reconstructed input. +-- | left part = dot-bracket; right part = reconstructed input prettyprint :: Nested_Algebra Char (String,String) prettyprint = (nil,left,pair,basepair,base,h) where nil _ = ("","")@@ -85,7 +58,8 @@ basepair b1 (sl,sr) b2 = ("(" ++ sl ++ ")", [b1] ++ sr ++ [b2]) base b = (".", [b]) h = id - + +-- | PSTricks trees using some custom macros pstree :: Nested_Algebra Char String pstree = (nil,left,pair,basepair,base,h) where nil _ = "\\emptyword" @@ -96,7 +70,8 @@ h = id nonterm sym tree = "\\pstree{\\nonterminal{" ++ sym ++ "}}{" ++ tree ++ "}" - + +-- | terms in tex math term :: Nested_Algebra Char String term = (nil,left,pair,basepair,base,h) where nil _ = "\\op{f}_3()" @@ -105,7 +80,8 @@ basepair b1 s b2 = "\\op{f}_4(" ++ [b1] ++ "," ++ s ++ "," ++ [b2] ++ ")" base b = "\\op{f}_5(" ++ [b] ++ ")" h = id - + +-- | plain terms without markup termPlain :: Nested_Algebra Char String termPlain = (nil,left,pair,basepair,base,h) where nil _ = "f_3"
tests/ADP/Tests/Nussinov.lhs view
@@ -1,9 +1,10 @@-This file uses original ADP combinators and functions from:+This file uses original Haskell-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)+It is here to serve as comparison to adp-multi (for benchmarking purposes)+See NestedExample.hs for the equivalent adp-multi grammar. > module ADP.Tests.Nussinov where @@ -18,7 +19,7 @@ > Right' Pairing Char | > Pair Char Pairing Char | > Split Pairing Pairing-> deriving (Eq, Show)+> deriving (Eq, Show) Algebra type: @@ -91,68 +92,70 @@ > x2 <- h2 [ y2 | (y1,y2) <- xs, y1 == x1]] -Nussinov's original grammar:+Variant used for benchmarking (see /benchmarks/Benchmarks.hs): -> nussinov78 :: Nussinov_Algebra Char answer -> String -> [answer]-> nussinov78 alg inp = axiom s where+> 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+> left <<< b -~~ s |||+> split <<< p +~~ s ... h > ) -> t = tabulated (-> (pair <<< base -~~ s ~~- base) `with` basepairing -> )+> p = 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 $+> char 'a' |||+> char 'u' |||+> char 'c' |||+> char 'g'+ Bind input: > z = mk inp > (_,n) = bounds z -> base = achar' z+> char = char' 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+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 ~~- b |||+> right <<< s ~~- base ||| > 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 $-> char 'a' |||-> char 'u' |||-> char 'c' |||-> char 'g'+> t = tabulated (+> (pair <<< base -~~ s ~~- base) `with` basepairing +> ) Bind input: > z = mk inp > (_,n) = bounds z -> char = char' 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)) Durbin's variant of nussinov78
− tests/ADP/Tests/NussinovExample.hs
@@ -1,56 +0,0 @@-module ADP.Tests.NussinovExample where - -import ADP.Multi.All -import ADP.Multi.Rewriting.All - -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 :: Nussinov_Algebra Char answer -> String -> [answer] -nussinov78 algebra inp = - let - (nil,base,left,right,pair,split,h) = algebra - - s = tabulated $ - yieldSize1 (0, Nothing) $ - nil <<< EPS >>> id1 ||| - right <<< s ~~~ b >>> id1 ||| - split <<< s ~~~ t >>> id1 - ... h - - t = tabulated $ - pair <<< 'a' ~~~ s ~~~ 'u' >>> id1 ||| - pair <<< 'u' ~~~ s ~~~ 'a' >>> id1 ||| - pair <<< 'c' ~~~ s ~~~ 'g' >>> id1 ||| - pair <<< 'g' ~~~ s ~~~ 'c' >>> id1 ||| - pair <<< 'g' ~~~ s ~~~ 'u' >>> id1 ||| - pair <<< 'u' ~~~ s ~~~ 'g' >>> id1 - - b = tabulated $ - base <<< 'a' >>> id1 |||- base <<< 'u' >>> id1 |||- base <<< 'c' >>> id1 |||- base <<< 'g' >>> id1- - z = mk inp - tabulated = table1 z - - in axiom z s
tests/ADP/Tests/OneStructureExample.hs view
@@ -1,14 +1,12 @@-{- This example implements the 1-structure grammar from- "Topology and prediction of RNA pseudoknots" by Reidys et al., 2011--}+-- | This example implements the 1-structure grammar from+-- "Topology and prediction of RNA pseudoknots" by Reidys et al., 2011 module ADP.Tests.OneStructureExample where import Data.Array import ADP.Multi.All import ADP.Multi.Rewriting.All---- TODO as in CopyExample, use separate answer type for each dimension + type OneStructure_Algebra alphabet answer = ( EPS -> answer, -- nil answer -> answer -> answer, -- left@@ -53,6 +51,7 @@ enum = (\_->Nil,Left',Pair,BasePair,Base,I1,I2,TStart,KnotH,KnotK,KnotL,KnotM ,XKnot1,XKnot2,XKnot1,XKnot2,XKnot1,XKnot2,XKnot1,XKnot2,id) +-- | dot-bracket prettyprint :: OneStructure_Algebra Char [String] prettyprint = (nil,left,pair,basepair,base,i1,i2,tstart,knotH,knotK,knotL,knotM ,aknot1,aknot2,bknot1,bknot2,cknot1,cknot2,dknot1,dknot2,h) where@@ -85,7 +84,7 @@ h = id --- reconstructed input+-- | reconstructed input prettyprint2 :: OneStructure_Algebra Char [String] prettyprint2 = (nil,left,pair,basepair,base,i1,i2,tstart,knotH,knotK,knotL,knotM ,aknot1,aknot2,bknot1,bknot2,cknot1,cknot2,dknot1,dknot2,h) where@@ -122,6 +121,7 @@ {- To make the grammar reusable, its definition has been split up into the actual grammar which exposes the start symbol as a parser (oneStructureGrammar) and a convenience function which actually runs the grammar on a given input (oneStructure).+ It is reused in ZeroStructureTwoBackbonesExample.hs -} oneStructure :: OneStructure_Algebra Char answer -> String -> [answer] oneStructure algebra inp =
tests/ADP/Tests/RGExample.hs view
@@ -2,11 +2,12 @@ {- Example using the Reeder&Giegerich class of pseudoknots.+(with only the first canonization rule applied) The grammar was taken from: Markus E. Nebel and Frank Weinberg. Algebraic and Combinatorial Properties of Common-RNA Pseudoknot Classes with Applications. (submitted), 2012.+RNA Pseudoknot Classes with Applications. 2012. The original algorithm (not in grammar form) can be found in: @@ -15,20 +16,11 @@ -} module ADP.Tests.RGExample 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 qualified Control.Arrow as A import Data.Typeable import Data.Data import ADP.Multi.All import ADP.Multi.Rewriting.All- --- TODO as in CopyExample, use separate answer type for each dimension + type RG_Algebra alphabet answer = ( EPS -> answer, -- nil answer -> answer -> answer, -- left@@ -47,22 +39,6 @@ (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)@@ -76,8 +52,8 @@ 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.@@ -95,16 +71,7 @@ -- 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 +enum = (\_->Nil,Left',Pair,Knot,Knot1,Knot2,BasePair,Base,id) -- with consistency checks enumDebug :: RG_Algebra Char Start@@ -252,6 +219,7 @@ base <<< 'u' >>> id1 ||| base <<< 'c' >>> id1 ||| base <<< 'g' >>> id1+ ... h p = tabulated2 $ basepair <<< ('a', 'u') >>> id2 |||@@ -260,6 +228,7 @@ basepair <<< ('g', 'c') >>> id2 ||| basepair <<< ('g', 'u') >>> id2 ||| basepair <<< ('u', 'g') >>> id2+ ... h rewriteKnot1 :: Dim2 rewriteKnot1 [p1,p2,k1,k2] = ([k1,p1],[p2,k2])@@ -268,6 +237,7 @@ yieldSize2 (1,Nothing) (1,Nothing) $ knot1 <<< p ~~~ k >>> rewriteKnot1 ||| knot2 <<< p >>> id2+ ... h z = mk inp tabulated1 = table1 z
tests/ADP/Tests/RGExampleDim2.hs view
@@ -1,29 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {--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.+The same as RGExample.hs but all 1-dim nonterminals are encoded+as 2-dim nonterminals. -} 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@@ -47,23 +29,7 @@ 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)@@ -77,8 +43,8 @@ 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.@@ -96,16 +62,7 @@ -- 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 +enum = (\_->Nil,Left',Pair,Knot,Knot1,Knot2,BasePair,Base,id) -- with consistency checks enumDebug :: RG_Algebra Char Start@@ -241,7 +198,6 @@ knot2 <<< p >>> k2 z = mk inp- tabulated1 = table1 z tabulated2 = table2 z axiom' :: Array Int a -> RichParser a b -> [b]
tests/ADP/Tests/RGExampleStar.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}- {- This example is a copy of RGExample with the difference that (A^*)^i is used in the signature instead of just A or (A,A).@@ -24,14 +22,14 @@ type RG_Algebra alphabet answer = (- [alphabet] -> answer, -- nil+ [alphabet] -> 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- [alphabet] -> answer, -- base+ ([alphabet], [alphabet]) -> answer, -- basepair+ [alphabet] -> answer, -- base [answer] -> [answer] -- h ) @@ -41,21 +39,20 @@ (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''+ 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] ] - (****) = uncurry (A.***)- data Start = Nil | Left' Start Start | Pair Start Start Start@@ -64,20 +61,10 @@ | Knot2 Start | BasePair (String, String) | Base String- deriving (Eq, Show, Data, Typeable)+ deriving (Eq, Show) --- 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 +enum = (\_->Nil,Left',Pair,Knot,Knot1,Knot2,BasePair,Base,id) maxBasepairs :: RG_Algebra Char Int maxBasepairs = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where@@ -137,42 +124,7 @@ h = id square l r = (map (const '[') l, map (const ']') r)- -pstree :: RG_Algebra Char String-pstree = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where- nil _ = "\\function{(\\op{f}_3,\\op{r}_0)}"- left b s = "\\pstree{\\function{(\\op{f}_1,\\op{r}_1)}}{" ++ b ++ s ++ "}"- pair p s1 s2 = "\\pstree{\\function{(\\op{f}_2,\\op{r}_2})}{" ++ p ++ s1 ++ s2 ++ "}"- knot k1 k2 s1 s2 s3 s4 = "\\pstree{\\function{(\\op{f}_4,\\op{r}_3)}}{" ++ k1 ++ k2 ++ s1 ++ s2 ++ s3 ++ s4 ++ "}"- knot1 p k = "\\pstree{\\function{(\\op{f}_5,\\op{r}_4})}{" ++ k ++ p ++ "}"- knot2 p = "\\pstree{\\function{(\\op{f}_6,\\op{id})}}{" ++ p ++ "}"- basepair (p1,p2) = "\\pstree{\\function{(\\op{f}_7,\\op{id})}}{\\terminalvec{" ++ p1 ++ "}{" ++ p2 ++ "}}"- base b = "\\pstree{\\function{(\\op{f}_8,\\op{id})}}{\\terminal{" ++ b ++ "}}"- h = id- -pstreeYield :: RG_Algebra Char String-pstreeYield = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where- nil _ = "\\function{\\op{r}_0}"- left b s = "\\pstree{\\function{\\op{r}_1}}{" ++ b ++ s ++ "}"- pair p s1 s2 = "\\pstree{\\function{\\op{r}_2}}{" ++ p ++ s1 ++ s2 ++ "}"- knot k1 k2 s1 s2 s3 s4 = "\\pstree{\\function{\\op{r}_3}}{" ++ k1 ++ k2 ++ s1 ++ s2 ++ s3 ++ s4 ++ "}"- knot1 p k = "\\pstree{\\function{\\op{r}_4}}{" ++ k ++ p ++ "}"- knot2 p = "\\pstree{\\function{\\op{id}}}{" ++ p ++ "}"- basepair (p1,p2) = "\\pstree{\\function{\\op{id}}}{\\terminalvec{" ++ p1 ++ "}{" ++ p2 ++ "}}"- base b = "\\pstree{\\function{\\op{id}}}{\\terminal{" ++ b ++ "}}"- h = id- -pstreeEval :: RG_Algebra Char String-pstreeEval = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where- nil _ = "\\function{\\op{f}_3}"- left b s = "\\pstree{\\function{\\op{f}_1}}{" ++ b ++ s ++ "}"- pair p s1 s2 = "\\pstree{\\function{\\op{f}_2})}{" ++ p ++ s1 ++ s2 ++ "}"- knot k1 k2 s1 s2 s3 s4 = "\\pstree{\\function{\\op{f}_4}}{" ++ k1 ++ k2 ++ s1 ++ s2 ++ s3 ++ s4 ++ "}"- knot1 p k = "\\pstree{\\function{\\op{f}_5}}{" ++ k ++ p ++ "}"- knot2 p = "\\pstree{\\function{\\op{f}_6}}{" ++ p ++ "}"- basepair (p1,p2) = "\\pstree{\\function{\\op{f}_7}}{\\terminalvec{" ++ p1 ++ "}{" ++ p2 ++ "}}"- base b = "\\pstree{\\function{\\op{f}_8}}{\\terminal{" ++ b ++ "}}"- h = id+ rgknot :: RG_Algebra Char answer -> String -> [answer] rgknot algebra inp =
tests/ADP/Tests/Suite.hs view
@@ -35,6 +35,7 @@ ], testGroup "System tests" [ testCase "finds all reference structures" testRgSimpleCompleteness,+ -- the following is commented out as it takes quite long --testCase "finds pseudoknot reference structure" testRgRealPseudoknot, testCase "tests associative function with max basepairs" testRgSimpleBasepairs, testProperty "produces copy language" prop_copyLanguage,@@ -53,17 +54,8 @@ topt_maximum_generated_tests = Just 100 } }- -rg :: RG.RG_Algebra Char answer -> String -> [answer]-rg = RG.rgknot -rgDim2 :: RGDim2.RG_Algebra Char answer -> String -> [answer]-rgDim2 = RGDim2.rgknot--rgStar :: RGStar.RG_Algebra Char answer -> String -> [answer]-rgStar = RGStar.rgknot---- https://github.com/neothemachine/rna/wiki/Example+-- checks if RG grammar produces all structures for the given sequence testRgSimpleCompleteness = let inp = "agcgu" referenceStructures = [@@ -78,15 +70,15 @@ "(().)", "(.())" ]- result = rg RG.prettyprint inp+ result = RG.rgknot RG.prettyprint inp in do length result @?= length referenceStructures all (\ ([structure],_) -> structure `elem` referenceStructures) result @? "reference structure not found"- --- https://github.com/neothemachine/rna/wiki/Example+ +-- checks if RG grammar determines the right optimization result testRgSimpleBasepairs = let inp = "agcgu"- [maxBasepairs] = rg RG.maxBasepairs inp+ [maxBasepairs] = RG.rgknot RG.maxBasepairs inp in maxBasepairs @?= 2 -- http://www.ekevanbatenburg.nl/PKBASE/PKB00279.HTML@@ -95,23 +87,24 @@ let inp = map toLower "CAAUUUUCUGAAAAUUUUCAC" referenceStructure = ".(((((..[[[))))).]]]." referenceStructure2 = ".[[[[[..(((]]]]].)))."- result = rg RG.prettyprint inp+ result = RG.rgknot RG.prettyprint inp in any (\ ([structure],_) -> structure == referenceStructure || structure == referenceStructure2) result @? "reference structure not found" -smallTestSize prop = sized $ \n -> resize (round (sqrt (fromIntegral n))) prop-+-- checks if input sequence can be reconstructed prop_copyLanguage (CopyLangString w) = let result = Copy.copyGr Copy.prettyprint (w ++ w) in result == [w ++ w] +-- checks if input pair can be reconstructed prop_copyLanguageTT (CopyLangString w) = let result = CopyTT.copyTTGr CopyTT.prettyprint (w,w) in result == [(w,w)] -- this basically checks if the yield parser of adp-multi produces the same derivation trees -- as the MCFG parser by Johannes Waldmann--- Note: the copy language grammar is unambiguous! thus, ambiguous grammars (=multiple trees) are not tested here+-- Note: the copy language grammar is unambiguous! +-- thus, ambiguous grammars (=multiple trees) are not tested here prop_copyLanguageDerivation (CopyLangString w) = let [resultADP] = Copy.copyGr Copy.derivation (w ++ w) [resultMCFG] = MCFG.parse Copy.mcfg (map MCFG.T (w ++ w))@@ -126,31 +119,37 @@ in rule1 == rule2 && length children1 == length children2 && all (\(c1,c2) -> equivalentTrees c1 c2) children- ++-- checks if input sequence can be reconstructed prop_nestedRna (RNAString w) = let results = Nested.nested Nested.prettyprint w in not (null results) && all (\(_,result) -> result == w) results- ++-- checks if input sequence can be reconstructed prop_oneStructureRna (RNAString w) = let results = One.oneStructure One.prettyprint2 w in not (null results) && all (\[result] -> result == w) results +-- checks if input sequence can be reconstructed prop_rgRna (RNAString w) =- let results = rg RG.prettyprint w+ let results = RG.rgknot RG.prettyprint w in not (null results) && all (\(_,[result]) -> result == w) results +-- checks if both RG grammars produce the same results prop_rgDim2Rna (RNAString w) =- let results = rgDim2 RGDim2.prettyprint w- resultsDim1 = rg RG.prettyprint w+ let results = RGDim2.rgknot RGDim2.prettyprint w+ resultsDim1 = RG.rgknot RG.prettyprint w in results == resultsDim1 +-- checks if using the string elementary parsers produces consistent results prop_rgStarRna (RNAString w) =- let results = rgStar RGStar.prettyprint w- resultsRef = rg RG.prettyprint w+ let results = RGStar.rgknot RGStar.prettyprint w+ resultsRef = RG.rgknot RG.prettyprint w in results == resultsRef -- This test is a bit useless, it just shows that "something" happens.--- TODO: as in the other tests, we would need a pretty-printing algebra +-- As in the other tests, we would need a pretty-printing algebra+-- but so far no dot-bracket equivalent has been defined for RNA-RNA structures. prop_zeroStructureTwoBackbonesRna (RNAString w) = let results = ZeroTT.zeroStructureTwoBackbones ZeroTT.enum (w,w) in not (null results)
tests/ADP/Tests/TermExample.hs view
@@ -1,3 +1,5 @@+-- | A little thesis helper which parses plain terms and +-- returns them in various tex formats. module ADP.Tests.TermExample where import ADP.Multi.All @@ -36,7 +38,7 @@ single s = "child{" ++ s ++ "}" split s _ a = "child{" ++ s ++ "}" ++ a -qtree :: (String -> String) -- custom symbol formatting +qtree :: (String -> String) -- custom symbol formatting, see Main.hs -> Term_Algebra Char String qtree format = (wrap,sym,sym1,sym2,escape,fun,single,split) where wrap s = "\\Tree " ++ s
tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs view
@@ -13,14 +13,14 @@ import ADP.Multi.Rewriting.All import qualified ADP.Tests.OneStructureExample as One --- there are two answer types so that the enum algebra can be written (because data types aren't extensible)+-- there are two answer types so that the enum algebra can be written (because ADTs aren't extensible) -- for algebras with numeric answer types it wouldn't matter and we'd only need one type type ZeroStructureTwoBackbones_Algebra alphabet answerOne answer = ( One.OneStructure_Algebra alphabet answerOne,- answer -> answerOne -> answerOne -> answer, -- i1- answerOne -> answerOne -> answer, -- i2- answer -> answer -> answer, -- pt1- answer -> answer -> answer, -- pt2+ answer -> answerOne -> answerOne -> answer, -- i1+ answerOne -> answerOne -> answer, -- i2+ answer -> answer -> answer, -- pt1+ answer -> answer -> answer, -- pt2 answerOne -> answerOne -> answer -> answer -> answer, -- t1 answerOne -> answerOne -> answer -> answer -> answer, -- t2 answerOne -> answerOne -> answer -> answer -> answer, -- t3@@ -30,14 +30,14 @@ answerOne -> answerOne -> answerOne -> answerOne -> answer -> answer -> answer -> answer, -- t7 answerOne -> answerOne -> answer -> answer -> answer, -- hs2 answer -> answer -> answer -> answer -> answer, -- h1- answer -> answer, -- h2- answer -> answerOne -> answerOne -> answer -> answer, -- g1- answer -> answer, -- g2- answer -> answer -> answer, -- ub1- EPS -> answer, -- ub2- alphabet -> answer, -- base- (alphabet, alphabet) -> answer, -- basepair- [answer] -> [answer] -- h+ answer -> answer, -- h2+ answer -> answerOne -> answerOne -> answer -> answer, -- g1+ answer -> answer, -- g2+ answer -> answer -> answer, -- ub1+ EPS -> answer, -- ub2+ alphabet -> answer, -- base+ (alphabet, alphabet) -> answer, -- basepair+ [answer] -> [answer] -- h ) data T = OneStructure One.T@@ -67,8 +67,8 @@ enum = (One.enum,I1,I2,PT1,PT2,T1,T2,T3,T4,T5,T6,T7,Hs2,H1,H2,G1,G2,Ub1,\_->Ub2,Base,BasePair,id) {- To make the grammar reusable, its definition has been split up into the- actual grammar which exposes the start symbol as a parser (oneStructureGrammar)- and a convenience function which actually runs the grammar on a given input (oneStructure).+ actual grammar which exposes the start symbol as a parser (zeroStructureTwoBackbonesGrammar)+ and a convenience function which actually runs the grammar on a given input (zeroStructureTwoBackbones). -} zeroStructureTwoBackbones :: ZeroStructureTwoBackbones_Algebra Char answerOne answer -> (String,String) -> [answer] zeroStructureTwoBackbones algebra (inp1,inp2) =@@ -109,9 +109,9 @@ rewriteT6 [one1,one2,one3,one4,g1,g2,hs11,hs12,hs21,hs22] = ([g1,one1,hs11,one2,hs21,one3,g2],[hs12,one4,hs22]) rewriteT7 [one1,one2,one3,one4,hs11,hs12,hs21,hs22,g1,g2] = ([hs11,one1,hs21],[g1,one2,hs12,one3,hs22,one4,g2]) t = tabulated2 $- t1 <<< one ~~~ one ~~~ hs ~~~ hs >>> rewriteT1 |||- t2 <<< one ~~~ one ~~~ g ~~~ hs >>> rewriteT2 |||- t3 <<< one ~~~ one ~~~ hs ~~~ g >>> rewriteT3 |||+ t1 <<< one ~~~ one ~~~ hs ~~~ hs >>> rewriteT1 |||+ t2 <<< one ~~~ one ~~~ g ~~~ hs >>> rewriteT2 |||+ t3 <<< one ~~~ one ~~~ hs ~~~ g >>> rewriteT3 ||| t4 <<< one ~~~ one ~~~ one ~~~ one ~~~ g ~~~ hs ~~~ g >>> rewriteT4 ||| t5 <<< one ~~~ one ~~~ one ~~~ one ~~~ one ~~~ one ~~~ g ~~~ hs ~~~ hs ~~~ g >>> rewriteT5 ||| t6 <<< one ~~~ one ~~~ one ~~~ one ~~~ g ~~~ hs ~~~ hs >>> rewriteT6 |||
tests/MCFG/MCFG.hs view
@@ -1,10 +1,9 @@- -module MCFG.MCFG where - -- | multiple context free grammar, -- with CYK table parser. (Johannes Waldmann, HTWK Leipzig) --- Note (Maik): it is actually an Unger-style parser, or: top-down memoizing dynamic programming algorithm +-- Note (Maik): it is actually an Unger-style parser, +-- or: top-down memoizing dynamic programming algorithm +module MCFG.MCFG where import qualified Data.Map as M import Control.Monad.State.Strict