adp-multi 0.1.1 → 0.2.0
raw patch · 41 files changed
+2795/−2819 lines, 41 filesdep +Nussinov78dep +deepseqdep +mtldep −adp-multidep −monadiccpdep ~containersdep ~test-frameworkdep ~test-framework-hunitsetup-changed
Dependencies added: Nussinov78, deepseq, mtl
Dependencies removed: adp-multi, monadiccp
Dependency ranges changed: containers, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- Setup.hs +2/−2
- adp-multi.cabal +64/−41
- benchmarks/Benchmarks.hs +23/−42
- benchmarks/Criterion/Helpers.hs +8/−0
- src/ADP/Debug.hs +12/−5
- src/ADP/Multi/All.hs +10/−0
- src/ADP/Multi/Combinators.hs +130/−201
- src/ADP/Multi/ElementaryParsers.hs +179/−0
- src/ADP/Multi/Helpers.hs +37/−26
- src/ADP/Multi/Parser.hs +37/−30
- src/ADP/Multi/Rewriting.hs +15/−16
- src/ADP/Multi/Rewriting/All.hs +8/−0
- src/ADP/Multi/Rewriting/Combinators.hs +20/−0
- src/ADP/Multi/Rewriting/ConstraintSolver.hs +0/−297
- src/ADP/Multi/Rewriting/Explicit.hs +227/−347
- src/ADP/Multi/Rewriting/Model.hs +38/−0
- src/ADP/Multi/Rewriting/MonadicCpHelper.hs +0/−42
- src/ADP/Multi/Rewriting/RangesHelper.hs +130/−0
- src/ADP/Multi/Rewriting/YieldSize.hs +61/−69
- src/ADP/Multi/SimpleParsers.hs +0/−108
- src/ADP/Multi/Tabulation.hs +32/−35
- tests/ADP/Combinators.hs +0/−149
- tests/ADP/Multi/Rewriting/Tests/YieldSize.hs +87/−87
- tests/ADP/Tests/AlignmentExample.hs +81/−89
- tests/ADP/Tests/CopyExample.hs +103/−72
- tests/ADP/Tests/CopyTwoTrackExample.hs +52/−61
- tests/ADP/Tests/Main.hs +32/−12
- tests/ADP/Tests/MonadicCpRegression.hs +48/−48
- tests/ADP/Tests/MonadicCpTest.hs +54/−54
- tests/ADP/Tests/NestedExample.hs +41/−34
- tests/ADP/Tests/Nussinov.lhs +4/−4
- tests/ADP/Tests/NussinovExample.hs +21/−32
- tests/ADP/Tests/OneStructureExample.hs +203/−213
- tests/ADP/Tests/RGExample.hs +26/−36
- tests/ADP/Tests/RGExampleDim2.hs +250/−263
- tests/ADP/Tests/RGExampleStar.hs +221/−0
- tests/ADP/Tests/RIGExample.hs +0/−88
- tests/ADP/Tests/Suite.hs +171/−148
- tests/ADP/Tests/TermExample.hs +89/−0
- tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs +161/−168
- tests/MCFG/MCFG.hs +118/−0
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
adp-multi.cabal view
@@ -1,5 +1,5 @@ name: adp-multi -version: 0.1.1 +version: 0.2.0 cabal-version: >= 1.8 build-type: Simple author: Maik Riechert @@ -9,7 +9,9 @@ copyright: Maik Riechert, 2012 license: BSD3 license-file: LICENSE -tested-with: GHC==7.4.1 +tested-with: + GHC==7.4.1, + GHC==7.6.2 maintainer: Maik Riechert category: Algorithms, Data Structures, Bioinformatics synopsis: ADP for multiple context-free languages @@ -24,28 +26,41 @@ location: git://github.com/neothemachine/adp-multi.git Flag buildTests - description: Build test / benchmark executables + description: Build test executable default: False +Flag buildBenchmark + description: Build benchmark executable + default: False + +Flag DEBUG + description: Enable/disable debug output + default: False + library - build-depends: base == 4.*, + build-depends: base == 4.*, array == 0.4.*, - containers >= 0.4 && <= 0.5, - htrace == 0.1.*, - monadiccp == 0.7.* + containers >= 0.4 && < 0.6, + htrace == 0.1.* hs-source-dirs: src ghc-options: -Wall - exposed-modules: ADP.Debug, + if flag(DEBUG) + cpp-options: -DADPDEBUG + exposed-modules: + ADP.Debug, + ADP.Multi.All, ADP.Multi.Combinators, + ADP.Multi.ElementaryParsers, ADP.Multi.Helpers, ADP.Multi.Parser, ADP.Multi.Rewriting, - ADP.Multi.Rewriting.ConstraintSolver, + ADP.Multi.Rewriting.All, + ADP.Multi.Rewriting.Combinators, ADP.Multi.Rewriting.Explicit, + ADP.Multi.Rewriting.Model, + ADP.Multi.Rewriting.RangesHelper, ADP.Multi.Rewriting.YieldSize, - ADP.Multi.SimpleParsers, ADP.Multi.Tabulation - other-modules: ADP.Multi.Rewriting.MonadicCpHelper test-suite MainTestSuite type: exitcode-stdio-1.0 @@ -53,19 +68,18 @@ build-depends: base == 4.*, array == 0.4.*, - containers >= 0.4 && <= 0.5, - adp-multi, - monadiccp == 0.7.*, + containers >= 0.4 && < 0.6, + htrace == 0.1.*, 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 + test-framework == 0.8.*, + test-framework-quickcheck2 == 0.3.*, + test-framework-hunit == 0.3.*, + random-shuffle == 0.0.4, + mtl >= 2.0 && < 2.2 + hs-source-dirs: tests,src ghc-options: -Wall -rtsopts other-modules: - ADP.Combinators, ADP.Multi.Rewriting.Tests.YieldSize, ADP.Tests.AlignmentExample, ADP.Tests.CopyExample, @@ -79,47 +93,56 @@ ADP.Tests.OneStructureExample, ADP.Tests.RGExample, ADP.Tests.RGExampleDim2, - ADP.Tests.RIGExample, - ADP.Tests.ZeroStructureTwoBackbonesExample + ADP.Tests.RGExampleStar, + ADP.Tests.TermExample, + ADP.Tests.ZeroStructureTwoBackbonesExample, + MCFG.MCFG main-is: ADP/Tests/Suite.hs executable adp-multi-benchmarks - if !flag(buildTests) + if !flag(buildBenchmark) buildable: False - build-depends: + else + build-depends: base == 4.*, array == 0.4.*, - containers >= 0.4 && <= 0.5, - adp-multi, - monadiccp == 0.7.*, + containers >= 0.4 && < 0.6, + htrace == 0.1.*, HUnit == 1.2.*, QuickCheck == 2.5.*, - test-framework == 0.6.*, - test-framework-quickcheck2 == 0.2.*, - test-framework-hunit == 0.2.*, + test-framework == 0.8.*, + test-framework-quickcheck2 == 0.3.*, + test-framework-hunit == 0.3.*, random-shuffle == 0.0.4, - criterion == 0.6.* + mtl >= 2.0 && < 2.2, + Nussinov78 == 0.1.0.0, + criterion == 0.6.*, + deepseq >= 1.1.0.0 hs-source-dirs: benchmarks, - tests + tests, + src ghc-options: -Wall -rtsopts main-is: Benchmarks.hs + other-modules: Criterion.Helpers executable adp-test if !flag(buildTests) buildable: False - build-depends: + else + build-depends: base == 4.*, array == 0.4.*, - containers >= 0.4 && <= 0.5, - adp-multi, - monadiccp == 0.7.*, + containers >= 0.4 && < 0.6, + htrace == 0.1.*, HUnit == 1.2.*, QuickCheck == 2.5.*, - test-framework == 0.6.*, - test-framework-quickcheck2 == 0.2.*, - test-framework-hunit == 0.2.*, + test-framework == 0.8.*, + test-framework-quickcheck2 == 0.3.*, + test-framework-hunit == 0.3.*, + mtl >= 2.0 && < 2.2, random-shuffle == 0.0.4 - hs-source-dirs: tests + hs-source-dirs: tests,src ghc-options: -Wall -rtsopts -O0 + if flag(DEBUG) + cpp-options: -DADPDEBUG main-is: ADP/Tests/Main.hs -
benchmarks/Benchmarks.hs view
@@ -1,42 +1,23 @@-import Criterion.Main - -import ADP.Multi.Rewriting.ConstraintSolver as CS -import ADP.Multi.Rewriting.Explicit as EX -import ADP.Tests.RGExample as RG -import ADP.Tests.RGExampleDim2 as RG2 -import ADP.Tests.Nussinov as Nuss -import ADP.Tests.NussinovExample as Nuss2 - -main :: IO () -main = defaultMain - [ - bgroup "compare explicit vs constraint solver range construction" [ - bgroup "RG dim1+2" [ - bench "explicit" $ nf (simple EX.determineYieldSize1 EX.constructRanges1 EX.determineYieldSize2) EX.constructRanges2, - bench "constraint solver" $ nf (simple CS.determineYieldSize1 CS.constructRanges1 CS.determineYieldSize2) CS.constructRanges2 - ], - bgroup "RG dim2" [ - bench "explicit" $ nf (simple2 EX.determineYieldSize1 EX.constructRanges1 EX.determineYieldSize2) EX.constructRanges2, - bench "constraint solver" $ nf (simple2 CS.determineYieldSize1 CS.constructRanges1 CS.determineYieldSize2) CS.constructRanges2 - ] - ], - bgroup "compare different nussinovs" [ - bench "nussinov78 (adp)" $ nf (Nuss.nussinov78 Nuss.pairmax) longInp, - bench "nussinov78' (adp)" $ nf (Nuss.nussinov78' Nuss.pairmax) longInp, - bench "nussinov78 (adp-multi)" $ nf (Nuss2.nussinov78 EX.determineYieldSize1 EX.constructRanges1 Nuss2.pairmax) longInp - ], - bgroup "compare different nussinovs (doubled size)" [ - bench "nussinov78 (adp)" $ nf (Nuss.nussinov78 Nuss.pairmax) veryLongInp, - bench "nussinov78' (adp)" $ nf (Nuss.nussinov78' Nuss.pairmax) veryLongInp, - bench "nussinov78 (adp-multi)" $ nf (Nuss2.nussinov78 EX.determineYieldSize1 EX.constructRanges1 Nuss2.pairmax) veryLongInp - ] - ] - -longInp = "ggcguaggcgccgugcuuuugcuccccgcgcgcuguuuuucucgcugacuuucagcgggcggaaaagccucggccugccgccuuccaccguucauucuagagcaaacaaaaaaugucagcu" -veryLongInp = longInp ++ longInp - -simple yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 = - RG.rgknot yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 RG.maxBasepairs "agcgu" - -simple2 yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 = - RG2.rgknot yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 RG2.maxBasepairs "agcgu"+import Criterion.Main+import Criterion.Helpers++import ADP.Tests.Nussinov as Nuss+import ADP.Tests.NussinovExample 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 (ADPfusion)" (benchArray (fst . Nuss3.nussinov78) inputs)+ ]+ where+ longInp = "ggcguaggcgccgugcuuuugcuccccgcgcgcuguuuuucucgcugacuuucagcgggcggaaaagccucggccugccgccuuccaccguucauucuag"+ infiniteInp = cycle longInp+ + inputs = [ (show i, take i infiniteInp) | i <- [100,200..1000] ]
+ benchmarks/Criterion/Helpers.hs view
@@ -0,0 +1,8 @@+module Criterion.Helpers where + +import Criterion.Main +import Control.DeepSeq (NFData) + +benchArray :: NFData b => (a -> b) -> [(String,a)] -> [Benchmark] +benchArray fun args = + [bench name (nf fun arg) | (name,arg) <- args]
src/ADP/Debug.hs view
@@ -1,6 +1,13 @@-module ADP.Debug where - -import Debug.HTrace (htrace) +{-# LANGUAGE CPP #-}++-- | Debugging is enabled via the cabal flag /DEBUG/+module ADP.Debug where++import Debug.HTrace (htrace) -trace _ b = b ---trace = htrace+trace :: String -> a -> a+#ifdef ADPDEBUG+trace = htrace+#else+trace _ b = b+#endif
+ src/ADP/Multi/All.hs view
@@ -0,0 +1,10 @@+-- | Convenience module to import everything except a specific +-- rewriting combinator implementation. See "ADP.Multi.Rewriting.All" +-- for that. +module ADP.Multi.All (module X) where + +import ADP.Multi.Parser as X +import ADP.Multi.ElementaryParsers as X +import ADP.Multi.Combinators as X +import ADP.Multi.Tabulation as X +import ADP.Multi.Helpers as X
src/ADP/Multi/Combinators.hs view
@@ -1,201 +1,130 @@-{-# LANGUAGE ImplicitParams #-} - -module ADP.Multi.Combinators where - -import Data.Maybe -import Data.Array -import qualified Control.Arrow as A - -import ADP.Debug -import ADP.Multi.Parser -import ADP.Multi.Rewriting - -{- - -TODO - -Weakening types: - -The Subword in Parser could be made generic as a list. Then -the subword in Ranges would also be a list instead of a tuple. The simple parser would -then pattern match his accepting subword as e.g. [x1,x2,x3,x4] and this would happen for -every call to a parser. It's not clear how well GHC optimizes this, probably not as much as tuples. -We would loose some type-safety and (probably) performance but still have readable code. - -=> This branch tries the above approach. - -Using full type system without data-constructs: - -If no data-constructs are used, then instead we need many combinations of overloads simulated with -type classes. Then the rewriting functions would also (need to) be type-safe, but it is not yet clear -how to do that. - - --> Considering that this is a prototype and probably won't be used in this form, it might be too much effort -to get full type-safety. - - --} - - - --- TODO use static info about min yield sizes for self-recursion --- This is not easy to solve for indirect recursion like S -> a | aP, P -> aS | a --- At the moment we would use S -> a | a ~~~| P and P -> a ~~~| S | a to prevent --- endless recursion at yield size analysis. Therefore, as ~~~| isn't only used --- for direct self-recursion, we would need to analyse the grammar in its whole to --- detect cycles which seems impossible without creating a complete AST. --- TODO define which grammars are not useable without a whole-grammar yield size analysis - - - -infix 8 <<< -(<<<) :: Parseable p a b => (b -> c) -> p -> ([ParserInfo], [Ranges] -> Parser a c) -(<<<) f parseable = - let (info,parser) = toParser parseable - in ( - [info], - \ [] z subword -> map f (parser z subword) - ) - --- special version of <<< which ignores the first parser for determining the yield sizes --- for dim1 parsers -infix 8 <<<| -(<<<|) :: Parseable p a b => (b -> c) -> p -> ([ParserInfo], [Ranges] -> Parser a c) -(<<<|) f parseable = - let (_,parser) = toParser parseable - info = ParserInfo1 { minYield = 0, maxYield = Nothing } - in ( - [info], - \ [] z subword -> map f (parser z subword) - ) - --- special version of <<< which ignores the first parser for determining the yield sizes --- for dim2 parsers -infix 8 <<<|| -(<<<||) :: Parseable p a b => (b -> c) -> p -> ([ParserInfo], [Ranges] -> Parser a c) -(<<<||) f parseable = - let (_,parser) = toParser parseable - info = ParserInfo2 { minYield2 = (0,0), maxYield2 = (Nothing,Nothing) } - in ( - [info], - \ [] z subword -> map f (parser z subword) - ) - -infixl 7 ~~~ -(~~~) :: Parseable p a b => ([ParserInfo], [Ranges] -> Parser a (b -> c)) -> p -> ([ParserInfo], [Ranges] -> Parser a c) -(~~~) (infos,leftParser) parseable = - let (info,rightParser) = toParser parseable - in ( - info : infos, - \ ranges z subword -> - [ pr qr | - qr <- rightParser z subword - , RangeMap sub rest <- ranges - , pr <- leftParser rest z sub - ] - ) - - --- special version of ~~~ which ignores the right parser for determining the yield sizes --- this must be used for self-recursion, mutual recursion etc. There must be no cycles! --- I guess this only works because of laziness (ignoring the info value of toParser). --- for 1-dim parsers -infixl 7 ~~~| -(~~~|) :: Parseable p a b => ([ParserInfo], [Ranges] -> Parser a (b -> c)) -> p -> ([ParserInfo], [Ranges] -> Parser a c) -(~~~|) (infos,leftParser) parseable = - let (_,rightParser) = toParser parseable - info = ParserInfo1 { minYield = 0, maxYield = Nothing } - in ( - info : infos, - \ ranges z subword -> - [ pr qr | - qr <- rightParser z subword - , RangeMap sub rest <- ranges - , pr <- leftParser rest z sub - ] - ) - --- for 2-dim parsers -infixl 7 ~~~|| -(~~~||) :: Parseable p a b => ([ParserInfo], [Ranges] -> Parser a (b -> c)) -> p -> ([ParserInfo], [Ranges] -> Parser a c) -(~~~||) (infos,leftParser) parseable = - let (_,rightParser) = toParser parseable - info = ParserInfo2 { minYield2 = (0,0), maxYield2 = (Nothing,Nothing) } - in ( - info : infos, - \ ranges z subword -> - [ pr qr | - qr <- rightParser z subword - , RangeMap sub rest <- ranges - , pr <- leftParser rest z sub - ] - ) - -infix 6 >>>| -(>>>|) :: (?yieldAlg1 :: YieldAnalysisAlgorithm Dim1, ?rangeAlg1 :: RangeConstructionAlgorithm Dim1) - => ([ParserInfo], [Ranges] -> Parser a b) -> Dim1 -> RichParser a b -(>>>|) = rewrite ?yieldAlg1 ?rangeAlg1 - -infix 6 >>>|| -(>>>||) :: (?yieldAlg2 :: YieldAnalysisAlgorithm Dim2, ?rangeAlg2 :: RangeConstructionAlgorithm Dim2) - => ([ParserInfo], [Ranges] -> Parser a b) -> Dim2 -> RichParser a b -(>>>||) = rewrite ?yieldAlg2 ?rangeAlg2 - -rewrite yieldAlg rangeAlg (infos,p) f = - let yieldSize = yieldAlg f infos - in trace (">>> yield size: " ++ show yieldSize) $ - ( - yieldSize, - \ z subword -> - let ranges = rangeAlg f infos subword - in trace (">>> " ++ show subword) $ - trace ("ranges: " ++ show ranges) $ - [ result | - RangeMap sub rest <- ranges - , result <- p rest z sub - ] - ) - -infixr 5 ||| -(|||) :: RichParser a b -> RichParser a b -> RichParser a b -(|||) (ParserInfo1 {minYield=minY1, maxYield=maxY1}, r) (ParserInfo1 {minYield=minY2, maxYield=maxY2}, q) = - ( - ParserInfo1 { - minYield = min minY1 minY2, - maxYield = if isNothing maxY1 || isNothing maxY2 then Nothing else max maxY1 maxY2 - }, - \ z subword -> r z subword ++ q z subword - ) -(|||) (ParserInfo2 {minYield2=minY1, maxYield2=maxY1}, r) (ParserInfo2 {minYield2=minY2, maxYield2=maxY2}, q) = - ( - ParserInfo2 { - minYield2 = combineMinYields minY1 minY2, - maxYield2 = combineMaxYields maxY1 maxY2 - }, - \ z subword -> r z subword ++ q z subword - ) -(|||) _ _ = error "Different parser dimensions can't be combined with ||| !" - -combineMinYields :: (Int,Int) -> (Int,Int) -> (Int,Int) -combineMinYields (min11,min12) (min21,min22) = (min min11 min21, min min12 min22) - -combineMaxYields :: (Maybe Int,Maybe Int) -> (Maybe Int,Maybe Int) -> (Maybe Int,Maybe Int) -combineMaxYields (a,b) (c,d) = - ( if isNothing a || isNothing c then Nothing else max a c - , if isNothing b || isNothing d then Nothing else max b d - ) - -infix 4 ... -(...) :: RichParser a b -> ([b] -> [b]) -> RichParser a b -(...) (info,r) h = (info, \ z subword -> h (r z subword) ) ---(...) richParser h = A.second (\ r z subword -> h (r z subword) ) richParser - - -type Filter a = Array Int a -> Subword -> Bool -with :: RichParser a b -> Filter a -> RichParser a b -with (info,q) c = - ( - info, - \ z subword -> if c z subword then q z subword else [] - ) +{-# LANGUAGE MultiParamTypeClasses #-}++-- | Parser combinators for use in grammars+module ADP.Multi.Combinators (+ (<<<),+ (~~~),+ Rewritable(..), rewrite,+ (|||),+ (...),+ Filter, with,+ yieldSize1, yieldSize2+) where++import Data.Array+import Control.Monad (liftM2)++import ADP.Multi.Parser+import ADP.Multi.Rewriting++++eval :: (b -> c) -> Parser a b -> ([SubwordTree] -> Parser a c)+eval f parser [] z subword = map f (parser z subword) ++infix 8 <<<+(<<<) :: Parseable p a b + => (b -> c)+ -> p+ -> ([ParserInfo], [SubwordTree] -> Parser a c)+(<<<) f parseable =+ let (info,parser) = toParser parseable+ in ([info], eval f parser)++seqDefer :: ([SubwordTree] -> Parser a (b -> c)) + -> Parser a b+ -> ([SubwordTree] -> Parser a c)+seqDefer leftParser rightParser subwordTrees z subword =+ [ pr qr |+ qr <- rightParser z subword+ , SubwordTree sub rest <- subwordTrees+ , pr <- leftParser rest z sub + ]++infixl 7 ~~~+(~~~) :: Parseable p a b + => ([ParserInfo], [SubwordTree] -> Parser a (b -> c))+ -> p+ -> ([ParserInfo], [SubwordTree] -> Parser a c)+(~~~) (infos,leftParser) parseable =+ let (info,rightParser) = toParser parseable+ in (info : infos, seqDefer leftParser rightParser) + +-- | Explicitly specify yield size of a parser.+yieldSize :: ParserInfo -> RichParser a b -> RichParser a b+yieldSize info (_,p) = (info, p)++-- two convenience functions so that ParserInfo stays hidden++-- | Explicitly specify yield size of a 1-dim parser.+yieldSize1 :: (Int,Maybe Int) -> RichParser a b -> RichParser a b+yieldSize1 (minY,maxY) = + yieldSize (ParserInfo1 minY maxY)++-- | Explicitly specify yield size of a 2-dim parser.+yieldSize2 :: (Int,Maybe Int) -> (Int,Maybe Int) + -> RichParser a b -> RichParser a b+yieldSize2 (minY1,maxY1) (minY2,maxY2) = + yieldSize (ParserInfo2 (minY1,minY2) (maxY1,maxY2))+++rewrite :: SubwordConstructionAlgorithm a+ -> ([ParserInfo], [SubwordTree] -> Parser b c) + -> a -- ^ rewriting function+ -> Parser b c+rewrite subwordAlg (infos,p) r z subword =+ let subwordTrees = subwordAlg r infos subword+ in [ result |+ SubwordTree sub rest <- subwordTrees+ , result <- p rest z sub+ ]+ +class Rewritable r a b where+ infix 6 >>>+ (>>>) :: ([ParserInfo], [SubwordTree] -> Parser a b) -> r -> RichParser a b ++alt :: Parser a b -> Parser a b -> Parser a b+alt r q z subword = r z subword ++ q z subword ++infixr 5 ||| +(|||) :: RichParser a b -> RichParser a b -> RichParser a b+(|||) (ParserInfo1 minY1 maxY1, r) (ParserInfo1 minY2 maxY2, q) = + (+ ParserInfo1 {+ minYield = min minY1 minY2,+ maxYield = liftM2 max maxY1 maxY2+ },+ alt r q+ ) +(|||) (ParserInfo2 (minY11,minY12) (maxY11,maxY12), r) + (ParserInfo2 (minY21,minY22) (maxY21,maxY22), q) = + (+ ParserInfo2 {+ minYield2 = (min minY11 minY21, min minY12 minY22),+ maxYield2 = (liftM2 max maxY11 maxY21, liftM2 max maxY12 maxY22) + },+ alt r q+ )+(|||) _ _ = error "Different parser dimensions can't be combined with ||| !"+++select :: Parser a b -> ([b] -> [b]) -> Parser a b+select r h z subword = h (r z subword)++infix 4 ...+(...) :: RichParser a b -> ([b] -> [b]) -> RichParser a b+(...) (info,r) h = (info, select r h)+++{- |+Filters are not part of ADP-MCFL, but are sometimes used in RNA folding+to skip parses where subwords are too long, e.g. restricting loop size+to 30. It is included here for convenience.+-} +type Filter a = Array Int a -> Subword -> Bool++with' :: Parser a b -> Filter a -> Parser a b+with' q c z subword = if c z subword then q z subword else []++with :: RichParser a b -> Filter a -> RichParser a b+with (info,q) c = (info, with' q c)
+ src/ADP/Multi/ElementaryParsers.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- needed for Parseable +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Elementary parsers for dimensions 1 and 2 +module ADP.Multi.ElementaryParsers ( + string, + string2, + empty1, + empty2, + anychar, + anycharExcept, + anychar2, + char, + char2, + charLeftOnly, + charRightOnly, + EPS(..) +) where + +import Data.Array +import Data.Typeable +import Data.Data +import ADP.Multi.Parser + +string' :: Eq a => [a] -> Parser a [a] +string' s z [i,j] = + [ s | + j-i == length s && + all (\i' -> z!i' == s !! (i'-i-1)) [i+1..j] + ] + +string :: Eq a => [a] -> RichParser a [a] +string s = + ( + ParserInfo1 {minYield=length s, maxYield=Just (length s)}, + string' s + ) + +string2' :: Eq a => [a] -> [a] -> Parser a ([a],[a]) +string2' s1 s2 z [i,j,k,l] = + [ (s1,s2) | + j-i == length s1 && all (\i' -> z!i' == s1 !! (i'-i-1)) [i+1..j] && + l-k == length s2 && all (\k' -> z!k' == s2 !! (k'-k-1)) [k+1..l] + ] + +string2 :: Eq a => [a] -> [a] -> RichParser a ([a],[a]) +string2 s1 s2 = + ( + ParserInfo2 + { + minYield2=(length s1,length s2), + maxYield2=(Just (length s1),Just (length s2)) + }, + string2' s1 s2 + ) + +data EPS = EPS deriving (Eq, Show, Data, Typeable) + +empty1' :: Parser a EPS +empty1' _ [i,j] = [ EPS | i == j ] + +empty1 :: RichParser a EPS +empty1 = ( + ParserInfo1 {minYield=0, maxYield=Just 0}, + empty1' + ) + +empty2' :: Parser a (EPS,EPS) +empty2' _ [i,j,k,l] = [ (EPS,EPS) | i == j && k == l ] + +empty2 :: RichParser a (EPS,EPS) +empty2 = ( + ParserInfo2 {minYield2=(0,0), maxYield2=(Just 0,Just 0)}, + empty2' + ) + +anychar' :: Parser a a +anychar' z [i,j] = [ z!j | i+1 == j ] + +anychar :: RichParser a a +anychar = ( + ParserInfo1 {minYield=1, maxYield=Just 1}, + anychar' + ) + +anychar2' :: Parser a (a,a) +anychar2' z [i,j,k,l] = [ (z!j, z!l) | i+1 == j && k+1 == l ] + +anychar2 :: RichParser a (a,a) +anychar2 = ( + ParserInfo2 {minYield2=(1,1), maxYield2=(Just 1,Just 1)}, + anychar2' + ) + +anycharExcept' :: Eq a => [a] -> Parser a a +anycharExcept' e z [i,j] = [ z!j | i+1 == j && z!j `notElem` e ] + +anycharExcept :: Eq a => [a] -> RichParser a a +anycharExcept e = ( + ParserInfo1 {minYield=1, maxYield=Just 1}, + anycharExcept' e + ) + +char' :: Eq a => a -> Parser a a +char' c z [i,j] = [ z!j | i+1 == j && z!j == c ] + +char :: Eq a => a -> RichParser a a +char c = ( + ParserInfo1 {minYield=1, maxYield=Just 1}, + char' c + ) + +char2' :: Eq a => a -> a -> Parser a (a,a) +char2' c1 c2 z [i,j,k,l] = + [ (z!j, z!l) | + i+1 == j && k+1 == l && z!j == c1 && z!l == c2 + ] + +char2 :: Eq a => a -> a -> RichParser a (a,a) +char2 c1 c2 = ( + ParserInfo2 {minYield2=(1,1), maxYield2=(Just 1,Just 1)}, + char2' c1 c2 + ) + +charLeftOnly' :: Eq a => a -> Parser a (a,EPS) +charLeftOnly' c z [i,j,k,l] = + [ (c, EPS) | i+1 == j && k == l && z!j == c ] + +charLeftOnly :: Eq a => a -> RichParser a (a,EPS) +charLeftOnly c = ( + ParserInfo2 {minYield2=(1,0), maxYield2=(Just 1,Just 0)}, + charLeftOnly' c + ) + +charRightOnly' :: Eq a => a -> Parser a (EPS,a) +charRightOnly' c z [i,j,k,l] = + [ (EPS, c) | i == j && k+1 == l && z!l == c ] + +charRightOnly :: Eq a => a -> RichParser a (EPS,a) +charRightOnly c = ( + ParserInfo2 {minYield2=(0,1), maxYield2=(Just 0,Just 1)}, + charRightOnly' c + ) + +-- * some syntax sugar + +-- ** generic instances +instance Parseable EPS a EPS where + toParser _ = empty1 + +instance Parseable (EPS,EPS) a (EPS,EPS) where + toParser _ = empty2 + +instance Eq a => Parseable [a] a [a] where + toParser = string + +instance Eq a => Parseable ([a],[a]) a ([a],[a]) where + toParser (s1,s2) = string2 s1 s2 + +-- ** specific instances for chars + +-- these can't be made generic as it would lead to `Parseable a a a` which is +-- in conflict to all other instances + +instance Parseable Char Char Char where + toParser = char + +instance Parseable (Char,Char) Char (Char,Char) where + toParser (c1,c2) = char2 c1 c2 + +instance Parseable (EPS,Char) Char (EPS,Char) where + toParser (_,c) = charRightOnly c + +instance Parseable (Char,EPS) Char (Char,EPS) where + toParser (c,_) = charLeftOnly c
src/ADP/Multi/Helpers.hs view
@@ -1,27 +1,38 @@-module ADP.Multi.Helpers where - -import Control.Exception -import Data.Array -import ADP.Multi.Parser - -axiom :: Array Int a -> RichParser a b -> [b] -axiom z (_,ax) = - let (_,l) = bounds z - in ax z [0,l] - - -axiomTwoTrack :: Eq a => Array Int a -> [a] -> [a] -> RichParser a b -> [b] -axiomTwoTrack z inp1 inp2 (_,ax) = - assert (z == mkTwoTrack inp1 inp2) $ - ax z [0,l1,l1,l1+l2] - where l1 = length inp1 - l2 = length inp2 - - --- # Create array from List - -mk :: [a] -> Array Int a -mk xs = array (1,length xs) (zip [1..] xs) - -mkTwoTrack :: [a] -> [a] -> Array Int a +-- | Provides several convenience functions to ease parsing setup.+module ADP.Multi.Helpers (+ mk,+ mkTwoTrack,+ axiom,+ axiomTwoTrack+) where++import Control.Exception+import Data.Array+import ADP.Multi.Parser++-- | Turns an input sequence into an array for use with a 1-dim parser.+-- Typically, this prepares the input for the 'axiom' function.+mk :: [a] -> Array Int a+mk xs = array (1,length xs) (zip [1..] xs)++-- | Turns two input sequences into an array for use with a 2-dim parser.+-- Typically, this prepares the input for the 'axiomTwoTrack' function.+mkTwoTrack :: [a] -> [a] -> Array Int a mkTwoTrack xs ys = mk (xs ++ ys)++-- | Convenience function for parsing a given input+-- using a 1-dim parser, usually the start nonterminal.+axiom :: Array Int a -> RichParser a b -> [b]+axiom z (_,ax) =+ let (_,l) = bounds z+ in ax z [0,l]+ +-- | Convenience function for parsing a given input pair+-- using a 2-dim parser, usually the start nonterminal.+axiomTwoTrack :: Eq a => Array Int a -> [a] -> [a] -> RichParser a b -> [b]+axiomTwoTrack z inp1 inp2 (_,ax) =+ assert (z == mkTwoTrack inp1 inp2) $+ ax z [0,l1,l1,l1+l2]+ where l1 = length inp1+ l2 = length inp2+
src/ADP/Multi/Parser.hs view
@@ -1,30 +1,37 @@-{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} - -module ADP.Multi.Parser where - -import Data.Array - -type Subword = [Int] -type Parser a b = Array Int a -> Subword -> [b] - -data ParserInfo = ParserInfo1 - { - minYield :: Int - , maxYield :: Maybe Int - } - | ParserInfo2 - { - minYield2 :: (Int,Int) - , maxYield2 :: (Maybe Int,Maybe Int) - } - deriving (Eq, Show) - -type RichParser a b = (ParserInfo, Parser a b) - -class Parseable p a b | p -> a b where - toParser :: p -> RichParser a b - -instance Parseable (RichParser a b) a b where - toParser p = p +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | Some common types for parsers. +module ADP.Multi.Parser where++import Data.Array++-- | To support higher dimensions, a subword is a list+-- of indices. Valid list lengths are 2n with n>0.+type Subword = [Int]++type Parser a b = Array Int a -- ^ The input sequence+ -> Subword -- ^ Subword of the input sequence to be parsed+ -> [b] -- ^ Parsing results++-- | Static information about yield sizes of a parser.+-- For supporting dimensions > 2, this type has to be+-- expanded with more constructors, or redesigned to be generic.+data ParserInfo = ParserInfo1 {+ minYield :: Int+ , maxYield :: Maybe Int+ }+ | ParserInfo2 {+ minYield2 :: (Int,Int)+ , maxYield2 :: (Maybe Int,Maybe Int)+ }+ deriving (Eq, Show)+ +type RichParser a b = (ParserInfo, Parser a b)++class Parseable p a b | p -> a b where+ toParser :: p -> RichParser a b+ +instance Parseable (RichParser a b) a b where+ toParser p = p
src/ADP/Multi/Rewriting.hs view
@@ -1,16 +1,15 @@-module ADP.Multi.Rewriting where - -import ADP.Multi.Parser - -data Ranges = RangeMap Subword [Ranges] deriving Show - -type YieldAnalysisAlgorithm a = a -> [ParserInfo] -> ParserInfo -type RangeConstructionAlgorithm a = a -> [ParserInfo] -> Subword -> [Ranges] - -type Dim1 = [(Int, Int)] -> [(Int, Int)] -type Dim2 = [(Int, Int)] -> ([(Int, Int)], [(Int, Int)]) - --- | Convenience function for one dim2 symbol -id2 :: [a] -> ([a], [a]) -id2 [c1,c2] = ([c1],[c2]) -id2 _ = error "Only use id2 for single symbols! Write your own rewrite function instead."+-- | Types for the rewriting combinator+module ADP.Multi.Rewriting where++import ADP.Multi.Parser++-- | Tree of subwords. Every path in a tree represents+-- a sequence of subwords for a corresponding sequence of parsers+-- in a production. +data SubwordTree = SubwordTree Subword [SubwordTree] deriving Show++type SubwordConstructionAlgorithm a + = a -- ^ rewriting function+ -> [ParserInfo] -- ^ yield size info for each parser of a production+ -> Subword -- ^ subword for which subwords should be constructed+ -> [SubwordTree] -- ^ constructed subwords, represented as tree
+ src/ADP/Multi/Rewriting/All.hs view
@@ -0,0 +1,8 @@+-- | Convenience module to import the specific rewriting function model+-- and combinator implementation known as /explicit/.+-- In package adp-multi-monadiccp, there is another+-- combinator implementation.+module ADP.Multi.Rewriting.All (module X) where++import ADP.Multi.Rewriting.Model as X +import ADP.Multi.Rewriting.Combinators()
+ src/ADP/Multi/Rewriting/Combinators.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Provides instance implementations for the >>> combinator +-- using the /explicit/ subword construction algorithm. +module ADP.Multi.Rewriting.Combinators where + +import ADP.Multi.Combinators +import ADP.Multi.Rewriting.Model +import ADP.Multi.Rewriting.YieldSize +import ADP.Multi.Rewriting.Explicit + +instance Rewritable Dim1 a b where + (>>>) (infos,p) f = + (determineYieldSize1 f infos, rewrite constructSubwords1 (infos,p) f) + +instance Rewritable Dim2 a b where + (>>>) (infos,p) f = + (determineYieldSize2 f infos, rewrite constructSubwords2 (infos,p) f)
− src/ADP/Multi/Rewriting/ConstraintSolver.hs
@@ -1,297 +0,0 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -{- -Use monadiccp as a finite-domain constraint solver to construct -subwords in a generic way. - -TODO It is slow as hell. Maybe it is possible to "compile" the two inequality - systems so that they can later be run faster. - see http://www.cs.washington.edu/research/constraints/solvers/cp97.html --} -module ADP.Multi.Rewriting.ConstraintSolver ( - determineYieldSize1, - determineYieldSize2, - constructRanges1, - constructRanges2 -) where - -import Control.Exception -import Data.List (elemIndex, find) -import qualified Data.Map as Map -import Data.Maybe (fromJust, isNothing) - -import ADP.Debug -import ADP.Multi.Parser -import ADP.Multi.Rewriting -import ADP.Multi.Rewriting.YieldSize - -import ADP.Multi.Rewriting.MonadicCpHelper -import Control.CP.FD.Interface - -type Subword1 = (Int,Int) -type Subword2 = (Int,Int,Int,Int) - -constructRanges1 :: RangeConstructionAlgorithm Dim1 -constructRanges1 _ _ b | trace ("constructRanges1 " ++ show b) False = undefined -constructRanges1 f infos [i,j] = - assert (i <= j) $ - let parserCount = length infos - elemInfo = buildInfoMap infos - rewritten = f (Map.keys elemInfo) - remainingSymbols = [parserCount,parserCount-1..1] `zip` infos - rangeDesc = [(i,j,rewritten)] - rangeDescFiltered = filterEmptyRanges rangeDesc - in trace (show remainingSymbols) $ - if any (\(m,n,d) -> null d && m /= n) rangeDesc then [] - else constructRangesRec elemInfo remainingSymbols rangeDescFiltered - -constructRanges2 :: RangeConstructionAlgorithm Dim2 -constructRanges2 _ _ b | trace ("constructRanges2 " ++ show b) False = undefined -constructRanges2 f infos [i,j,k,l] = - assert (i <= j && j <= k && k <= l) $ - let parserCount = length infos - elemInfo = buildInfoMap infos - (left,right) = f (Map.keys elemInfo) - remainingSymbols = [parserCount,parserCount-1..1] `zip` infos - rangeDesc = [(i,j,left),(k,l,right)] - rangeDescFiltered = filterEmptyRanges rangeDesc - in if any (\(m,n,d) -> null d && m /= n) rangeDesc then [] - else constructRangesRec elemInfo remainingSymbols rangeDescFiltered - -determineYieldSize1 :: YieldAnalysisAlgorithm Dim1 -determineYieldSize1 _ infos | trace ("determineYieldSize1 " ++ show infos) False = undefined -determineYieldSize1 f infos = doDetermineYieldSize1 f infos - -determineYieldSize2 :: YieldAnalysisAlgorithm Dim2 -determineYieldSize2 _ infos | trace ("determineYieldSize2 " ++ show infos) False = undefined -determineYieldSize2 f infos = doDetermineYieldSize2 f infos - - -type RangeDesc = (Int,Int,[(Int,Int)]) - -constructRangesRec :: InfoMap -> [(Int,ParserInfo)] -> [RangeDesc] -> [Ranges] -constructRangesRec a b c | trace ("constructRangesRec " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -constructRangesRec _ [] [] = [] -constructRangesRec infoMap ((current,ParserInfo2 {}):rest) rangeDescs = - let symbolLoc = findSymbol2 current rangeDescs - subwords = calcSubwords2 infoMap symbolLoc - in trace ("calc subwords for dim2") $ - trace ("subwords: " ++ show subwords) $ - [ RangeMap [i,j,k,l] restRanges | - (i,j,k,l) <- subwords, - let newDescs = constructNewRangeDescs2 rangeDescs symbolLoc (i,j,k,l), - let restRanges = constructRangesRec infoMap rest newDescs - ] -constructRangesRec infoMap ((current,ParserInfo1 {}):rest) rangeDescs = - let symbolLoc = findSymbol1 current rangeDescs - subwords = calcSubwords1 infoMap symbolLoc - in trace ("calc subwords for dim1") $ - trace ("subwords: " ++ show subwords) $ - [ RangeMap [i,j] restRanges | - (i,j) <- subwords, - let newDescs = constructNewRangeDescs1 rangeDescs symbolLoc (i,j), - let restRanges = constructRangesRec infoMap rest newDescs - ] -constructRangesRec _ [] r@(_:_) = error ("programming error " ++ show r) - -findSymbol :: Int -> Int -> [RangeDesc] -> (RangeDesc,Int) -findSymbol s idx r | trace ("findSymbol " ++ show s ++ "," ++ show idx ++ " " ++ show r) False = undefined -findSymbol s idx rangeDesc = - let Just (i,j,r) = find (\(_,_,l') -> any (\(s',i') -> s' == s && i' == idx) l') rangeDesc - Just aIdx = elemIndex (s,idx) r - in ((i,j,r),aIdx) - -findSymbol1 :: Int -> [RangeDesc] -> (RangeDesc,Int) -findSymbol1 s = findSymbol s 1 - -findSymbol2 :: Int -> [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) -findSymbol2 s rangeDesc = (findSymbol s 1 rangeDesc, findSymbol s 2 rangeDesc) - --- TODO refactor (code duplication with Explicit module) - -constructNewRangeDescs1 :: [RangeDesc] -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] -constructNewRangeDescs1 d p s | trace ("constructNewRangeDescs " ++ show d ++ " " ++ show p ++ " " ++ show s) False = undefined -constructNewRangeDescs1 descs symbolPosition subword = - let newDescs = [ newDesc | - desc <- descs - , newDesc <- processRangeDesc1 desc symbolPosition subword - ] - count = foldr (\(_,_,l) r -> r + length l) 0 - in assert (count descs > count newDescs) $ - trace (show newDescs) $ - newDescs - -constructNewRangeDescs2 :: [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] -constructNewRangeDescs2 d p s | trace ("constructNewRangeDescs " ++ show d ++ " " ++ show p ++ " " ++ show s) False = undefined -constructNewRangeDescs2 descs symbolPositions subword = - let newDescs = [ newDesc | - desc <- descs - , newDesc <- processRangeDesc2 desc symbolPositions subword - ] - count = foldr (\(_,_,l) r -> r + length l) 0 - in assert (count descs > count newDescs) $ - trace (show newDescs) $ - newDescs - -processRangeDesc1 :: RangeDesc -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] -processRangeDesc1 a b c | trace ("processRangeDesc1 " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -processRangeDesc1 inp (desc,aIdx) (m,n) - | inp /= desc = [inp] - | otherwise = processRangeDescSingle desc aIdx (m,n) - -processRangeDesc2 :: RangeDesc -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] -processRangeDesc2 a b c | trace ("processRangeDesc2 " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -processRangeDesc2 inp ((left,a1Idx),(right,a2Idx)) (m,n,o,p) - | inp /= left && inp /= right = [inp] - | inp == left && inp == right = - -- at this point it doesn't matter what the actual ordering is - -- so we just swap if necessary to make it easier for processRangeDescDouble - let (a1Idx',a2Idx',m',n',o',p') = - if a1Idx < a2Idx then - (a1Idx,a2Idx,m,n,o,p) - else - (a2Idx,a1Idx,o,p,m,n) - in processRangeDescDouble inp a1Idx' a2Idx' (m',n',o',p') - | inp == left = processRangeDescSingle left a1Idx (m,n) - | inp == right = processRangeDescSingle right a2Idx (o,p) - -filterEmptyRanges :: [RangeDesc] -> [RangeDesc] -filterEmptyRanges l = - let f (i,j,d) = not $ null d && i == j - in filter f l - -processRangeDescSingle :: RangeDesc -> Int -> Subword1 -> [RangeDesc] -processRangeDescSingle a b c | trace ("processRangeDescSingle " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -processRangeDescSingle (i,j,r) aIdx (k,l) - | aIdx == 0 = filterEmptyRanges [(l,j,tail r)] - | aIdx == length r - 1 = [(i,k,init r)] - | otherwise = [(i,k,take aIdx r),(l,j,drop (aIdx + 1) r)] - --- assumes that a1Idx < a2Idx, see processRangeDesc -processRangeDescDouble :: RangeDesc -> Int -> Int -> Subword2 -> [RangeDesc] -processRangeDescDouble a b c d | trace ("processRangeDescDouble " ++ show a ++ " " ++ show b ++ " " ++ show c ++ " " ++ show d) False = undefined -processRangeDescDouble (i,j,r) a1Idx a2Idx (k,l,m,n) = - assert (a1Idx < a2Idx) result where - result | a1Idx == 0 && a2Idx == length r - 1 = filterEmptyRanges [(l,m,init (tail r))] - | a1Idx == 0 = filterEmptyRanges [(l,m,slice 1 (a2Idx-1) r),(n,j,drop (a2Idx+1) r)] - | a2Idx == length r - 1 = filterEmptyRanges [(i,k,take a1Idx r),(l,m,slice (a1Idx+1) (a2Idx-1) r)] - | otherwise = filterEmptyRanges [(i,k,take a1Idx r),(l,m,slice (a1Idx+1) (a2Idx-1) r),(n,j,drop (a2Idx+1) r)] - where slice from to xs = take (to - from + 1) (drop from xs) - - -infoFromPos :: InfoMap -> (RangeDesc,Int) -> Info -infoFromPos infoMap ((_,_,r),aIdx) = - -- TODO !! might be expensive as it's a list - infoMap Map.! (r !! aIdx) - --- calculates the combined yield size of all symbols left of the given one -combinedInfoLeftOf :: InfoMap -> (RangeDesc,Int) -> Info -combinedInfoLeftOf infoMap (desc,axIdx) - | axIdx == 0 = (0, Just 0) - | otherwise = - let leftInfos = map (\i -> infoFromPos infoMap (desc,i)) [0..axIdx-1] - in combineYields leftInfos - --- calculates the combined yield size of all symbols right of the given one -combinedInfoRightOf :: InfoMap -> (RangeDesc,Int) -> Info -combinedInfoRightOf infoMap (desc@(_,_,r),axIdx) - | axIdx == length r - 1 = (0, Just 0) - | otherwise = - let rightInfos = map (\i -> infoFromPos infoMap (desc,i)) [axIdx+1..length r - 1] - in combineYields rightInfos - - -calcSubwords2 :: InfoMap -> ((RangeDesc,Int),(RangeDesc,Int)) -> [Subword2] -calcSubwords2 a b | trace ("calcSubwords " ++ show a ++ " " ++ show b) False = undefined -calcSubwords2 infoMap (left@((i,j,r),a1Idx),right@((_,_,r'),a2Idx)) - | r == r' = calcSubwords2Dependent infoMap (i,j,r) a1Idx a2Idx - | otherwise = [ (i',j',k',l') | - (i',j') <- calcSubwords1 infoMap left - , (k',l') <- calcSubwords1 infoMap right - ] - --- assumes that other component is in a different part -calcSubwords1 :: InfoMap -> (RangeDesc,Int) -> [Subword1] -calcSubwords1 _ b | trace ("calcSubwordsIndependent " ++ show b) False = undefined -calcSubwords1 infoMap pos@((i,j,_),_) = - let (minY,maxY) = infoFromPos infoMap pos - (minYLeft,maxYLeft) = combinedInfoLeftOf infoMap pos - (minYRight,maxYRight) = combinedInfoRightOf infoMap pos - model :: FDModel - model = exists $ \col -> do - let rangeLen = fromIntegral (j-i) - [minY',minYLeft',minYRight'] = map fromIntegral [minY,minYLeft,minYRight] - [maxY',maxYLeft',maxYRight'] = map (maybe rangeLen fromIntegral) [maxY,maxYLeft,maxYRight] - -- TODO instead of using a safe default (rangeLen), it might be better not to - -- include a new inequality at all (how?) - [len1,len2,len3] <- colList col 3 - xsum col @= rangeLen - len1 @>= minYLeft' - len2 @>= minY' - len3 @>= minYRight' - len1 @<= maxYLeft' - len2 @<= maxY' - len3 @<= maxYRight' - rangeLen - maxYLeft' @<= len2 + len3 - rangeLen - maxYRight' @<= len1 + len2 - rangeLen - maxY' @<= len1 + len3 - return col - in map (\[len1,_,len3] -> (i+len1, j-len3)) $ solveModel model - - -calcSubwords2Dependent :: InfoMap -> RangeDesc -> Int -> Int -> [Subword2] -calcSubwords2Dependent _ b c d | trace ("calcSubwordsDependent " ++ show b ++ " " ++ show c ++ " " ++ show d) False = undefined -calcSubwords2Dependent infoMap desc a1Idx a2Idx = - let a1Idx' = if a1Idx < a2Idx then a1Idx else a2Idx - a2Idx' = if a1Idx < a2Idx then a2Idx else a1Idx - subs = doCalcSubwords2Dependent infoMap desc a1Idx' a2Idx' - in if a1Idx < a2Idx then subs - else [ (k,l,m,n) | (m,n,k,l) <- subs ] - -doCalcSubwords2Dependent :: InfoMap -> RangeDesc -> Int -> Int -> [Subword2] -doCalcSubwords2Dependent infoMap desc@(i,j,_) a1Idx a2Idx = - let (minY1,maxY1) = infoFromPos infoMap (desc,a1Idx) - (minY2,maxY2) = infoFromPos infoMap (desc,a2Idx) - (minYLeft1,maxYLeft1) = combinedInfoLeftOf infoMap (desc,a1Idx) - (minYRight1,maxYRight1) = combinedInfoRightOf infoMap (desc,a1Idx) - (minYRight2,maxYRight2) = combinedInfoRightOf infoMap (desc,a2Idx) - minYBetween = minYRight1 - minYRight2 - minY2 - maxYBetween | a1Idx + 1 == a2Idx = Just 0 - | isNothing maxYRight1 = Nothing - | otherwise = Just $ fromJust maxYRight1 - fromJust maxYRight2 - fromJust maxY2 - model :: FDModel - model = exists $ \col -> do - let rangeLen = fromIntegral (j-i) - [minYLeft1',minY1',minYBetween',minY2',minYRight2'] = - map fromIntegral [minYLeft1,minY1,minYBetween,minY2,minYRight2] - [maxYLeft1',maxY1',maxYBetween',maxY2',maxYRight2'] = - map (maybe rangeLen fromIntegral) [maxYLeft1,maxY1,maxYBetween,maxY2,maxYRight2] - - [lenLeft1,len1,lenBetween,len2,lenRight2] <- colList col 5 - xsum col @= rangeLen - lenLeft1 @>= minYLeft1' - len1 @>= minY1' - lenBetween @>= minYBetween' - len2 @>= minY2' - lenRight2 @>= minYRight2' - lenLeft1 @<= maxYLeft1' - len1 @<= maxY1' - lenBetween @<= maxYBetween' - len2 @<= maxY2' - lenRight2 @<= maxYRight2' - rangeLen - maxYLeft1' @<= len1 + lenBetween + len2 + lenRight2 - rangeLen - maxY1' @<= lenLeft1 + lenBetween + len2 + lenRight2 - rangeLen - maxYBetween' @<= lenLeft1 + len1 + len2 + lenRight2 - rangeLen - maxY2' @<= lenLeft1 + len1 + lenBetween + lenRight2 - rangeLen - maxYRight2' @<= lenLeft1 + len1 + lenBetween + len2 - return col - in map (\ [lenLeft1,len1,_,len2,lenRight2] -> - ( i + lenLeft1 - , i + lenLeft1 + len1 - , j - lenRight2 - len2 - , j - lenRight2 - ) - ) $ solveModel model
src/ADP/Multi/Rewriting/Explicit.hs view
@@ -1,347 +1,227 @@-{-# LANGUAGE FlexibleInstances #-} - -module ADP.Multi.Rewriting.Explicit ( - determineYieldSize1, - determineYieldSize2, - constructRanges1, - constructRanges2 -) where - -import Control.Exception -import Data.List (elemIndex, find) -import qualified Data.Map as Map -import Data.Maybe - - -import ADP.Debug -import ADP.Multi.Parser -import ADP.Multi.Rewriting -import ADP.Multi.Rewriting.YieldSize - -type Subword1 = (Int,Int) -type Subword2 = (Int,Int,Int,Int) - - -constructRanges1 :: RangeConstructionAlgorithm Dim1 -constructRanges1 _ _ b | trace ("constructRanges1 " ++ show b) False = undefined -constructRanges1 f infos [i,j] = - assert (i <= j) $ - let parserCount = length infos - elemInfo = buildInfoMap infos - rewritten = f (Map.keys elemInfo) - remainingSymbols = [parserCount,parserCount-1..1] `zip` infos - rangeDesc = [(i,j,rewritten)] - rangeDescFiltered = filterEmptyRanges rangeDesc - in trace ("f " ++ show (Map.keys elemInfo) ++ " = " ++ show rewritten) $ - assert (length rewritten == Map.size elemInfo && all (`elem` rewritten) (Map.keys elemInfo)) $ - if any (\(m,n,d) -> null d && m /= n) rangeDesc then [] - else constructRangesRec elemInfo remainingSymbols rangeDescFiltered - -constructRanges2 :: RangeConstructionAlgorithm Dim2 -constructRanges2 _ _ b | trace ("constructRanges2 " ++ show b) False = undefined -constructRanges2 f infos [i,j,k,l] = - assert (i <= j && j <= k && k <= l) $ - let parserCount = length infos - elemInfo = buildInfoMap infos - (left,right) = f (Map.keys elemInfo) - remainingSymbols = [parserCount,parserCount-1..1] `zip` infos - rangeDesc = [(i,j,left),(k,l,right)] - rangeDescFiltered = filterEmptyRanges rangeDesc - in trace ("f " ++ show (Map.keys elemInfo) ++ " = (" ++ show left ++ "," ++ show right ++ ")") $ - assert (length left + length right == Map.size elemInfo && all (`elem` (left ++ right)) (Map.keys elemInfo)) $ - if any (\(m,n,d) -> null d && m /= n) rangeDesc then [] - else constructRangesRec elemInfo remainingSymbols rangeDescFiltered - -determineYieldSize1 :: YieldAnalysisAlgorithm Dim1 -determineYieldSize1 _ infos | trace ("determineYieldSize1 " ++ show infos) False = undefined -determineYieldSize1 f infos = doDetermineYieldSize1 f infos - -determineYieldSize2 :: YieldAnalysisAlgorithm Dim2 -determineYieldSize2 _ infos | trace ("determineYieldSize2 " ++ show infos) False = undefined -determineYieldSize2 f infos = doDetermineYieldSize2 f infos - - - - -type RangeDesc = (Int,Int,[(Int,Int)]) - - -constructRangesRec :: InfoMap -> [(Int,ParserInfo)] -> [RangeDesc] -> [Ranges] -constructRangesRec a b c | trace ("constructRangesRec " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -constructRangesRec _ [] [] = [] -constructRangesRec infoMap ((current,ParserInfo2 {}):rest) rangeDescs = - let symbolLoc = findSymbol2 current rangeDescs - subwords = calcSubwords2 infoMap symbolLoc - in trace ("calc subwords for dim2") $ - trace ("subwords: " ++ show subwords) $ - [ RangeMap [i,j,k,l] restRanges | - (i,j,k,l) <- subwords, - let newDescs = constructNewRangeDescs2 rangeDescs symbolLoc (i,j,k,l), - let restRanges = constructRangesRec infoMap rest newDescs - ] -constructRangesRec infoMap ((current,ParserInfo1 {}):rest) rangeDescs = - let symbolLoc = findSymbol1 current rangeDescs - subwords = calcSubwords1 infoMap symbolLoc - in trace ("calc subwords for dim1") $ - trace ("subwords: " ++ show subwords) $ - [ RangeMap [i,j] restRanges | - (i,j) <- subwords, - let newDescs = constructNewRangeDescs1 rangeDescs symbolLoc (i,j), - let restRanges = constructRangesRec infoMap rest newDescs - ] -constructRangesRec _ [] r@(_:_) = error ("programming error " ++ show r) - -findSymbol :: Int -> Int -> [RangeDesc] -> (RangeDesc,Int) -findSymbol s idx r | trace ("findSymbol " ++ show s ++ "," ++ show idx ++ " " ++ show r) False = undefined -findSymbol s idx rangeDesc = - let Just (i,j,r) = find (\(_,_,l') -> any (\(s',i') -> s' == s && i' == idx) l') rangeDesc - Just aIdx = elemIndex (s,idx) r - in ((i,j,r),aIdx) - -findSymbol1 :: Int -> [RangeDesc] -> (RangeDesc,Int) -findSymbol1 s = findSymbol s 1 - -findSymbol2 :: Int -> [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) -findSymbol2 s rangeDesc = (findSymbol s 1 rangeDesc, findSymbol s 2 rangeDesc) - --- TODO refactor (code duplication with Explicit module) - -constructNewRangeDescs1 :: [RangeDesc] -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] -constructNewRangeDescs1 d p s | trace ("constructNewRangeDescs1 " ++ show d ++ " " ++ show p ++ " " ++ show s) False = undefined -constructNewRangeDescs1 descs symbolPosition subword = - let newDescs = [ newDesc | - desc <- descs - , newDesc <- processRangeDesc1 desc symbolPosition subword - ] - count = foldr (\(_,_,l) r -> r + length l) 0 - in assert (count descs > count newDescs) $ - trace (show newDescs) $ - newDescs - -constructNewRangeDescs2 :: [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] -constructNewRangeDescs2 d p s | trace ("constructNewRangeDescs2 " ++ show d ++ " " ++ show p ++ " " ++ show s) False = undefined -constructNewRangeDescs2 descs symbolPositions subword = - let newDescs = [ newDesc | - desc <- descs - , newDesc <- processRangeDesc2 desc symbolPositions subword - ] - count = foldr (\(_,_,l) r -> r + length l) 0 - in assert (count descs > count newDescs) $ - trace (show newDescs) $ - newDescs - -processRangeDesc1 :: RangeDesc -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] -processRangeDesc1 a b c | trace ("processRangeDesc1 " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -processRangeDesc1 inp (desc,aIdx) (m,n) - | inp /= desc = [inp] - | otherwise = processRangeDescSingle desc aIdx (m,n) - -processRangeDesc2 :: RangeDesc -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] -processRangeDesc2 a b c | trace ("processRangeDesc2 " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -processRangeDesc2 inp ((left,a1Idx),(right,a2Idx)) (m,n,o,p) - | inp /= left && inp /= right = [inp] - | inp == left && inp == right = - -- at this point it doesn't matter what the actual ordering is - -- so we just swap if necessary to make it easier for processRangeDescDouble - let (a1Idx',a2Idx',m',n',o',p') = - if a1Idx < a2Idx then - (a1Idx,a2Idx,m,n,o,p) - else - (a2Idx,a1Idx,o,p,m,n) - in processRangeDescDouble inp a1Idx' a2Idx' (m',n',o',p') - | inp == left = processRangeDescSingle left a1Idx (m,n) - | inp == right = processRangeDescSingle right a2Idx (o,p) - -filterEmptyRanges :: [RangeDesc] -> [RangeDesc] -filterEmptyRanges l = - let f (i,j,d) = not $ null d && i == j - in filter f l - -processRangeDescSingle :: RangeDesc -> Int -> Subword1 -> [RangeDesc] -processRangeDescSingle a b c | trace ("processRangeDescSingle " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -processRangeDescSingle (i,j,r) aIdx (k,l) - | aIdx == 0 = filterEmptyRanges [(l,j,tail r)] - | aIdx == length r - 1 = [(i,k,init r)] - | otherwise = [(i,k,take aIdx r),(l,j,drop (aIdx + 1) r)] - --- assumes that a1Idx < a2Idx, see processRangeDesc -processRangeDescDouble :: RangeDesc -> Int -> Int -> Subword2 -> [RangeDesc] -processRangeDescDouble a b c d | trace ("processRangeDescDouble " ++ show a ++ " " ++ show b ++ " " ++ show c ++ " " ++ show d) False = undefined -processRangeDescDouble (i,j,r) a1Idx a2Idx (k,l,m,n) = - assert (a1Idx < a2Idx) result where - result | a1Idx == 0 && a2Idx == length r - 1 = filterEmptyRanges [(l,m,init (tail r))] - | a1Idx == 0 = filterEmptyRanges [(l,m,slice 1 (a2Idx-1) r),(n,j,drop (a2Idx+1) r)] - | a2Idx == length r - 1 = filterEmptyRanges [(i,k,take a1Idx r),(l,m,slice (a1Idx+1) (a2Idx-1) r)] - | otherwise = filterEmptyRanges [(i,k,take a1Idx r),(l,m,slice (a1Idx+1) (a2Idx-1) r),(n,j,drop (a2Idx+1) r)] - where slice from to xs = take (to - from + 1) (drop from xs) - - -infoFromPos :: InfoMap -> (RangeDesc,Int) -> Info -infoFromPos infoMap ((_,_,r),aIdx) = - -- TODO !! might be expensive as it's a list - infoMap Map.! (r !! aIdx) - --- calculates the combined yield size of all symbols left of the given one -combinedInfoLeftOf :: InfoMap -> (RangeDesc,Int) -> Info -combinedInfoLeftOf infoMap (desc,axIdx) - | axIdx == 0 = (0, Just 0) - | otherwise = - let leftInfos = map (\i -> infoFromPos infoMap (desc,i)) [0..axIdx-1] - in combineYields leftInfos - --- calculates the combined yield size of all symbols right of the given one -combinedInfoRightOf :: InfoMap -> (RangeDesc,Int) -> Info -combinedInfoRightOf infoMap (desc@(_,_,r),axIdx) - | axIdx == length r - 1 = (0, Just 0) - | otherwise = - let rightInfos = map (\i -> infoFromPos infoMap (desc,i)) [axIdx+1..length r - 1] - in combineYields rightInfos - --- Subword construction doesn't yet take the maximum yield sizes into account. --- This will further decrease the number of generated subwords and thus increase performance. -calcSubwords2 :: InfoMap -> ((RangeDesc,Int),(RangeDesc,Int)) -> [Subword2] -calcSubwords2 a b | trace ("calcSubwords2 " ++ show a ++ " " ++ show b) False = undefined -calcSubwords2 infoMap (left@((i,j,r),a1Idx),right@((m,n,r'),a2Idx)) - | r == r' = calcSubwords2Dependent infoMap (i,j,r) a1Idx a2Idx - | length r == 1 && length r' == 1 = [(i,j,m,n)] - | length r == 1 = [ (i',j',k',l') | - let (i',j') = (i,j) - , (k',l') <- calcSubwords1 infoMap right - ] - | length r' == 1 = [ (i',j',k',l') | - let (k',l') = (m,n) - , (i',j') <- calcSubwords1 infoMap left - ] - | otherwise = [ (i',j',k',l') | - (i',j') <- calcSubwords1 infoMap left - , (k',l') <- calcSubwords1 infoMap right - ] - --- assumes that other component is in a different part -calcSubwords1 :: InfoMap -> (RangeDesc,Int) -> [Subword1] -calcSubwords1 _ b | trace ("calcSubwords1 " ++ show b) False = undefined -calcSubwords1 infoMap pos@((i,j,r),axIdx) - | axIdx == 0 = - [ (k,l) | - Just (minY',minYRight') <- [adjustMinYield (i,j) (minY,minYRight) (maxY,maxYRight)] - , let k = i - , l <- [i+minY'..j-minYRight'] - ] - | axIdx == length r - 1 = - [ (k,l) | - Just (minYLeft',minY') <- [adjustMinYield (i,j) (minYLeft,minY) (maxYLeft,maxY)] - , let l = j - , k <- [i+minYLeft'..j-minY'] - ] - | otherwise = - [ (k,l) | - k <- [i+minYLeft..j-minY] - , l <- [k+minY..j-minYRight] - ] - where (minY,maxY) = infoFromPos infoMap pos - (minYLeft,maxYLeft) = combinedInfoLeftOf infoMap pos - (minYRight,maxYRight) = combinedInfoRightOf infoMap pos - -adjustMinYield :: Subword1 -> (Int,Int) -> (Maybe Int,Maybe Int) -> Maybe (Int,Int) -adjustMinYield (i,j) (minl,minr) (maxl,maxr) = - let len = j-i - adjust oldMinY maxY = let x = maybe oldMinY (\m -> len - m) maxY - in if x > oldMinY then x else oldMinY - minrAdj = adjust minr maxl - minlAdj = adjust minl maxr - in do - minlRes <- maybe (Just minlAdj) (\m -> if minlAdj > m then Nothing else Just minlAdj) maxl - minrRes <- maybe (Just minrAdj) (\m -> if minrAdj > m then Nothing else Just minrAdj) maxr - Just (minlRes,minrRes) - --- assumes that other component is in the same part -calcSubwords2Dependent :: InfoMap -> RangeDesc -> Int -> Int -> [Subword2] -calcSubwords2Dependent _ b c d | trace ("calcSubwords2Dependent " ++ show b ++ " " ++ show c ++ " " ++ show d) False = undefined -calcSubwords2Dependent infoMap (i,j,r) a1Idx a2Idx = - let a1Idx' = if a1Idx < a2Idx then a1Idx else a2Idx - a2Idx' = if a1Idx < a2Idx then a2Idx else a1Idx - subs = doCalcSubwords2Dependent infoMap (i,j,r) a1Idx' a2Idx' - in if a1Idx < a2Idx then subs - else [ (k,l,m,n) | (m,n,k,l) <- subs ] - -doCalcSubwords2Dependent :: InfoMap -> RangeDesc -> Int -> Int -> [Subword2] -doCalcSubwords2Dependent infoMap desc@(i,j,r) a1Idx a2Idx = - assert (a1Idx < a2Idx) $ - trace ("min yields: " ++ show minY1 ++ " " ++ show minY2 ++ " " ++ show minYLeft1 ++ " " ++ - show minYLeft2 ++ " " ++ show minYRight1 ++ " " ++ show minYRight2 ++ " " ++ show minYBetween) $ - trace ("max yields: " ++ show maxY1 ++ " " ++ show maxY2 ++ " " ++ show maxYLeft1 ++ " " ++ - show maxYLeft2 ++ " " ++ show maxYRight1 ++ " " ++ show maxYRight2 ++ " " ++ show maxYBetween) $ - result where - - (minY1,maxY1) = infoFromPos infoMap (desc,a1Idx) - (minY2,maxY2) = infoFromPos infoMap (desc,a2Idx) - (minYLeft1,maxYLeft1) = combinedInfoLeftOf infoMap (desc,a1Idx) - (minYLeft2,maxYLeft2) = combinedInfoLeftOf infoMap (desc,a2Idx) - (minYRight1,maxYRight1) = combinedInfoRightOf infoMap (desc,a1Idx) - (minYRight2,maxYRight2) = combinedInfoRightOf infoMap (desc,a2Idx) - minYBetween = minYRight1 - minYRight2 - minY2 - maxYBetween = if isNothing maxYRight1 - then Nothing - else Just $ fromJust maxYRight1 - fromJust maxYRight2 - fromJust maxY2 - - neighbors = a1Idx + 1 == a2Idx - - result | a1Idx == 0 && a2Idx == length r - 1 && neighbors = - [ (k,l,l,n) | - let (k,n) = (i,j) - , l <- [i+minY1..j-minY2] - ] - - | a1Idx == 0 && a2Idx == length r - 1 = - [ (k,l,m,n) | - let (k,n) = (i,j) - , l <- [i+minY1..j-minYRight1] - , m <- [l+minYBetween..j-minY2] - ] - - | a1Idx == 0 && neighbors = - [ (k,l,l,n) | - let k = i - , l <- [i+minY1..j-minYRight1] - , n <- [l+minY2..j-minYRight2] - ] - - | a1Idx == 0 = - [ (k,l,m,n) | - let k = i - , l <- [i+minY1..j-minYRight1] - , m <- [l+minYBetween..j-minY2-minYRight2] - , n <- [m+minY2..j-minYRight2] - ] - - | a2Idx == length r - 1 && neighbors = - [ (k,m,m,n) | - let n = j - , m <- [i+minYLeft2..j-minY2] - , k <- [i+minYLeft1..m-minY1] - ] - - | a2Idx == length r - 1 = - [ (k,l,m,n) | - let n = j - , m <- [i+minYLeft2..j-minY2] - , l <- [i+minY1+minYLeft1..m-minYBetween] - , k <- [i+minYLeft1..l-minY1] - ] - - | a1Idx > 0 && a2Idx < length r - 1 && neighbors = - [ (k,l,l,n) | - k <- [i+minYLeft1..j-minY1-minYRight1] - , l <- [k+minY1..j-minYRight1] - , n <- [l+minY2..j-minYRight2] - ] - - | a1Idx > 0 && a2Idx < length r - 1 = - [ (k,l,m,n) | - k <- [i+minYLeft1..j-minY1-minYRight1] - , l <- [k+minY1..j-minYRight1] - , m <- [l+minYBetween..j-minY2-minYRight2] - , n <- [m+minY2..j-minYRight2] - ] - - | otherwise = error "invalid conditions, e.g. a1Idx == a2Idx == 0" +{-# LANGUAGE FlexibleInstances #-}++module ADP.Multi.Rewriting.Explicit (+ constructSubwords1,+ constructSubwords2+) where++import Control.Exception+import qualified Data.Map as Map+import Data.Maybe++import ADP.Debug+import ADP.Multi.Parser+import ADP.Multi.Rewriting+import ADP.Multi.Rewriting.Model+import ADP.Multi.Rewriting.YieldSize+import ADP.Multi.Rewriting.RangesHelper++constructSubwords1 :: SubwordConstructionAlgorithm Dim1+constructSubwords1 _ _ b | trace ("constructSubwords1 " ++ show b) False = undefined+constructSubwords1 f infos [i,j] =+ assert (i <= j) $+ let yieldSizeMap = buildYieldSizeMap infos+ symbolIDs = Map.keys yieldSizeMap+ rewritten = f symbolIDs+ parserCount = length infos+ remainingParsers = [parserCount,parserCount-1..1] `zip` infos+ rangeDesc = [(i,j,rewritten)]+ rangeDescFiltered = filterEmptyRanges rangeDesc+ in trace ("f " ++ show symbolIDs ++ " = " ++ show rewritten) $+ assert (length rewritten == Map.size yieldSizeMap && all (`elem` rewritten) symbolIDs) $+ if any (\(m,n,d) -> null d && m /= n) rangeDesc then []+ else constructSubwordsRec yieldSizeMap remainingParsers rangeDescFiltered++constructSubwords2 :: SubwordConstructionAlgorithm Dim2+constructSubwords2 _ _ b | trace ("constructSubwords2 " ++ show b) False = undefined+constructSubwords2 f infos [i,j,k,l] =+ assert (i <= j && j <= k && k <= l) $+ let yieldSizeMap = buildYieldSizeMap infos+ symbolIDs = Map.keys yieldSizeMap+ (left,right) = f symbolIDs+ parserCount = length infos+ remainingParsers = [parserCount,parserCount-1..1] `zip` infos+ rangeDesc = [(i,j,left),(k,l,right)]+ rangeDescFiltered = filterEmptyRanges rangeDesc+ in trace ("f " ++ show symbolIDs ++ " = (" ++ show left ++ "," ++ show right ++ ")") $+ assert (length left + length right == Map.size yieldSizeMap && all (`elem` (left ++ right)) symbolIDs) $+ if any (\(m,n,d) -> null d && m /= n) rangeDesc then []+ else constructSubwordsRec yieldSizeMap remainingParsers rangeDescFiltered++++constructSubwordsRec :: YieldSizeMap -> [(Int,ParserInfo)] -> [RangeDesc] -> [SubwordTree]+constructSubwordsRec a b c | trace ("constructRangesRec " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined+constructSubwordsRec _ [] [] = []+constructSubwordsRec yieldSizeMap ((current,ParserInfo1 {}):rest) rangeDescs =+ let symbolLoc = findSymbol1 current rangeDescs+ subwords = calcSubwords1 yieldSizeMap symbolLoc+ in trace ("calc subwords for dim1") $+ trace ("subwords: " ++ show subwords) $+ [ SubwordTree [i,j] restTrees |+ (i,j) <- subwords,+ let newDescs = constructNewRangeDescs1 rangeDescs symbolLoc (i,j),+ let restTrees = constructSubwordsRec yieldSizeMap rest newDescs+ ]+constructSubwordsRec yieldSizeMap ((current,ParserInfo2 {}):rest) rangeDescs =+ let symbolLocs = findSymbol2 current rangeDescs+ subwords = calcSubwords2 yieldSizeMap symbolLocs+ in trace ("calc subwords for dim2") $+ trace ("subwords: " ++ show subwords) $+ [ SubwordTree [i,j,k,l] restTrees |+ (i,j,k,l) <- subwords,+ let newDescs = constructNewRangeDescs2 rangeDescs symbolLocs (i,j,k,l),+ let restTrees = constructSubwordsRec yieldSizeMap rest newDescs+ ]+constructSubwordsRec _ [] r@(_:_) = error ("programming error " ++ show r)++++-- Subword construction doesn't yet take the maximum yield sizes into account.+-- This will further decrease the number of generated subwords and thus increase performance.+calcSubwords2 :: YieldSizeMap -> ((RangeDesc,Int),(RangeDesc,Int)) -> [Subword2]+calcSubwords2 a b | trace ("calcSubwords2 " ++ show a ++ " " ++ show b) False = undefined+calcSubwords2 yieldSizeMap (left@((i,j,r),a1Idx),right@((m,n,r'),a2Idx))+ | r == r' = calcSubwords2Dependent yieldSizeMap (i,j,r) a1Idx a2Idx+ | length r == 1 && length r' == 1 = [(i,j,m,n)]+ | length r == 1 = [ (i',j',k',l') |+ let (i',j') = (i,j)+ , (k',l') <- calcSubwords1 yieldSizeMap right+ ]+ | length r' == 1 = [ (i',j',k',l') |+ let (k',l') = (m,n)+ , (i',j') <- calcSubwords1 yieldSizeMap left+ ]+ | otherwise = [ (i',j',k',l') |+ (i',j') <- calcSubwords1 yieldSizeMap left+ , (k',l') <- calcSubwords1 yieldSizeMap right+ ]++-- assumes that other component is in a different part+calcSubwords1 :: YieldSizeMap -> (RangeDesc,Int) -> [Subword1]+calcSubwords1 _ b | trace ("calcSubwords1 " ++ show b) False = undefined+calcSubwords1 yieldSizeMap pos@((i,j,r),axIdx)+ | axIdx == 0 =+ [ (k,l) |+ Just (minY',minYRight') <- [adjustMinYield (i,j) (minY,maxY) (minYRight,maxYRight)]+ , let k = i+ , l <- [i+minY'..j-minYRight']+ ]+ | axIdx == length r - 1 =+ [ (k,l) |+ Just (minYLeft',minY') <- [adjustMinYield (i,j) (minYLeft,maxYLeft) (minY,maxY)]+ , let l = j+ , k <- [i+minYLeft'..j-minY']+ ]+ | otherwise =+ [ (k,l) |+ k <- [i+minYLeft..j-minY]+ , l <- [k+minY..j-minYRight]+ ]+ where (minY,maxY) = yieldSizeOf yieldSizeMap pos+ (minYLeft,maxYLeft) = combinedYieldSizeLeftOf yieldSizeMap pos+ (minYRight,maxYRight) = combinedYieldSizeRightOf yieldSizeMap pos++adjustMinYield :: Subword1 -> YieldSize -> YieldSize -> Maybe (Int,Int)+adjustMinYield (i,j) (minl,maxl) (minr,maxr) =+ let len = j-i+ adjust oldMinY maxY = let x = maybe oldMinY (\m -> len - m) maxY+ in if x > oldMinY then x else oldMinY+ minrAdj = adjust minr maxl+ minlAdj = adjust minl maxr+ in do+ minlRes <- maybe (Just minlAdj) (\m -> if minlAdj > m then Nothing else Just minlAdj) maxl+ minrRes <- maybe (Just minrAdj) (\m -> if minrAdj > m then Nothing else Just minrAdj) maxr+ Just (minlRes,minrRes)++-- assumes that other component is in the same part+calcSubwords2Dependent :: YieldSizeMap -> RangeDesc -> Int -> Int -> [Subword2]+calcSubwords2Dependent _ b c d | trace ("calcSubwords2Dependent " ++ show b ++ " " ++ show c ++ " " ++ show d) False = undefined+calcSubwords2Dependent yieldSizeMap (i,j,r) a1Idx a2Idx =+ let a1Idx' = if a1Idx < a2Idx then a1Idx else a2Idx+ a2Idx' = if a1Idx < a2Idx then a2Idx else a1Idx+ subs = doCalcSubwords2Dependent yieldSizeMap (i,j,r) a1Idx' a2Idx'+ in if a1Idx < a2Idx then subs+ else [ (k,l,m,n) | (m,n,k,l) <- subs ]++doCalcSubwords2Dependent :: YieldSizeMap -> RangeDesc -> Int -> Int -> [Subword2]+doCalcSubwords2Dependent yieldSizeMap desc@(i,j,r) a1Idx a2Idx =+ assert (a1Idx < a2Idx) $+ trace ("min yields: " ++ show minY1 ++ " " ++ show minY2 ++ " " ++ show minYLeft1 ++ " " +++ show minYLeft2 ++ " " ++ show minYRight1 ++ " " ++ show minYRight2 ++ " " ++ show minYBetween) $+ trace ("max yields: " ++ show maxY1 ++ " " ++ show maxY2 ++ " " ++ show maxYLeft1 ++ " " +++ show maxYLeft2 ++ " " ++ show maxYRight1 ++ " " ++ show maxYRight2 ++ " " ++ show maxYBetween) $+ result where++ (minY1,maxY1) = yieldSizeOf yieldSizeMap (desc,a1Idx)+ (minY2,maxY2) = yieldSizeOf yieldSizeMap (desc,a2Idx)+ (minYLeft1,maxYLeft1) = combinedYieldSizeLeftOf yieldSizeMap (desc,a1Idx)+ (minYLeft2,maxYLeft2) = combinedYieldSizeLeftOf yieldSizeMap (desc,a2Idx)+ (minYRight1,maxYRight1) = combinedYieldSizeRightOf yieldSizeMap (desc,a1Idx)+ (minYRight2,maxYRight2) = combinedYieldSizeRightOf yieldSizeMap (desc,a2Idx)+ minYBetween = minYRight1 - minYRight2 - minY2+ maxYBetween = if isNothing maxYRight1+ then Nothing+ else Just $ fromJust maxYRight1 - fromJust maxYRight2 - fromJust maxY2++ neighbors = a1Idx + 1 == a2Idx++ result | a1Idx == 0 && a2Idx == length r - 1 && neighbors =+ [ (k,l,l,n) |+ let (k,n) = (i,j)+ , l <- [i+minY1..j-minY2]+ ]++ | a1Idx == 0 && a2Idx == length r - 1 =+ [ (k,l,m,n) |+ let (k,n) = (i,j)+ , l <- [i+minY1..j-minYRight1]+ , m <- [l+minYBetween..j-minY2]+ ]++ | a1Idx == 0 && neighbors =+ [ (k,l,l,n) |+ let k = i+ , l <- [i+minY1..j-minYRight1]+ , n <- [l+minY2..j-minYRight2]+ ]++ | a1Idx == 0 =+ [ (k,l,m,n) |+ let k = i+ , l <- [i+minY1..j-minYRight1]+ , m <- [l+minYBetween..j-minY2-minYRight2]+ , n <- [m+minY2..j-minYRight2]+ ]++ | a2Idx == length r - 1 && neighbors =+ [ (k,m,m,n) |+ let n = j+ , m <- [i+minYLeft2..j-minY2]+ , k <- [i+minYLeft1..m-minY1]+ ]++ | a2Idx == length r - 1 =+ [ (k,l,m,n) |+ let n = j+ , m <- [i+minYLeft2..j-minY2]+ , l <- [i+minY1+minYLeft1..m-minYBetween]+ , k <- [i+minYLeft1..l-minY1]+ ]++ | a1Idx > 0 && a2Idx < length r - 1 && neighbors =+ [ (k,l,l,n) |+ k <- [i+minYLeft1..j-minY1-minYRight1]+ , l <- [k+minY1..j-minYRight1]+ , n <- [l+minY2..j-minYRight2]+ ]++ | a1Idx > 0 && a2Idx < length r - 1 =+ [ (k,l,m,n) |+ k <- [i+minYLeft1..j-minY1-minYRight1]+ , l <- [k+minY1..j-minYRight1]+ , m <- [l+minYBetween..j-minY2-minYRight2]+ , n <- [m+minY2..j-minYRight2]+ ]++ | otherwise = error "invalid conditions, e.g. a1Idx == a2Idx == 0"
+ src/ADP/Multi/Rewriting/Model.hs view
@@ -0,0 +1,38 @@+-- | Default model of rewriting functions used in adp-multi. +module ADP.Multi.Rewriting.Model where + +{- | +Every 1-dim parser has one symbol, every 2-dim parser two symbols. +In a production with parsers p1 to pn, each parser has a number, +1 to n. Each symbol of a parser also has a number, 1 or 2, as only +two dimensions are supported now. Both numbers form a unique identifier +for each symbol in a production. + +Example: +f <<< a ~~~ b ~~~ c >>> r + +a and c shall have dimension 1, b dimension 2. +Then a has id (1,1), b has ids (2,1) and (2,2), and +c has (3,1). Applying a rewriting function of type 'Dim1' or 'Dim2' +to the list of ids produces a permutation of those, possibly +split up in two dimensions. + +E.g., [(1,1),(2,1),(2,2),(3,1)] gets ([(2,1),(3,1)],[(2,2),(1,1)]) +if the rewriting function is: r [a,b1,b2,c] = ([b1,c],[b2,a]). +-} +type SymbolID = (Int, Int) + +-- | 1-dimensional rewriting function +type Dim1 = [SymbolID] -> [SymbolID] + +-- | 2-dimensional rewriting function +type Dim2 = [SymbolID] -> ([SymbolID], [SymbolID]) + +-- | Convenience rewriting function for one or more dim1 symbols +id1 :: Dim1 +id1 = id + +-- | Convenience rewriting function for one dim2 symbol +id2 :: Dim2 +id2 [c1,c2] = ([c1],[c2]) +id2 _ = error "Only use id2 for single symbols! Write your own rewrite function instead."
− src/ADP/Multi/Rewriting/MonadicCpHelper.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -module ADP.Multi.Rewriting.MonadicCpHelper ( - FDModel - , solveModel -) 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 - -import ADP.Debug - -type FDModel = - forall s m. (Show (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s) - => m ModelCol - -solveModel :: Tree (FDInstance OvertonFD) ModelCol -> [[Int]] -solveModel f = - let (visitedNodes, result) = solve dfs it $ f >>= labeller - in trace ("FD model solved, nodes visited: " ++ show visitedNodes) result - -labeller :: forall s m. - (Show (FDIntTerm s), EnumTerm s (FDIntTerm s), FDSolver s, MonadTree m, TreeSolver m ~ FDInstance s) - => ModelCol -> m [TermBaseType s (FDIntTerm s)] -labeller col = - label $ do - minVar <- getMinimizeVar - case minVar of - Nothing -> return $ labelCol col - Just v -> return $ do - enumerate [v] - labelCol col
+ src/ADP/Multi/Rewriting/RangesHelper.hs view
@@ -0,0 +1,130 @@+{-# OPTIONS_HADDOCK hide #-} + +-- | Helper methods used for subword construction. +module ADP.Multi.Rewriting.RangesHelper where + +import Control.Exception +import Data.List (elemIndex, find) +import qualified Data.Map as Map + +import ADP.Debug +import ADP.Multi.Rewriting.Model +import ADP.Multi.Rewriting.YieldSize + +-- an attempt to regain some type safety +type Subword1 = (Int,Int) +type Subword2 = (Int,Int,Int,Int) + +-- | List of parser symbols and a start and end index over +-- which subwords shall be constructed. +-- Note: RangeDesc means Range Description. I don't like +-- that name very much, but haven't found a good alternative. +type RangeDesc = (Int,Int,[SymbolID]) + +-- | Searches for the given SymbolID in a list of RangeDesc's +-- and returns its index in the RangeDesc where it was found. +findSymbol :: SymbolID -> [RangeDesc] -> (RangeDesc,Int) +findSymbol (s,idx) r | trace ("findSymbol " ++ show s ++ "," ++ show idx ++ " " ++ show r) False = undefined +findSymbol (s,idx) rangeDesc = + let Just (i,j,r) = find (\(_,_,l') -> any (\(s',i') -> s' == s && i' == idx) l') rangeDesc + Just aIdx = elemIndex (s,idx) r + in ((i,j,r),aIdx) + +findSymbol1 :: Int -> [RangeDesc] -> (RangeDesc,Int) +findSymbol1 s = findSymbol (s,1) + +findSymbol2 :: Int -> [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) +findSymbol2 s rangeDesc = (findSymbol (s,1) rangeDesc, findSymbol (s,2) rangeDesc) + +constructNewRangeDescs1 :: [RangeDesc] -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] +constructNewRangeDescs1 d p s | trace ("constructNewRangeDescs1 " ++ show d ++ " " ++ show p ++ " " ++ show s) False = undefined +constructNewRangeDescs1 descs symbolPosition subword = + let newDescs = [ newDesc | + desc <- descs + , newDesc <- processRangeDesc1 desc symbolPosition subword + ] + count = foldr (\(_,_,l) r -> r + length l) 0 + in assert (count descs > count newDescs) $ + trace (show newDescs) $ + newDescs + +constructNewRangeDescs2 :: [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] +constructNewRangeDescs2 d p s | trace ("constructNewRangeDescs2 " ++ show d ++ " " ++ show p ++ " " ++ show s) False = undefined +constructNewRangeDescs2 descs symbolPositions subword = + let newDescs = [ newDesc | + desc <- descs + , newDesc <- processRangeDesc2 desc symbolPositions subword + ] + count = foldr (\(_,_,l) r -> r + length l) 0 + in assert (count descs > count newDescs) $ + trace (show newDescs) $ + newDescs + +processRangeDesc1 :: RangeDesc -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] +processRangeDesc1 a b c | trace ("processRangeDesc1 " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined +processRangeDesc1 inp (desc,aIdx) (m,n) + | inp /= desc = [inp] + | otherwise = processRangeDescSingle desc aIdx (m,n) + +processRangeDesc2 :: RangeDesc -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] +processRangeDesc2 a b c | trace ("processRangeDesc2 " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined +processRangeDesc2 inp ((left,a1Idx),(right,a2Idx)) (m,n,o,p) + | inp /= left && inp /= right = [inp] + | inp == left && inp == right = + -- at this point it doesn't matter what the actual ordering is + -- so we just swap if necessary to make it easier for processRangeDescDouble + let (a1Idx',a2Idx',m',n',o',p') = + if a1Idx < a2Idx then + (a1Idx,a2Idx,m,n,o,p) + else + (a2Idx,a1Idx,o,p,m,n) + in processRangeDescDouble inp a1Idx' a2Idx' (m',n',o',p') + | inp == left = processRangeDescSingle left a1Idx (m,n) + | inp == right = processRangeDescSingle right a2Idx (o,p) + +filterEmptyRanges :: [RangeDesc] -> [RangeDesc] +filterEmptyRanges l = + let f (i,j,d) = not $ null d && i == j + in filter f l + +processRangeDescSingle :: RangeDesc -> Int -> Subword1 -> [RangeDesc] +processRangeDescSingle a b c | trace ("processRangeDescSingle " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined +processRangeDescSingle (i,j,r) aIdx (k,l) + | aIdx == 0 = filterEmptyRanges [(l,j,tail r)] + | aIdx == length r - 1 = [(i,k,init r)] + | otherwise = [(i,k,take aIdx r),(l,j,drop (aIdx + 1) r)] + +-- assumes that a1Idx < a2Idx, see processRangeDesc +processRangeDescDouble :: RangeDesc -> Int -> Int -> Subword2 -> [RangeDesc] +processRangeDescDouble a b c d | trace ("processRangeDescDouble " ++ show a ++ " " ++ show b ++ " " ++ show c ++ " " ++ show d) False = undefined +processRangeDescDouble (i,j,r) a1Idx a2Idx (k,l,m,n) = + assert (a1Idx < a2Idx) result where + result | a1Idx == 0 && a2Idx == length r - 1 = filterEmptyRanges [(l,m,init (tail r))] + | a1Idx == 0 = filterEmptyRanges [(l,m,slice 1 (a2Idx-1) r),(n,j,drop (a2Idx+1) r)] + | a2Idx == length r - 1 = filterEmptyRanges [(i,k,take a1Idx r),(l,m,slice (a1Idx+1) (a2Idx-1) r)] + | otherwise = filterEmptyRanges [(i,k,take a1Idx r),(l,m,slice (a1Idx+1) (a2Idx-1) r),(n,j,drop (a2Idx+1) r)] + where slice from to xs = take (to - from + 1) (drop from xs) + + +-- | Returns the yield size of the symbol at the given index in +-- the given RangeDesc. +yieldSizeOf :: YieldSizeMap -> (RangeDesc,Int) -> YieldSize +yieldSizeOf yieldSizeMap ((_,_,r),aIdx) = + -- TODO !! might be expensive as it's a list + yieldSizeMap Map.! (r !! aIdx) + +-- | calculates the combined yield size of all symbols left of the given one +combinedYieldSizeLeftOf :: YieldSizeMap -> (RangeDesc,Int) -> YieldSize +combinedYieldSizeLeftOf yieldSizeMap (desc,axIdx) + | axIdx == 0 = (0, Just 0) + | otherwise = + let leftYieldSizes = map (\i -> yieldSizeOf yieldSizeMap (desc,i)) [0..axIdx-1] + in combineYields leftYieldSizes + +-- | calculates the combined yield size of all symbols right of the given one +combinedYieldSizeRightOf :: YieldSizeMap -> (RangeDesc,Int) -> YieldSize +combinedYieldSizeRightOf yieldSizeMap (desc@(_,_,r),axIdx) + | axIdx == length r - 1 = (0, Just 0) + | otherwise = + let rightYieldSizes = map (\i -> yieldSizeOf yieldSizeMap (desc,i)) [axIdx+1..length r - 1] + in combineYields rightYieldSizes
src/ADP/Multi/Rewriting/YieldSize.hs view
@@ -1,70 +1,62 @@-module ADP.Multi.Rewriting.YieldSize where - -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map - -import ADP.Debug -import ADP.Multi.Parser -import ADP.Multi.Rewriting - -{- -This module might later be re-integrated into both Rewriting implementations. -It is unclear yet if generically determining the yield size for higher parser -dimensions also needs a constraint solver. --} - --- for dim1 we don't need the rewriting function to determine the yield size --- it's kept as argument anyway to make it more consistent -doDetermineYieldSize1 :: YieldAnalysisAlgorithm Dim1 -doDetermineYieldSize1 _ infos = - let elemInfo = buildInfoMap infos - (yieldMin,yieldMax) = combineYields (Map.elems elemInfo) - in trace (show elemInfo) $ - ParserInfo1 { - minYield = yieldMin, - maxYield = yieldMax - } - -doDetermineYieldSize2 :: YieldAnalysisAlgorithm Dim2 -doDetermineYieldSize2 f infos = - let elemInfo = buildInfoMap infos - (left,right) = f (Map.keys elemInfo) - leftYields = map (\(i,j) -> elemInfo Map.! (i,j)) left - rightYields = map (\(i,j) -> elemInfo Map.! (i,j)) right - (leftMin,leftMax) = combineYields leftYields - (rightMin,rightMax) = combineYields rightYields - in trace (show elemInfo) $ - trace (show left) $ - trace (show right) $ - ParserInfo2 { - minYield2 = (leftMin,rightMin), - maxYield2 = (leftMax,rightMax) - } - -combineYields :: [Info] -> Info -combineYields = foldl (\(minY1,maxY1) (minY2,maxY2) -> - ( minY1+minY2 - , if isNothing maxY1 || isNothing maxY2 - then Nothing - else Just $ fromJust maxY1 + fromJust maxY2 - ) ) (0,Just 0) - -type YieldSizes = (Int,Maybe Int) -- min and max yield sizes -type Info = YieldSizes -- could later be extended with more static analysis data -type InfoMap = Map (Int,Int) Info - --- the input list is in reverse order, i.e. the first in the list is the last applied parser -buildInfoMap :: [ParserInfo] -> InfoMap -buildInfoMap i | trace ("buildInfoMap " ++ show i) False = undefined -buildInfoMap infos = - let parserCount = length infos - list = concatMap (\ (x,info) -> case info of - ParserInfo1 { minYield = minY, maxYield = maxY } -> - [ ((x,1), (minY, maxY) ) ] - ParserInfo2 { minYield2 = minY, maxYield2 = maxY } -> - [ ((x,1), (fst minY, fst maxY) ) - , ((x,2), (snd minY, snd maxY) ) - ] - ) $ zip [parserCount,parserCount-1..] infos +-- | Calculates yield sizes using rewriting functions. +module ADP.Multi.Rewriting.YieldSize where++import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad (liftM2)++import ADP.Multi.Parser+import ADP.Multi.Rewriting.Model++type YieldAnalysisAlgorithm a = a -> [ParserInfo] -> ParserInfo++-- for dim1 we don't need the rewriting function to determine the yield size+-- it's kept as argument anyway to make it more consistent+determineYieldSize1 :: YieldAnalysisAlgorithm Dim1+determineYieldSize1 _ infos =+ let elemInfo = buildYieldSizeMap infos+ (yieldMin,yieldMax) = combineYields (Map.elems elemInfo) + in ParserInfo1 { + minYield = yieldMin,+ maxYield = yieldMax+ }++determineYieldSize2 :: YieldAnalysisAlgorithm Dim2+determineYieldSize2 f infos =+ let elemInfo = buildYieldSizeMap infos+ (left,right) = f (Map.keys elemInfo)+ leftYields = map (\(i,j) -> elemInfo Map.! (i,j)) left+ rightYields = map (\(i,j) -> elemInfo Map.! (i,j)) right+ (leftMin,leftMax) = combineYields leftYields+ (rightMin,rightMax) = combineYields rightYields + in ParserInfo2 { + minYield2 = (leftMin,rightMin),+ maxYield2 = (leftMax,rightMax)+ }++combineYields :: [YieldSize] -> YieldSize+combineYields = foldl (\(minY1,maxY1) (minY2,maxY2) ->+ ( minY1+minY2+ , liftM2 (+) maxY1 maxY2+ ) ) (0,Just 0)++-- | min and max yield size+type YieldSize = (Int,Maybe Int)++-- | Maps each parser symbol to its yield size+-- (remember: a 2-dim parser has 2 symbols in a rewriting function)+type YieldSizeMap = Map (Int,Int) YieldSize++-- the input list is in reverse order, i.e. the first in the list is the last applied parser+buildYieldSizeMap :: [ParserInfo] -> YieldSizeMap+buildYieldSizeMap infos =+ let parserCount = length infos+ list = concatMap (\ (x,info) -> case info of+ ParserInfo1 { minYield = minY, maxYield = maxY } ->+ [ ((x,1), (minY, maxY) ) ]+ ParserInfo2 { minYield2 = minY, maxYield2 = maxY } ->+ [ ((x,1), (fst minY, fst maxY) )+ , ((x,2), (snd minY, snd maxY) )+ ]+ ) $ zip [parserCount,parserCount-1..] infos in Map.fromList list
− src/ADP/Multi/SimpleParsers.hs
@@ -1,108 +0,0 @@-{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- needed for Parseable -{-# LANGUAGE DeriveDataTypeable #-} - -module ADP.Multi.SimpleParsers where - -import Data.Array -import Data.Typeable -import Data.Data -import ADP.Multi.Parser - -data EPS = EPS deriving (Eq, Show, Data, Typeable) - - --- # elementary parsers - -empty1 :: RichParser a EPS -empty1 = ( - ParserInfo1 {minYield=0, maxYield=Just 0}, - \ _ [i,j] -> - [ EPS | - i == j - ] - ) - -empty2 :: RichParser a (EPS,EPS) -empty2 = ( - ParserInfo2 {minYield2=(0,0), maxYield2=(Just 0,Just 0)}, - \ _ [i,j,k,l] -> - [ (EPS,EPS) | - i == j && k == l - ] - ) - -anychars :: RichParser a (a,a) -anychars = ( - ParserInfo2 {minYield2=(1,1), maxYield2=(Just 1,Just 1)}, - \ z [i,j,k,l] -> - [ (z!j, z!l) | - i+1 == j && k+1 == l - ] - ) - -chars :: Eq a => a -> a -> RichParser a (a,a) -chars c1 c2 = ( - ParserInfo2 {minYield2=(1,1), maxYield2=(Just 1,Just 1)}, - \ z [i,j,k,l] -> - [ (z!j, z!l) | - i+1 == j && k+1 == l && z!j == c1 && z!l == c2 - ] - ) - -char :: Eq a => a -> RichParser a a -char c = ( - ParserInfo1 {minYield=1, maxYield=Just 1}, - \ z [i,j] -> - [ (z!j) | - i+1 == j && z!j == c - ] - ) - -anychar :: RichParser a a -anychar = ( - ParserInfo1 {minYield=1, maxYield=Just 1}, - \ z [i,j] -> - [ (z!j) | - i+1 == j - ] - ) - -charLeftOnly :: Eq a => a -> RichParser a (a,EPS) -charLeftOnly c = ( - ParserInfo2 {minYield2=(1,0), maxYield2=(Just 1,Just 0)}, - \ z [i,j,k,l] -> - [ (c, EPS) | - i+1 == j && k == l && z!j == c - ] - ) - -charRightOnly :: Eq a => a -> RichParser a (EPS,a) -charRightOnly c = ( - ParserInfo2 {minYield2=(0,1), maxYield2=(Just 0,Just 1)}, - \ z [i,j,k,l] -> - [ (EPS, c) | - i == j && k+1 == l && z!l == c - ] - ) - --- # some syntax sugar - -instance Parseable EPS Char EPS where - toParser _ = empty1 - -instance Parseable Char Char Char where - toParser = char - -instance Parseable (EPS,EPS) Char (EPS,EPS) where - toParser _ = empty2 - -instance Parseable (Char,Char) Char (Char,Char) where - toParser (c1,c2) = chars c1 c2 - -instance Parseable (EPS,Char) Char (EPS,Char) where - toParser (_,c) = charRightOnly c - -instance Parseable (Char,EPS) Char (Char,EPS) where - toParser (c,_) = charLeftOnly c
src/ADP/Multi/Tabulation.hs view
@@ -1,35 +1,32 @@-module ADP.Multi.Tabulation where - -import Data.Array -import ADP.Multi.Parser - - --- four-dimensional tabulation -table2 :: Array Int a -> RichParser a b -> RichParser a b -table2 z (info,q) = - let (_,n) = bounds z - arr = ( array ((0,0,0,0),(n,n,n,n)) - [ ((i,j,k,l),q z [i,j,k,l]) | - i <- [0..n] - , j <- [i..n] - , k <- [0..n] - , l <- [k..n] - ]) - in (info, - \ _ [i',j',k',l'] -> arr ! (i',j',k',l') - ) - --- two-dimensional tabulation -table1 :: Array Int a -> RichParser a b -> RichParser a b -table1 z (info,q) = - let (_,n) = bounds z - arr = ( array ((0,0),(n,n)) - [ ((i,j),q z [i,j]) | - i <- [0..n] - , j <- [i..n] - ]) - in (info, - \ _ [i',j'] -> arr ! (i',j') - ) - --- TODO tabulation with diagonal arrays+-- | Combinators for two- and four-dimensional tabulation+module ADP.Multi.Tabulation where++import Data.Array+import ADP.Multi.Parser++-- | Two-dimensional tabulation for one-dim. parsers+table1' :: Array Int a -> Parser a b -> Parser a b+table1' z q = + let (_,n) = bounds z+ arr = array ((0,0),(n,n))+ [ ((i,j), q z [i,j])+ | i <- [0..n], j <- [i..n] ]+ in \ _ [i,j] -> arr ! (i,j)++-- | Two-dimensional tabulation for one-dim. parsers+table1 :: Array Int a -> RichParser a b -> RichParser a b+table1 z (info,q) = (info, table1' z q)++-- | Four-dimensional tabulation for two-dim. parsers+table2' :: Array Int a -> Parser a b -> Parser a b+table2' z q =+ let (_,n) = bounds z+ arr = array ((0,0,0,0),(n,n,n,n))+ [ ((i,j,k,l), q z [i,j,k,l])+ | i <- [0..n], j <- [i..n]+ , k <- [0..n], l <- [k..n] ]+ in \ _ [i,j,k,l] -> arr ! (i,j,k,l)++-- | Four-dimensional tabulation for two-dim. parsers+table2 :: Array Int a -> RichParser a b -> RichParser a b+table2 z (info,q) = (info, table2' z q)
− tests/ADP/Combinators.hs
@@ -1,149 +0,0 @@-{- -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/Multi/Rewriting/Tests/YieldSize.hs view
@@ -1,88 +1,88 @@-{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -module ADP.Multi.Rewriting.Tests.YieldSize ( - prop_infoMapSize, - prop_infoMapElements, - prop_yieldSizeDim2 -) where - -import Test.QuickCheck -import Text.Show.Functions() -import System.Random.Shuffle - -import qualified Data.Map as Map - -import ADP.Multi.Parser -import ADP.Multi.Rewriting -import ADP.Multi.Rewriting.YieldSize - -elemCount ParserInfo1{} = 1 -elemCount ParserInfo2{} = 2 -infoMapSize = foldl (\ count info -> count + elemCount info ) 0 - -prop_infoMapSize (infos :: [ParserInfo]) = - let infoMap = buildInfoMap infos - in Map.size infoMap == infoMapSize infos - -prop_infoMapElements (infos :: [ParserInfo]) = - let infoMap = buildInfoMap infos - reversed = reverse infos - withIdx = zip [1..] reversed - exists (i,ParserInfo1 {minYield=min1,maxYield=max1}) = - Map.member (i,1) infoMap && infoMap Map.! (i,1) == (min1,max1) - exists (i,ParserInfo2 {minYield2=(min1,min2),maxYield2=(max1,max2)}) = - Map.member (i,1) infoMap && Map.member (i,2) infoMap && - infoMap Map.! (i,1) == (min1,max1) && - infoMap Map.! (i,2) == (min2,max2) - in all exists withIdx - --- calculates the value of doDetermineYieldSize2 in terms of doDetermineYieldSize1 -prop_yieldSizeDim2 (infos :: [ParserInfo]) = - forAll (genDim2RewritingFunction infos) $ \ f -> - let elemInfo = buildInfoMap infos - (left,right) = f (Map.keys elemInfo) - yieldToInfo (minY,maxY) = ParserInfo1 {minYield = minY, maxYield = maxY} - parserInfos = map (\(i,j) -> yieldToInfo $ elemInfo Map.! (i,j)) - leftInfos = parserInfos left - rightInfos = parserInfos right - leftYield = doDetermineYieldSize1 undefined leftInfos - rightYield = doDetermineYieldSize1 undefined rightInfos - in doDetermineYieldSize2 f infos - == - ParserInfo2 { - minYield2 = (minYield leftYield, minYield rightYield), - maxYield2 = (maxYield leftYield, maxYield rightYield) - } - --- remove this once random-shuffle handles this case by itself --- at the moment it goes into a <<loop>>! -_shuffle [] _ = [] -_shuffle list samples = shuffle list samples - -genDim2RewritingFunction :: [ParserInfo] -> Gen Dim2 -genDim2RewritingFunction infos = - let len = infoMapSize infos - in do split <- choose (0,len) - samples <- mapM (\i -> choose (0,len-i)) [1..len-1] - return $ \ l -> - let shuffled = _shuffle l samples - in (take split shuffled, drop split shuffled) - - -instance Arbitrary ParserInfo where - arbitrary = oneof [ do (minY,maxY) <- genMinMaxYield - return ParserInfo1 { minYield = minY, maxYield = maxY } - , - do (minY1,maxY1) <- genMinMaxYield - (minY2,maxY2) <- genMinMaxYield - return ParserInfo2 { minYield2 = (minY1,minY2), maxYield2 = (maxY1,maxY2) } - ] - -genMinMaxYield :: Gen (Int,Maybe Int) -genMinMaxYield = sized $ \n -> - do NonNegative minY <- arbitrary - maxY <- choose (minY,n) - oneof [ return (minY,Just maxY), - return (minY,Nothing) ] +{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module ADP.Multi.Rewriting.Tests.YieldSize (+ prop_yieldSizeMapSize,+ prop_yieldSizeMapElements,+ prop_yieldSizeDim2+) where++import Test.QuickCheck+import Text.Show.Functions()+import System.Random.Shuffle++import qualified Data.Map as Map++import ADP.Multi.Parser+import ADP.Multi.Rewriting.Model+import ADP.Multi.Rewriting.YieldSize++elemCount ParserInfo1{} = 1+elemCount ParserInfo2{} = 2+yieldSizeMapSize = foldl (\ count info -> count + elemCount info ) 0++prop_yieldSizeMapSize (infos :: [ParserInfo]) = + let yieldSizeMap = buildYieldSizeMap infos+ in Map.size yieldSizeMap == yieldSizeMapSize infos+ +prop_yieldSizeMapElements (infos :: [ParserInfo]) =+ let yieldSizeMap = buildYieldSizeMap infos+ reversed = reverse infos+ withIdx = zip [1..] reversed+ exists (i,ParserInfo1 {minYield=min1,maxYield=max1}) = + Map.member (i,1) yieldSizeMap && yieldSizeMap Map.! (i,1) == (min1,max1)+ exists (i,ParserInfo2 {minYield2=(min1,min2),maxYield2=(max1,max2)}) = + Map.member (i,1) yieldSizeMap && Map.member (i,2) yieldSizeMap &&+ yieldSizeMap Map.! (i,1) == (min1,max1) &&+ yieldSizeMap Map.! (i,2) == (min2,max2)+ in all exists withIdx+ +-- calculates the value of doDetermineYieldSize2 in terms of doDetermineYieldSize1+prop_yieldSizeDim2 (infos :: [ParserInfo]) =+ forAll (genDim2RewritingFunction infos) $ \ f ->+ let yieldSizeMap = buildYieldSizeMap infos+ (left,right) = f (Map.keys yieldSizeMap)+ yieldToInfo (minY,maxY) = ParserInfo1 {minYield = minY, maxYield = maxY}+ parserInfos = map (\(i,j) -> yieldToInfo $ yieldSizeMap Map.! (i,j))+ leftInfos = parserInfos left+ rightInfos = parserInfos right+ leftYield = determineYieldSize1 undefined leftInfos+ rightYield = determineYieldSize1 undefined rightInfos+ in determineYieldSize2 f infos + ==+ ParserInfo2 {+ minYield2 = (minYield leftYield, minYield rightYield),+ maxYield2 = (maxYield leftYield, maxYield rightYield)+ }++-- remove this once random-shuffle handles this case by itself+-- at the moment it goes into a <<loop>>!+_shuffle [] _ = []+_shuffle list samples = shuffle list samples++genDim2RewritingFunction :: [ParserInfo] -> Gen Dim2+genDim2RewritingFunction infos =+ let len = yieldSizeMapSize infos+ in do split <- choose (0,len)+ samples <- mapM (\i -> choose (0,len-i)) [1..len-1]+ return $ \ l ->+ let shuffled = _shuffle l samples+ in (take split shuffled, drop split shuffled)++ +instance Arbitrary ParserInfo where+ arbitrary = oneof [ do (minY,maxY) <- genMinMaxYield+ return ParserInfo1 { minYield = minY, maxYield = maxY }+ , + do (minY1,maxY1) <- genMinMaxYield+ (minY2,maxY2) <- genMinMaxYield+ return ParserInfo2 { minYield2 = (minY1,minY2), maxYield2 = (maxY1,maxY2) }+ ]++genMinMaxYield :: Gen (Int,Maybe Int)+genMinMaxYield = sized $ \n -> + do NonNegative minY <- arbitrary+ maxY <- choose (minY,n)+ oneof [ return (minY,Just maxY),+ return (minY,Nothing) ]
tests/ADP/Tests/AlignmentExample.hs view
@@ -1,90 +1,82 @@-{-# 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 - +-- Needleman/Wunsch global alignment+module ADP.Tests.AlignmentExample where++import ADP.Debug+import ADP.Multi.All+import ADP.Multi.Rewriting.All+ +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 :: Alignment_Algebra Char answer -> (String,String) -> [answer]+alignmentGr _ inp | trace ("running alignmentGr on " ++ show inp) False = undefined+alignmentGr algebra (inp1,inp2) =+ let+ (nil,del,ins,match,h) = algebra+ + rewriteDel, rewriteIns, rewriteMatch :: Dim2+ + 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 $+ yieldSize2 (0,Nothing) (0,Nothing) $+ 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
@@ -1,73 +1,104 @@-{-# 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 - +-- Copy language L = { ww | w € {a,b}^* }+module ADP.Tests.CopyExample where++import ADP.Multi.All+import ADP.Multi.Rewriting.All++import MCFG.MCFG+ +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'++-- MCFG grammar in Waldmann's data types, used for consistency checking +mcfg :: MCFG+mcfg = MCFG + { start = N 1 "S"+ , rules = [ Rule { lhs = N 1 "S"+ , function = [[Left (0,0), Left (0,1) ]]+ , rhs = [ N 2 "X" ]+ }+ , Rule { lhs = N 2 "X"+ , function = + [[ Right $ T 'a', Left (0,0) ]+ ,[ Right $ T 'a', Left (0,1) ]+ ]+ , rhs = [N 2 "X"]+ }+ , Rule { lhs = N 2 "X"+ , function = + [[ Right $ T 'b', Left (0,0) ]+ ,[ Right $ T 'b', Left (0,1) ]+ ]+ , rhs = [N 2 "X"]+ }+ , Rule { lhs = N 2 "X"+ , function = [ [], [] ]+ , rhs = []+ }+ ]+ }++-- 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+derivation :: Copy_Algebra Char Derivation Derivation+derivation = (nil,copy,copy') where+ nil _ = Derivation undefined r3 []+ copy d = Derivation undefined r0 [d]+ copy' 'a' 'a' d = Derivation undefined r1 [d]+ copy' 'b' 'b' d = Derivation undefined r2 [d]+ copy' _ _ _ = error "grammar mismatch"+ + [ r0, r1, r2, r3 ] = rules mcfg+ +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 :: Copy_Algebra Char answerDim1 answerDim2 -> String -> [answerDim1]+copyGr algebra inp =+ let + (nil,copy,copy') = algebra+ + s = tabulated1 $+ copy <<< c >>> id1 + + rewriteCopy :: Dim2+ rewriteCopy [a',a'',c1,c2] = ([a',c1],[a'',c2])+ + c = tabulated2 $+ yieldSize2 (0,Nothing) (0,Nothing) $+ 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
@@ -1,62 +1,53 @@-{-# 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 - +-- Copy language L = { (w,w) | w € {a,b}^* }+module ADP.Tests.CopyTwoTrackExample where++import ADP.Debug+import ADP.Multi.All+import ADP.Multi.Rewriting.All+ +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 ::CopyTT_Algebra Char answer -> (String,String) -> [answer]+copyTTGr _ inp | trace ("running copyTTGr on " ++ show inp) False = undefined+copyTTGr algebra (inp1,inp2) =+ let + (nil,copy) = algebra+ + rewriteCopy :: Dim2+ rewriteCopy [a',a'',c1,c2] = ([a',c1],[a'',c2])+ + c = tabulated2 $+ yieldSize2 (0,Nothing) (0,Nothing) $+ 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/Main.hs view
@@ -7,8 +7,8 @@ import qualified ADP.Tests.OneStructureExample as One import qualified ADP.Tests.ZeroStructureTwoBackbonesExample as ZeroTT import qualified ADP.Tests.AlignmentExample as Alignment ---import ADP.Multi.Rewriting.ConstraintSolver -import ADP.Multi.Rewriting.Explicit +import qualified ADP.Tests.TreeAlignExample as TreeAlign +import qualified ADP.Tests.TermExample as Term main::IO() @@ -16,15 +16,18 @@ hSetBuffering stdout LineBuffering --forM_ result print - --forM_ result2 print + --forM_ result21 print --forM_ result3 print --forM_ result4 print --forM_ result53 print --forM_ result6 putStrLn + --forM_ result6t3 print --forM_ result7 print --forM_ result8 print --forM_ result9 print - forM_ result10 print+ --forM_ result10 print + --forM_ resultTerm putStrLn + forM_ resultTreeAlign print where -- http://www.ekevanbatenburg.nl/PKBASE/PKB00279.HTML @@ -36,14 +39,15 @@ -- inp = map toLower "ACCGUCGUUCCCGACGUAAAAGGGAUGU" -- https://github.com/neothemachine/rna/wiki/Example - inp = "agcguu" + inp = "agcgu" --inp = map toLower "ACGAUUCAACGU" - rg = RG.rgknot determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + rg = RG.rgknot result = rg RG.enum inp result2 = rg RG.maxBasepairs inp + result21 = rg (RG.prettyprint RG.*** RG.maxBasepairs) inp result3 = rg RG.maxKnots inp result4 = rg RG.prettyprint inp @@ -52,17 +56,33 @@ result52 = rg (RG.prettyprint RG.*** RG.pstreeYield) inp result53 = rg (RG.prettyprint RG.*** RG.pstreeEval) inp - nested = N.nested determineYieldSize1 constructRanges1 + nested = N.nested result6 = nested (N.pstree) inp - copy = C.copyGr determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + result6t = nested (N.maxBasepairs N.*** N.prettyprint) inp + result6t2 = nested (N.term N.*** N.maxBasepairs) inp + result6t3 = nested (N.termPlain N.*** N.maxBasepairs) inp + + copy = C.copyGr result7 = copy (C.countABs) "abaaabaa" - oneStructure = One.oneStructure determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + oneStructure = One.oneStructure result8 = oneStructure (One.prettyprint) inp - zeroStructureTT = ZeroTT.zeroStructureTwoBackbones determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + zeroStructureTT = ZeroTT.zeroStructureTwoBackbones result9 = zeroStructureTT (ZeroTT.enum) (inp,inp) - alignment = Alignment.alignmentGr determineYieldSize2 constructRanges2 - result10 = alignment (Alignment.unit Alignment.*** Alignment.count) ("darling","airline")+ alignment = Alignment.alignmentGr + result10 = alignment (Alignment.unit Alignment.*** Alignment.count) ("darling","airline") + + term = Term.term + termAlg = Term.qtree (\sym -> + if sym `elem` ["a","g","c","u",".","(",")","[","]"] then "\\ts{" ++ sym ++ "}" + else if take 2 sym == "f_" || take 2 sym == "g_" then "$\\op{" ++ take 1 sym ++ "}_" ++ drop 2 sym ++ "$" + else "$" ++ sym ++ "$") + resultTerm = term termAlg "Z:r_1(.,Z:r_1(.,Z:r_1(.,Z:r_1(.,Z:r_1(.,Z:r_1(.,\\epsilon))))))" + + tree1 = "f(f(),g(f()))" + tree2 = "f(f(),g())" + ta = TreeAlign.treeAlign (TreeAlign.treeSimilarity TreeAlign.*** TreeAlign.term) + resultTreeAlign = ta (tree1,tree2)
tests/ADP/Tests/MonadicCpRegression.hs view
@@ -1,49 +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] +{-# 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
@@ -1,55 +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] +{-# 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,12 +1,7 @@-{-# LANGUAGE ImplicitParams #-} - module ADP.Tests.NestedExample where -import ADP.Multi.SimpleParsers -import ADP.Multi.Combinators -import ADP.Multi.Tabulation -import ADP.Multi.Helpers -import ADP.Multi.Rewriting +import ADP.Multi.All +import ADP.Multi.Rewriting.All type Nested_Algebra alphabet answer = ( EPS -> answer, -- nil @@ -74,9 +69,9 @@ maxBasepairs :: Nested_Algebra Char Int maxBasepairs = (nil,left,pair,basepair,base,h) where nil _ = 0 - left a b = a + b + left _ b = b pair a b = a + b - basepair _ _ _ = 1 + basepair _ s _ = 1 + s base _ = 0 h [] = [] h xs = [maximum xs] @@ -84,8 +79,8 @@ -- The left part is the structure and the right part the reconstructed input. prettyprint :: Nested_Algebra Char (String,String) prettyprint = (nil,left,pair,basepair,base,h) where - nil _ = ("","") - left (bl,br) (sl,sr) = (bl ++ sl, br ++ sr) + nil _ = ("","")+ left (b1,b2) (sl,sr) = (b1 ++ sl, b2 ++ sr) pair (pl,pr) (sl,sr) = (pl ++ sl, pr ++ sr) basepair b1 (sl,sr) b2 = ("(" ++ sl ++ ")", [b1] ++ sr ++ [b2]) base b = (".", [b]) @@ -102,37 +97,49 @@ nonterm sym tree = "\\pstree{\\nonterminal{" ++ sym ++ "}}{" ++ tree ++ "}" -nested :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 - -> Nested_Algebra Char answer -> String -> [answer] -nested 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 - +term :: Nested_Algebra Char String +term = (nil,left,pair,basepair,base,h) where + nil _ = "\\op{f}_3()" + left b s = "\\op{f}_2(" ++ b ++ "," ++ s ++ ")" + pair p s = "\\op{f}_2(" ++ p ++ "," ++ s ++ ")" + basepair b1 s b2 = "\\op{f}_4(" ++ [b1] ++ "," ++ s ++ "," ++ [b2] ++ ")" + base b = "\\op{f}_5(" ++ [b] ++ ")" + h = id + +termPlain :: Nested_Algebra Char String +termPlain = (nil,left,pair,basepair,base,h) where + nil _ = "f_3" + left b s = "f_2(" ++ b ++ "," ++ s ++ ")" + pair p s = "f_2(" ++ p ++ "," ++ s ++ ")" + basepair b1 s b2 = "f_4(" ++ [b1] ++ "," ++ s ++ "," ++ [b2] ++ ")" + base b = "f_5(" ++ [b] ++ ")" + h = id + +nested :: Nested_Algebra Char answer -> String -> [answer] +nested algebra inp = + let (nil,left,pair,basepair,base,h) = algebra s = tabulated $ - nil <<< EPS >>>| id ||| - left <<< b ~~~| s >>>| id ||| - pair <<< p ~~~| s >>>| id + yieldSize1 (0,Nothing) $ + nil <<< EPS >>> id1 ||| + left <<< b ~~~ s >>> id1 ||| + pair <<< p ~~~ s >>> id1 ... h b = tabulated $ - base <<< 'a' >>>| id ||| - base <<< 'u' >>>| id ||| - base <<< 'c' >>>| id ||| - base <<< 'g' >>>| id + base <<< 'a' >>> id1 |||+ base <<< 'u' >>> id1 |||+ base <<< 'c' >>> id1 |||+ base <<< 'g' >>> id1 p = tabulated $ - basepair <<< 'a' ~~~| s ~~~ 'u' >>>| id ||| - basepair <<< 'u' ~~~| s ~~~ 'a' >>>| id ||| - basepair <<< 'c' ~~~| s ~~~ 'g' >>>| id ||| - basepair <<< 'g' ~~~| s ~~~ 'c' >>>| id ||| - basepair <<< 'g' ~~~| s ~~~ 'u' >>>| id ||| - basepair <<< 'u' ~~~| s ~~~ 'g' >>>| id + basepair <<< 'a' ~~~ s ~~~ 'u' >>> id1 ||| + basepair <<< 'u' ~~~ s ~~~ 'a' >>> id1 ||| + basepair <<< 'c' ~~~ s ~~~ 'g' >>> id1 ||| + basepair <<< 'g' ~~~ s ~~~ 'c' >>> id1 ||| + basepair <<< 'g' ~~~ s ~~~ 'u' >>> id1 ||| + basepair <<< 'u' ~~~ s ~~~ 'g' >>> id1 z = mk inp tabulated = table1 z
tests/ADP/Tests/Nussinov.lhs view
@@ -139,10 +139,10 @@ > pair <<< char 'u' -~~ s ~~- char 'g' > b = tabulated $-> undefined <<< char 'a' |||-> undefined <<< char 'u' |||-> undefined <<< char 'c' |||-> undefined <<< char 'g'+> char 'a' |||+> char 'u' |||+> char 'c' |||+> char 'g' Bind input:
tests/ADP/Tests/NussinovExample.hs view
@@ -1,18 +1,13 @@-{-# 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 +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 + answer -> answer -> answer, -- right alphabet -> answer -> alphabet -> answer, -- pair answer -> answer -> answer, -- split [answer] -> [answer] -- h @@ -29,37 +24,31 @@ 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 - +nussinov78 :: Nussinov_Algebra Char answer -> String -> [answer] +nussinov78 algebra inp = + let (nil,base,left,right,pair,split,h) = algebra s = tabulated $ - nil <<< EPS >>>| id ||| - right <<<| s ~~~ b >>>| id ||| - split <<<| s ~~~ t >>>| id + yieldSize1 (0, Nothing) $ + nil <<< EPS >>> id1 ||| + right <<< s ~~~ b >>> id1 ||| + split <<< s ~~~ t >>> id1 ... 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 - + 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' >>>| id ||| - base <<< 'u' >>>| id ||| - base <<< 'c' >>>| id ||| - base <<< 'g' >>>| id + base <<< 'a' >>> id1 |||+ base <<< 'u' >>> id1 |||+ base <<< 'c' >>> id1 |||+ base <<< 'g' >>> id1 z = mk inp tabulated = table1 z
tests/ADP/Tests/OneStructureExample.hs view
@@ -1,214 +1,204 @@-{-# LANGUAGE ImplicitParams #-} - -{- 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.Parser -import ADP.Multi.SimpleParsers -import ADP.Multi.Combinators -import ADP.Multi.Tabulation -import ADP.Multi.Helpers -import ADP.Multi.Rewriting - --- TODO as in CopyExample, use separate answer type for each dimension -type OneStructure_Algebra alphabet answer = ( - EPS -> answer, -- nil - answer -> answer -> answer, -- left - answer -> answer -> answer -> answer, -- pair - (alphabet, alphabet) -> answer, -- basepair - alphabet -> answer, -- base - answer -> answer, -- i1 - answer -> answer, -- i2 - answer -> answer -> answer -> answer -> answer, -- tstart - answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotH - answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotK - answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotL - answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotM - answer -> answer -> answer -> answer -> answer, -- aknot1 - answer -> answer, -- aknot2 - answer -> answer -> answer -> answer -> answer, -- bknot1 - answer -> answer, -- bknot2 - answer -> answer -> answer -> answer -> answer, -- cknot1 - answer -> answer, -- cknot2 - answer -> answer -> answer -> answer -> answer, -- dknot1 - answer -> answer, -- dknot2 - [answer] -> [answer] -- h - ) - -data T = Nil - | Left' T T - | Pair T T T - | BasePair (Char, Char) - | Base Char - | I1 T - | I2 T - | TStart T T T T - | KnotH T T T T T T T - | KnotK T T T T T T T T T T - | KnotL T T T T T T T T T T - | KnotM T T T T T T T T T T T T T - | XKnot1 T T T T - | XKnot2 T - deriving (Eq, Show) - -enum :: OneStructure_Algebra Char T -enum = (\_->Nil,Left',Pair,BasePair,Base,I1,I2,TStart,KnotH,KnotK,KnotL,KnotM - ,XKnot1,XKnot2,XKnot1,XKnot2,XKnot1,XKnot2,XKnot1,XKnot2,id) - -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 - nil _ = [""] - left b s = [concat $ b ++ s] - pair [p1,p2] s1 s2 = [concat $ [p1] ++ s1 ++ [p2] ++ s2] - basepair _ = ["(",")"] - base _ = ["."] - i1 s = s - i2 t = t - tstart [p1,p2] i t s = [concat $ i ++ [p1] ++ t ++ [p2] ++ s] - knotH s i1 i2 i3 i4 [a1,a2] [b1,b2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [b2] ++ s] - knotK s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [c1] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s] - knotL s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s] - knotM s i1 i2 i3 i4 i5 i6 i7 i8 [a1,a2] [b1,b2] [c1,c2] [d1,d2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [d1] ++ i6 ++ [b2] ++ i7 ++ [c2] ++ i8 ++ [d2] ++ s] - aknot1 _ = xknot1 "(" ")" - aknot2 _ = [ "(" , ")" ] - bknot1 _ = xknot1 "[" "]" - bknot2 _ = [ "{" , "}" ] - cknot1 _ = xknot1 "{" "}" - cknot2 _ = [ "{" , "}" ] - dknot1 _ = xknot1 "<" ">" - dknot2 _ = [ "<" , ">" ] - - xknot1 parenL parenR i1 i2 [x1,x2] = [concat $ [parenL] ++ i1 ++ [x1], concat $ [x2] ++ i2 ++ [parenR]] - - h = id - --- 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 - nil _ = [""] - left b s = [concat $ b ++ s] - pair [p1,p2] s1 s2 = [concat $ [p1] ++ s1 ++ [p2] ++ s2] - basepair (b1,b2) = [[b1],[b2]] - base b = [[b]] - i1 s = s - i2 t = t - tstart [p1,p2] i t s = [concat $ i ++ [p1] ++ t ++ [p2] ++ s] - knotH s i1 i2 i3 i4 [a1,a2] [b1,b2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [b2] ++ s] - knotK s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [c1] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s] - knotL s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s] - knotM s i1 i2 i3 i4 i5 i6 i7 i8 [a1,a2] [b1,b2] [c1,c2] [d1,d2] = - [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [d1] ++ i6 ++ [b2] ++ i7 ++ [c2] ++ i8 ++ [d2] ++ s] - aknot1 = xknot1 - aknot2 = xknot2 - bknot1 = xknot1 - bknot2 = xknot2 - cknot1 = xknot1 - cknot2 = xknot2 - dknot1 = xknot1 - dknot2 = xknot2 - - xknot1 [p1,p2] i1 i2 [x1,x2] = [concat $ [p1] ++ i1 ++ [x1], concat $ [x2] ++ i2 ++ [p2]] - xknot2 [p1,p2] = [p1,p2] - - h = 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). --} -oneStructure :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 - -> YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 - -> OneStructure_Algebra Char answer -> String -> [answer] -oneStructure yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra inp = - let z = mk inp - grammar = oneStructureGrammar yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra z - in axiom z grammar - -oneStructureGrammar :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 - -> YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 - -> OneStructure_Algebra Char answer -> Array Int Char -> RichParser Char answer -oneStructureGrammar yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra z = - -- 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,basepair,base,i1,i2,tstart,knotH,knotK,knotL,knotM, - aknot1,aknot2,bknot1,bknot2,cknot1,cknot2,dknot1,dknot2,h) = algebra - - i = tabulated1 $ - i1 <<< s >>>| id ||| - i2 <<< t >>>| id - - rewritePair [p1,p2,s1,s2] = [p1,s1,p2,s2] - - s = tabulated1 $ - nil <<< EPS >>>| id ||| - left <<< b ~~~| s >>>| id ||| - pair <<< p ~~~| s ~~~| s >>>| rewritePair - - rewriteTStart [p1,p2,i,t,s] = [i,p1,t,p2,s] - rewriteKnotH [s,i1,i2,i3,i4,x11,x12,x21,x22] = [i1,x11,i2,x21,i3,x12,i4,x22,s] - rewriteKnotK [s,i1,i2,i3,i4,i5,i6,x11,x12,x21,x22,x31,x32] = [i1,x11,i2,x21,i3,x12,i4,x31,i5,x22,i6,x32,s] - rewriteKnotL [s,i1,i2,i3,i4,i5,i6,x11,x12,x21,x22,x31,x32] = [i1,x11,i2,x21,i3,x31,i4,x12,i5,x22,i6,x32,s] - rewriteKnotM [s,i1,i2,i3,i4,i5,i6,i7,i8,x11,x12,x21,x22,x31,x32,x41,x42] = - [i1,x11,i2,x21,i3,x31,i4,x12,i5,x41,i6,x22,i7,x32,i8,x42,s] - t = tabulated1 $ - tstart <<< p ~~~| i ~~~| t ~~~ s >>>| rewriteTStart ||| - knotH <<< s ~~~| i ~~~| i ~~~| i ~~~| i ~~~ xa ~~~ xb >>>| rewriteKnotH ||| - knotK <<< s ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~ xa ~~~ xb ~~~ xc >>>| rewriteKnotK ||| - knotL <<< s ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~ xa ~~~ xb ~~~ xc >>>| rewriteKnotL ||| - knotM <<< s ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~| i ~~~ xa ~~~ xb ~~~ xc ~~~ xd >>>| rewriteKnotM - - rewriteXKnot1 [p1,p2,i1,i2,x1,x2] = ([p1,i1,x1],[x2,i2,p2]) - xa = tabulated2 $ - aknot1 <<< p ~~~| i ~~~| i ~~~|| xa >>>|| rewriteXKnot1 ||| - aknot2 <<< p >>>|| id2 - - xb = tabulated2 $ - bknot1 <<< p ~~~| i ~~~| i ~~~|| xb >>>|| rewriteXKnot1 ||| - bknot2 <<< p >>>|| id2 - - xc = tabulated2 $ - cknot1 <<< p ~~~| i ~~~| i ~~~|| xb >>>|| rewriteXKnot1 ||| - cknot2 <<< p >>>|| id2 - - xd = tabulated2 $ - dknot1 <<< p ~~~| i ~~~| i ~~~|| xb >>>|| rewriteXKnot1 ||| - dknot2 <<< p >>>|| id2 - - b = tabulated1 $ - base <<< 'a' >>>| id ||| - base <<< 'u' >>>| id ||| - base <<< 'c' >>>| id ||| - base <<< 'g' >>>| id - - p = tabulated2 $ - basepair <<< ('a', 'u') >>>|| id2 ||| - basepair <<< ('u', 'a') >>>|| id2 ||| - basepair <<< ('c', 'g') >>>|| id2 ||| - basepair <<< ('g', 'c') >>>|| id2 ||| - basepair <<< ('g', 'u') >>>|| id2 ||| - basepair <<< ('u', 'g') >>>|| id2 - - tabulated1 = table1 z - tabulated2 = table2 z - +{- 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+ answer -> answer -> answer -> answer, -- pair+ (alphabet, alphabet) -> answer, -- basepair+ alphabet -> answer, -- base+ answer -> answer, -- i1+ answer -> answer, -- i2+ answer -> answer -> answer -> answer -> answer, -- tstart+ answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotH+ answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotK+ answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotL+ answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knotM+ answer -> answer -> answer -> answer -> answer, -- aknot1+ answer -> answer, -- aknot2+ answer -> answer -> answer -> answer -> answer, -- bknot1+ answer -> answer, -- bknot2+ answer -> answer -> answer -> answer -> answer, -- cknot1+ answer -> answer, -- cknot2+ answer -> answer -> answer -> answer -> answer, -- dknot1+ answer -> answer, -- dknot2+ [answer] -> [answer] -- h+ )+ +data T = Nil+ | Left' T T+ | Pair T T T+ | BasePair (Char, Char)+ | Base Char+ | I1 T+ | I2 T+ | TStart T T T T+ | KnotH T T T T T T T+ | KnotK T T T T T T T T T T+ | KnotL T T T T T T T T T T+ | KnotM T T T T T T T T T T T T T+ | XKnot1 T T T T+ | XKnot2 T+ deriving (Eq, Show)++enum :: OneStructure_Algebra Char T+enum = (\_->Nil,Left',Pair,BasePair,Base,I1,I2,TStart,KnotH,KnotK,KnotL,KnotM+ ,XKnot1,XKnot2,XKnot1,XKnot2,XKnot1,XKnot2,XKnot1,XKnot2,id)+ +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+ nil _ = [""]+ left b s = [concat $ b ++ s]+ pair [p1,p2] s1 s2 = [concat $ [p1] ++ s1 ++ [p2] ++ s2]+ basepair _ = ["(",")"]+ base _ = ["."]+ i1 s = s+ i2 t = t+ tstart [p1,p2] i t s = [concat $ i ++ [p1] ++ t ++ [p2] ++ s]+ knotH s i1 i2 i3 i4 [a1,a2] [b1,b2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [b2] ++ s]+ knotK s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [c1] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s]+ knotL s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s]+ knotM s i1 i2 i3 i4 i5 i6 i7 i8 [a1,a2] [b1,b2] [c1,c2] [d1,d2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [d1] ++ i6 ++ [b2] ++ i7 ++ [c2] ++ i8 ++ [d2] ++ s]+ aknot1 _ = xknot1 "(" ")"+ aknot2 _ = [ "(" , ")" ]+ bknot1 _ = xknot1 "[" "]"+ bknot2 _ = [ "{" , "}" ]+ cknot1 _ = xknot1 "{" "}"+ cknot2 _ = [ "{" , "}" ]+ dknot1 _ = xknot1 "<" ">"+ dknot2 _ = [ "<" , ">" ]+ + xknot1 parenL parenR i1 i2 [x1,x2] = [concat $ [parenL] ++ i1 ++ [x1], concat $ [x2] ++ i2 ++ [parenR]]+ + h = id+ +-- 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+ nil _ = [""]+ left b s = [concat $ b ++ s]+ pair [p1,p2] s1 s2 = [concat $ [p1] ++ s1 ++ [p2] ++ s2]+ basepair (b1,b2) = [[b1],[b2]]+ base b = [[b]]+ i1 s = s+ i2 t = t+ tstart [p1,p2] i t s = [concat $ i ++ [p1] ++ t ++ [p2] ++ s]+ knotH s i1 i2 i3 i4 [a1,a2] [b1,b2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [b2] ++ s]+ knotK s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [a2] ++ i4 ++ [c1] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s]+ knotL s i1 i2 i3 i4 i5 i6 [a1,a2] [b1,b2] [c1,c2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [b2] ++ i6 ++ [c2] ++ s]+ knotM s i1 i2 i3 i4 i5 i6 i7 i8 [a1,a2] [b1,b2] [c1,c2] [d1,d2] =+ [concat $ i1 ++ [a1] ++ i2 ++ [b1] ++ i3 ++ [c1] ++ i4 ++ [a2] ++ i5 ++ [d1] ++ i6 ++ [b2] ++ i7 ++ [c2] ++ i8 ++ [d2] ++ s]+ aknot1 = xknot1+ aknot2 = xknot2+ bknot1 = xknot1+ bknot2 = xknot2+ cknot1 = xknot1+ cknot2 = xknot2+ dknot1 = xknot1+ dknot2 = xknot2+ + xknot1 [p1,p2] i1 i2 [x1,x2] = [concat $ [p1] ++ i1 ++ [x1], concat $ [x2] ++ i2 ++ [p2]]+ xknot2 [p1,p2] = [p1,p2]+ + h = 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).+-}+oneStructure :: OneStructure_Algebra Char answer -> String -> [answer]+oneStructure algebra inp =+ let z = mk inp+ grammar = oneStructureGrammar algebra z+ in axiom z grammar++oneStructureGrammar :: OneStructure_Algebra Char answer -> Array Int Char -> RichParser Char answer+oneStructureGrammar algebra z =+ let + (nil,left,pair,basepair,base,i1,i2,tstart,knotH,knotK,knotL,knotM,+ aknot1,aknot2,bknot1,bknot2,cknot1,cknot2,dknot1,dknot2,h) = algebra+ + i = tabulated1 $+ i1 <<< s >>> id1 |||+ i2 <<< t >>> id1+ + rewritePair, rewriteTStart, rewriteKnotH, rewriteKnotK, rewriteKnotL, rewriteKnotM :: Dim1+ + rewritePair [p1,p2,s1,s2] = [p1,s1,p2,s2]+ + s = tabulated1 $+ yieldSize1 (0, Nothing) $+ nil <<< EPS >>> id1 |||+ left <<< b ~~~ s >>> id1 |||+ pair <<< p ~~~ s ~~~ s >>> rewritePair+ + rewriteTStart [p1,p2,i,t,s] = [i,p1,t,p2,s]+ rewriteKnotH [s,i1,i2,i3,i4,x11,x12,x21,x22] = [i1,x11,i2,x21,i3,x12,i4,x22,s]+ rewriteKnotK [s,i1,i2,i3,i4,i5,i6,x11,x12,x21,x22,x31,x32] = [i1,x11,i2,x21,i3,x12,i4,x31,i5,x22,i6,x32,s]+ rewriteKnotL [s,i1,i2,i3,i4,i5,i6,x11,x12,x21,x22,x31,x32] = [i1,x11,i2,x21,i3,x31,i4,x12,i5,x22,i6,x32,s]+ rewriteKnotM [s,i1,i2,i3,i4,i5,i6,i7,i8,x11,x12,x21,x22,x31,x32,x41,x42] =+ [i1,x11,i2,x21,i3,x31,i4,x12,i5,x41,i6,x22,i7,x32,i8,x42,s]+ t = tabulated1 $+ yieldSize1 (2, Nothing) $+ tstart <<< p ~~~ i ~~~ t ~~~ s >>> rewriteTStart |||+ knotH <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb >>> rewriteKnotH |||+ knotK <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc >>> rewriteKnotK |||+ knotL <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc >>> rewriteKnotL |||+ knotM <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc ~~~ xd >>> rewriteKnotM+ + rewriteXKnot1 :: Dim2 + rewriteXKnot1 [p1,p2,i1,i2,x1,x2] = ([p1,i1,x1],[x2,i2,p2])+ + xa = tabulated2 $+ yieldSize2 (1, Nothing) (1, Nothing) $+ aknot1 <<< p ~~~ i ~~~ i ~~~ xa >>> rewriteXKnot1 |||+ aknot2 <<< p >>> id2+ + xb = tabulated2 $+ yieldSize2 (1, Nothing) (1, Nothing) $+ bknot1 <<< p ~~~ i ~~~ i ~~~ xb >>> rewriteXKnot1 |||+ bknot2 <<< p >>> id2+ + xc = tabulated2 $+ cknot1 <<< p ~~~ i ~~~ i ~~~ xb >>> rewriteXKnot1 |||+ cknot2 <<< p >>> id2+ + xd = tabulated2 $+ dknot1 <<< p ~~~ i ~~~ i ~~~ xb >>> rewriteXKnot1 |||+ dknot2 <<< p >>> id2+ + b = tabulated1 $+ base <<< 'a' >>> id1 |||+ base <<< 'u' >>> id1 |||+ base <<< 'c' >>> id1 |||+ base <<< 'g' >>> id1+ + p = tabulated2 $+ basepair <<< ('a', 'u') >>> id2 |||+ basepair <<< ('u', 'a') >>> id2 |||+ basepair <<< ('c', 'g') >>> id2 |||+ basepair <<< ('g', 'c') >>> id2 |||+ basepair <<< ('g', 'u') >>> id2 |||+ basepair <<< ('u', 'g') >>> id2+ + tabulated1 = table1 z+ tabulated2 = table2 z+ in i
tests/ADP/Tests/RGExample.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ImplicitParams #-} {- Example using the Reeder&Giegerich class of pseudoknots.@@ -23,15 +22,11 @@ B -> a | u | c | g -} -import Data.Array (bounds) import qualified Control.Arrow as A import Data.Typeable import Data.Data-import ADP.Multi.SimpleParsers-import ADP.Multi.Combinators-import ADP.Multi.Tabulation-import ADP.Multi.Helpers-import ADP.Multi.Rewriting+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 = (@@ -234,50 +229,45 @@ base b = "\\pstree{\\function{\\op{f}_8}}{\\terminal{" ++ [b] ++ "}}" h = id -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- +rgknot :: RG_Algebra Char answer -> String -> [answer]+rgknot algebra inp =+ let (nil,left,pair,knot,knot1,knot2,basepair,base,h) = algebra + rewritePair, rewriteKnot :: Dim1+ rewritePair [p1,p2,s1,s2] = [p1,s1,p2,s2] rewriteKnot [k11,k12,k21,k22,s1,s2,s3,s4] = [k11,s1,k21,s2,k12,s3,k22,s4] s = tabulated1 $- nil <<< EPS >>>| id |||- left <<< b ~~~| s >>>| id |||- pair <<< p ~~~| s ~~~| s >>>| rewritePair |||- knot <<< k ~~~ k ~~~| s ~~~| s ~~~| s ~~~| s >>>| rewriteKnot+ yieldSize1 (0,Nothing) $+ nil <<< EPS >>> id1 |||+ left <<< b ~~~ s >>> id1 |||+ pair <<< p ~~~ s ~~~ s >>> rewritePair |||+ knot <<< k ~~~ k ~~~ s ~~~ s ~~~ s ~~~ s >>> rewriteKnot ... h b = tabulated1 $- base <<< 'a' >>>| id |||- base <<< 'u' >>>| id |||- base <<< 'c' >>>| id |||- base <<< 'g' >>>| id+ base <<< 'a' >>> id1 |||+ base <<< 'u' >>> id1 |||+ base <<< 'c' >>> id1 |||+ base <<< 'g' >>> id1 p = tabulated2 $- basepair <<< ('a', 'u') >>>|| id2 |||- basepair <<< ('u', 'a') >>>|| id2 |||- basepair <<< ('c', 'g') >>>|| id2 |||- basepair <<< ('g', 'c') >>>|| id2 |||- basepair <<< ('g', 'u') >>>|| id2 |||- basepair <<< ('u', 'g') >>>|| id2+ basepair <<< ('a', 'u') >>> id2 |||+ basepair <<< ('u', 'a') >>> id2 |||+ basepair <<< ('c', 'g') >>> id2 |||+ basepair <<< ('g', 'c') >>> id2 |||+ basepair <<< ('g', 'u') >>> id2 |||+ basepair <<< ('u', 'g') >>> id2 + rewriteKnot1 :: Dim2 rewriteKnot1 [p1,p2,k1,k2] = ([k1,p1],[p2,k2]) k = tabulated2 $- knot1 <<< p ~~~|| k >>>|| rewriteKnot1 |||- knot2 <<< p >>>|| id2+ yieldSize2 (1,Nothing) (1,Nothing) $+ knot1 <<< p ~~~ k >>> rewriteKnot1 |||+ knot2 <<< p >>> id2 z = mk inp tabulated1 = table1 z
tests/ADP/Tests/RGExampleDim2.hs view
@@ -1,264 +1,251 @@-{-# 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] +{-# 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.+-}+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.All+import ADP.Multi.Rewriting.All+ +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 :: RG_Algebra Char answer -> String -> [answer]+rgknot algebra inp =+ 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 $+ yieldSize2 (0,Nothing) (0,Nothing) $+ 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 $+ yieldSize2 (1,Nothing) (1,Nothing) $+ 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
+ tests/ADP/Tests/RGExampleStar.hs view
@@ -0,0 +1,221 @@+{-# 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).+Also, the empty string is used instead of EPS.++The purpose is to have a better relation to the examples in the thesis.+-}+module ADP.Tests.RGExampleStar 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+ + +type RG_Algebra alphabet answer = (+ [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+ [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.***)++data Start = Nil+ | Left' Start Start+ | Pair Start Start Start+ | Knot Start Start Start Start Start Start+ | Knot1 Start Start+ | Knot2 Start+ | BasePair (String, String)+ | Base String+ 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 ++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]++-- 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 b = (["."], [b])+ 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 =+ let + (nil,left,pair,knot,knot1,knot2,basepair,base,h) = algebra+ + rewritePair, rewriteKnot :: Dim1 + + rewritePair [p1,p2,s1,s2] = [p1,s1,p2,s2]+ rewriteKnot [k11,k12,k21,k22,s1,s2,s3,s4] = [k11,s1,k21,s2,k12,s3,k22,s4]+ + s = tabulated1 $+ yieldSize1 (0,Nothing) $+ nil <<< "" >>> id1 |||+ left <<< b ~~~ s >>> id1 |||+ pair <<< p ~~~ s ~~~ s >>> rewritePair |||+ knot <<< k ~~~ k ~~~ s ~~~ s ~~~ s ~~~ s >>> rewriteKnot+ ... h+ + b = tabulated1 $+ base <<< "a" >>> id1 |||+ base <<< "u" >>> id1 |||+ base <<< "c" >>> id1 |||+ base <<< "g" >>> id1+ + p = tabulated2 $+ basepair <<< ("a", "u") >>> id2 |||+ basepair <<< ("u", "a") >>> id2 |||+ basepair <<< ("c", "g") >>> id2 |||+ basepair <<< ("g", "c") >>> id2 |||+ basepair <<< ("g", "u") >>> id2 |||+ basepair <<< ("u", "g") >>> id2+ + rewriteKnot1 :: Dim2+ rewriteKnot1 [p1,p2,k1,k2] = ([k1,p1],[p2,k2])+ + k = tabulated2 $+ yieldSize2 (1,Nothing) (1,Nothing) $+ knot1 <<< p ~~~ k >>> rewriteKnot1 |||+ knot2 <<< p >>> id2+ + z = mk inp+ tabulated1 = table1 z+ tabulated2 = table2 z+ + in axiom z s
− tests/ADP/Tests/RIGExample.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE ImplicitParams #-} - -{- Models the RNA-RNA interaction grammar (RIG) from - -"A grammatical approach to RNA–RNA interaction prediction" by Kato et al., 2009 - -Specifically, example 3 from page 5. - --} -module ADP.Tests.RIGExample where - -import ADP.Multi.SimpleParsers -import ADP.Multi.Combinators -import ADP.Multi.Tabulation -import ADP.Multi.Helpers -import ADP.Multi.Rewriting - -type RIG_Algebra alphabet answer = ( - (EPS,EPS) -> answer, -- nil - alphabet -> answer, -- base - (alphabet,alphabet) -> answer, -- basepair - answer -> answer -> answer, -- sb1L - answer -> answer -> answer, -- sb1R - answer -> answer -> answer, -- sb2L - answer -> answer -> answer, -- sb2R - answer -> answer -> answer, -- ib1 - answer -> answer -> answer, -- ib2 - answer -> answer -> answer, -- eb - answer -> answer -> answer -- w - ) - - - -rig :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 - -> YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 - -> RIG_Algebra Char answer -> (String,String) -> [answer] -rig yieldAlg1 rangeAlg1 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 ?yieldAlg1 = yieldAlg1 - ?rangeAlg1 = rangeAlg1 - ?yieldAlg2 = yieldAlg2 - ?rangeAlg2 = rangeAlg2 - in let - - (nil,base,basepair,sb1L,sb1R,sb2L,sb2R,ib1,ib2,eb,w) = algebra - - rewriteSb1L [b,a1,a2] = ([b,a1],[a2]) - rewriteSb1R [b,a1,a2] = ([a1,b],[a2]) - rewriteSb2L [b,a1,a2] = ([a1],[b,a2]) - rewriteSb2R [b,a1,a2] = ([a1],[a2,b]) - rewriteIb1 [p1,p2,a1,a2] = ([p1,a1,p2],[a2]) - rewriteIb2 [p1,p2,a1,a2] = ([a1],[p1,a2,p2]) - rewriteEb [p1,p2,a1,a2] = ([p1,a1],[a2,p2]) - rewriteW [a11,a12,a21,a22] = ([a11,a21],[a22,a12]) - a = tabulated2 $ - nil <<< (EPS,EPS) >>>|| id2 ||| - sb1L <<< b ~~~| a >>>|| rewriteSb1L ||| - sb1R <<< b ~~~| a >>>|| rewriteSb1R ||| - sb2L <<< b ~~~| a >>>|| rewriteSb2L ||| - sb2R <<< b ~~~| a >>>|| rewriteSb2R ||| - ib1 <<< p ~~~| a >>>|| rewriteIb1 ||| - ib2 <<< p ~~~| a >>>|| rewriteIb2 ||| - eb <<< p ~~~| a >>>|| rewriteEb ||| - w <<< a ~~~| a >>>|| rewriteW - -- FIXME Won't work due to recursion and min yield of aa = 0 - -- Is this grammar actually semantically unambigous?? - - p = tabulated2 $ - basepair <<< ('a', 'u') >>>|| id2 ||| - basepair <<< ('u', 'a') >>>|| id2 ||| - basepair <<< ('c', 'g') >>>|| id2 ||| - basepair <<< ('g', 'c') >>>|| id2 ||| - basepair <<< ('g', 'u') >>>|| id2 ||| - basepair <<< ('u', 'g') >>>|| id2 - - b = tabulated1 $ - base <<< 'a' >>>| id ||| - base <<< 'u' >>>| id ||| - base <<< 'c' >>>| id ||| - base <<< 'g' >>>| id - - z = mkTwoTrack inp1 inp2 - tabulated1 = table1 z - tabulated2 = table2 z - - in axiomTwoTrack z inp1 inp2 a
tests/ADP/Tests/Suite.hs view
@@ -1,148 +1,171 @@-{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Data.Monoid (mempty) - -import Test.HUnit -import Test.QuickCheck - -import Data.Char (toLower) -import Data.List - -import ADP.Multi.Rewriting.Explicit ---import ADP.Multi.Rewriting.ConstraintSolver -import qualified ADP.Tests.RGExample as RG -import qualified ADP.Tests.RGExampleDim2 as RGDim2 -import qualified ADP.Tests.CopyExample as Copy -import qualified ADP.Tests.CopyTwoTrackExample as CopyTT -import qualified ADP.Tests.NestedExample as Nested -import qualified ADP.Tests.OneStructureExample as One -import qualified ADP.Tests.ZeroStructureTwoBackbonesExample as ZeroTT - -import ADP.Multi.Rewriting.Tests.YieldSize - -main :: IO () -main = defaultMainWithOpts - [ - testGroup "Property tests" [ - testGroup "Yield size" [ - testProperty "map size" prop_infoMapSize, - testProperty "map elements" prop_infoMapElements, - testProperty "yield size" prop_yieldSizeDim2 - ] - ], - testGroup "System tests" [ - testCase "finds all reference structures" testRgSimpleCompleteness, - --testCase "finds pseudoknot reference structure" testRgRealPseudoknot, - testCase "tests associative function with max basepairs" testRgSimpleBasepairs, - testProperty "produces copy language" prop_copyLanguage, - testProperty "produces copy language (two track)" prop_copyLanguageTT, - testProperty "produces nested rna" prop_nestedRna, - testProperty "produces 1-structure rna" prop_oneStructureRna, - testProperty "produces RG rna" prop_rgRna, - testProperty "produces RG (dim2) rna" prop_rgDim2Rna, - testProperty "produces 0-structure over two backbones rna" prop_zeroStructureTwoBackbonesRna - ] - ] - mempty { - ropt_test_options = Just mempty { - topt_maximum_generated_tests = Just 100 - } - } - -rg :: RG.RG_Algebra Char answer -> String -> [answer] -rg = RG.rgknot determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 - -rgDim2 :: RGDim2.RG_Algebra Char answer -> String -> [answer] -rgDim2 = RGDim2.rgknot determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 - --- https://github.com/neothemachine/rna/wiki/Example -testRgSimpleCompleteness = - let inp = "agcgu" - referenceStructures = [ - ".....", - ".()..", - "...()", - "..().", - ".()()", - ".(..)", - ".(())", - "(...)", - "(().)", - "(.())" - ] - result = rg 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 -testRgSimpleBasepairs = - let inp = "agcgu" - [maxBasepairs] = rg RG.maxBasepairs inp - in maxBasepairs @?= 2 - --- http://www.ekevanbatenburg.nl/PKBASE/PKB00279.HTML --- This test runs quite long and should only be run manually if needed. -testRgRealPseudoknot = - let inp = map toLower "CAAUUUUCUGAAAAUUUUCAC" - referenceStructure = ".(((((..[[[))))).]]]." - referenceStructure2 = ".[[[[[..(((]]]]].)))." - result = rg 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 - -prop_copyLanguage (CopyLangString w) = - let result = Copy.copyGr determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 - Copy.prettyprint (w ++ w) - in result == [w ++ w] - -prop_copyLanguageTT (CopyLangString w) = - let result = CopyTT.copyTTGr determineYieldSize2 constructRanges2 CopyTT.prettyprint (w,w) - in result == [(w,w)] - -prop_nestedRna (RNAString w) = - let results = Nested.nested determineYieldSize1 constructRanges1 Nested.prettyprint w - in not (null results) && all (\(_,result) -> result == w) results - -prop_oneStructureRna (RNAString w) = - let results = One.oneStructure determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 - One.prettyprint2 w - in not (null results) && all (\[result] -> result == w) results - -prop_rgRna (RNAString w) = - let results = rg RG.prettyprint w - in not (null results) && all (\(_,[result]) -> result == w) results - -prop_rgDim2Rna (RNAString w) = - let results = rgDim2 RGDim2.prettyprint w - resultsDim1 = rg RG.prettyprint w - in results == resultsDim1 - --- 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 -prop_zeroStructureTwoBackbonesRna (RNAString w) = - let results = ZeroTT.zeroStructureTwoBackbones - determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 - ZeroTT.enum (w,w) - in not (null results) - - -newtype CopyLangString = CopyLangString String deriving (Show) -instance Arbitrary CopyLangString where - arbitrary = genAlphabetString CopyLangString "ab" - -newtype RNAString = RNAString String deriving (Show) -instance Arbitrary RNAString where - arbitrary = genAlphabetString RNAString "agcu" - --- returns a small test string consisting of letters from an alphabet -genAlphabetString typ alph = - sized $ \n -> - do s <- mapM (\_ -> elements alph) [0..round (sqrt (fromIntegral n))] - return $ typ s +{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Test.Framework +import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Data.Monoid (mempty)++import Test.HUnit+import Test.QuickCheck++import Data.Char (toLower)++import qualified ADP.Tests.RGExample as RG+import qualified ADP.Tests.RGExampleDim2 as RGDim2+import qualified ADP.Tests.RGExampleStar as RGStar+import qualified ADP.Tests.CopyExample as Copy+import qualified ADP.Tests.CopyTwoTrackExample as CopyTT+import qualified MCFG.MCFG as MCFG+import qualified ADP.Tests.NestedExample as Nested+import qualified ADP.Tests.OneStructureExample as One+import qualified ADP.Tests.ZeroStructureTwoBackbonesExample as ZeroTT++import ADP.Multi.Rewriting.Tests.YieldSize++main :: IO ()+main = defaultMainWithOpts+ [+ testGroup "Property tests" [+ testGroup "Yield size" [+ testProperty "map size" prop_infoMapSize,+ testProperty "map elements" prop_infoMapElements,+ testProperty "yield size" prop_yieldSizeDim2+ ]+ ],+ testGroup "System tests" [+ testCase "finds all reference structures" testRgSimpleCompleteness,+ --testCase "finds pseudoknot reference structure" testRgRealPseudoknot,+ testCase "tests associative function with max basepairs" testRgSimpleBasepairs,+ testProperty "produces copy language" prop_copyLanguage,+ testProperty "produces same derivation trees for copy language grammar" prop_copyLanguageDerivation,+ testProperty "produces copy language (two track)" prop_copyLanguageTT,+ testProperty "produces nested rna" prop_nestedRna,+ testProperty "produces 1-structure rna" prop_oneStructureRna,+ testProperty "produces RG rna" prop_rgRna,+ testProperty "produces RG (dim2) rna" prop_rgDim2Rna,+ testProperty "produces RG (star version) rna" prop_rgStarRna,+ testProperty "produces 0-structure over two backbones rna" prop_zeroStructureTwoBackbonesRna+ ]+ ]+ mempty {+ ropt_test_options = Just mempty {+ 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+testRgSimpleCompleteness =+ let inp = "agcgu"+ referenceStructures = [+ ".....",+ ".()..",+ "...()",+ "..().",+ ".()()",+ ".(..)",+ ".(())",+ "(...)",+ "(().)",+ "(.())"+ ]+ result = rg 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+testRgSimpleBasepairs =+ let inp = "agcgu"+ [maxBasepairs] = rg RG.maxBasepairs inp+ in maxBasepairs @?= 2++-- http://www.ekevanbatenburg.nl/PKBASE/PKB00279.HTML+-- This test runs quite long and should only be run manually if needed.+testRgRealPseudoknot =+ let inp = map toLower "CAAUUUUCUGAAAAUUUUCAC" + referenceStructure = ".(((((..[[[))))).]]]."+ referenceStructure2 = ".[[[[[..(((]]]]].)))."+ result = rg 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++prop_copyLanguage (CopyLangString w) =+ let result = Copy.copyGr Copy.prettyprint (w ++ w)+ in result == [w ++ w]++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+prop_copyLanguageDerivation (CopyLangString w) =+ let [resultADP] = Copy.copyGr Copy.derivation (w ++ w)+ [resultMCFG] = MCFG.parse Copy.mcfg (map MCFG.T (w ++ w))+ in MCFG.consistent resultMCFG && equivalentTrees resultADP resultMCFG++-- checks if two derivation trees are the same (same rules applied)+equivalentTrees :: MCFG.Derivation -> MCFG.Derivation -> Bool+equivalentTrees t1 t2 =+ let MCFG.Derivation _ rule1 children1 = t1+ MCFG.Derivation _ rule2 children2 = t2+ children = zip children1 children2+ in rule1 == rule2 && + length children1 == length children2 &&+ all (\(c1,c2) -> equivalentTrees c1 c2) children+ +prop_nestedRna (RNAString w) =+ let results = Nested.nested Nested.prettyprint w+ in not (null results) && all (\(_,result) -> result == w) results+ +prop_oneStructureRna (RNAString w) =+ let results = One.oneStructure One.prettyprint2 w+ in not (null results) && all (\[result] -> result == w) results+ +prop_rgRna (RNAString w) =+ let results = rg RG.prettyprint w+ in not (null results) && all (\(_,[result]) -> result == w) results+ +prop_rgDim2Rna (RNAString w) =+ let results = rgDim2 RGDim2.prettyprint w+ resultsDim1 = rg RG.prettyprint w+ in results == resultsDim1+ +prop_rgStarRna (RNAString w) =+ let results = rgStar RGStar.prettyprint w+ resultsRef = rg 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 +prop_zeroStructureTwoBackbonesRna (RNAString w) =+ let results = ZeroTT.zeroStructureTwoBackbones ZeroTT.enum (w,w)+ in not (null results)++ +newtype CopyLangString = CopyLangString String deriving (Show)+instance Arbitrary CopyLangString where+ arbitrary = genAlphabetString CopyLangString "ab"+ +newtype RNAString = RNAString String deriving (Show)+instance Arbitrary RNAString where+ arbitrary = genAlphabetString RNAString "agcu"++-- returns a small test string consisting of letters from an alphabet+genAlphabetString typ alph =+ sized $ \n ->+ do s <- mapM (\_ -> elements alph) [0..round (sqrt (fromIntegral n))]+ return $ typ s
+ tests/ADP/Tests/TermExample.hs view
@@ -0,0 +1,89 @@+module ADP.Tests.TermExample where + +import ADP.Multi.All +import ADP.Multi.Rewriting.All + +type Term_Algebra alphabet answer = ( + answer -> answer, + answer -> answer, -- sym + alphabet -> answer -> answer, -- sym1 + alphabet -> answer, -- sym2 + alphabet -> alphabet -> alphabet -> alphabet, -- escape + answer -> alphabet -> answer -> alphabet -> answer, -- fun + answer -> answer, -- single + answer -> alphabet -> answer -> answer -- split + ) + +prettyprint :: Term_Algebra Char String +prettyprint = (wrap,sym,sym1,sym2,escape,fun,single,split) where + wrap s = s + sym s = s + sym1 c s = [c] ++ s + sym2 c = [c] + escape _ b _ = b + fun i _ a _ = i ++ ['('] ++ a ++ [')'] + single s = s + split s _ a = s ++ [','] ++ a + +tikztree :: Term_Algebra Char String +tikztree = (wrap,sym,sym1,sym2,escape,fun,single,split) where + wrap s = "\\" ++ s ++ ";" + sym s = "node{" ++ s ++ "}" + sym1 c s = [c] ++ s + sym2 c = [c] + escape _ b _ = b + fun i _ a _ = i ++ a + single s = "child{" ++ s ++ "}" + split s _ a = "child{" ++ s ++ "}" ++ a + +qtree :: (String -> String) -- custom symbol formatting + -> Term_Algebra Char String +qtree format = (wrap,sym,sym1,sym2,escape,fun,single,split) where + wrap s = "\\Tree " ++ s + sym s = format s + sym1 c s = [c] ++ s + sym2 c = [c] + escape _ b _ = b + fun i _ a _ = "[." ++ i ++ " " ++ a ++ " ]" + single s = s + split s _ a = s ++ " " ++ a + + +term :: Term_Algebra Char answer -> String -> [answer] +term algebra inp = + let + (wrap,sym,sym1,sym2,escape,fun,single,split) = algebra + + s'= wrap <<< s >>> id1 + + s = tabulated $ + i ||| + fun <<< i ~~~ '(' ~~~ a ~~~ ')' >>> id1 + + i = tabulated $ + sym <<< i' >>> id1 + + i' = tabulated $ + yieldSize1 (1,Nothing) $ + sym1 <<< i1 ~~~ i' >>> id1 ||| + sym1 <<< i2 ~~~ i' >>> id1 ||| + sym2 <<< i1 >>> id1 ||| + sym2 <<< i2 >>> id1 + + i1= tabulated $ + anycharExcept ['(', ')', ','] + + i2= tabulated $ + escape <<< '\'' ~~~ '(' ~~~ '\'' >>> id1 ||| + escape <<< '\'' ~~~ ')' ~~~ '\'' >>> id1 ||| + escape <<< '\'' ~~~ ',' ~~~ '\'' >>> id1 + + a = tabulated $ + yieldSize1 (1,Nothing) $ + single <<< s >>> id1 ||| + split <<< s ~~~ ',' ~~~ a >>> id1 + + z = mk inp + tabulated = table1 z + + in axiom z s'
tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs view
@@ -1,169 +1,162 @@-{-# LANGUAGE ImplicitParams #-} - -{- This example implements the grammar for 0-structures over two backbones from - "Topology of RNA-RNA interaction structures" by Andersen et al., 2012 - - It uses the 1-structure grammar from - "Topology and prediction of RNA pseudoknots" by Reidys et al., 2011 - by importing it from ADP.Tests.OneStructureExample --} -module ADP.Tests.ZeroStructureTwoBackbonesExample where - -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 -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) --- 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 - answerOne -> answerOne -> answer -> answer -> answer, -- t1 - answerOne -> answerOne -> answer -> answer -> answer, -- t2 - answerOne -> answerOne -> answer -> answer -> answer, -- t3 - answerOne -> answerOne -> answerOne -> answerOne -> answer -> answer -> answer -> answer, -- t4 - answerOne -> answerOne -> answerOne -> answerOne -> answerOne -> answerOne -> answer -> answer -> answer -> answer -> answer, -- t5 - answerOne -> answerOne -> answerOne -> answerOne -> answer -> answer -> answer -> answer, -- t6 - 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 - ) - -data T = OneStructure One.T - | I1 T One.T One.T - | I2 One.T One.T - | PT1 T T - | PT2 T T - | T1 One.T One.T T T - | T2 One.T One.T T T - | T3 One.T One.T T T - | T4 One.T One.T One.T One.T T T T - | T5 One.T One.T One.T One.T One.T One.T T T T T - | T6 One.T One.T One.T One.T T T T - | T7 One.T One.T One.T One.T T T T - | Hs2 One.T One.T T T - | H1 T T T T - | H2 T - | G1 T One.T One.T T - | G2 T - | Ub1 T T - | Ub2 - | Base Char - | BasePair (Char, Char) - deriving (Eq, Show) - -enum :: ZeroStructureTwoBackbones_Algebra Char One.T T -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). --} -zeroStructureTwoBackbones :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 - -> YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 - -> ZeroStructureTwoBackbones_Algebra Char answerOne answer -> (String,String) -> [answer] -zeroStructureTwoBackbones yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra (inp1,inp2) = - let z = mkTwoTrack inp1 inp2 - grammar = zeroStructureTwoBackbonesGrammar yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra z - in axiomTwoTrack z inp1 inp2 grammar - -zeroStructureTwoBackbonesGrammar :: YieldAnalysisAlgorithm Dim1 -> RangeConstructionAlgorithm Dim1 - -> YieldAnalysisAlgorithm Dim2 -> RangeConstructionAlgorithm Dim2 - -> ZeroStructureTwoBackbones_Algebra Char answerOne answer -> Array Int Char -> RichParser Char answer -zeroStructureTwoBackbonesGrammar yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 algebra z = - -- 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 - - (oneStructureAlgebra,i1,i2,pt1,pt2,t1,t2,t3,t4,t5,t6,t7,hs2,h1,h2,g1,g2,ub1,ub2,base,basepair,h') = algebra - - one = One.oneStructureGrammar yieldAlg1 rangeAlg1 yieldAlg2 rangeAlg2 oneStructureAlgebra z - - rewriteI1 [pt1,pt2,one1,one2] = ([pt1,one1],[one2,pt2]) - rewriteI2 [one1,one2] = ([one1],[one2]) - i = tabulated2 $ - i1 <<< pt ~~~ one ~~~ one >>>|| rewriteI1 ||| - i2 <<< one ~~~ one >>>|| rewriteI2 - - rewritePT1 [t1,t2,i1,i2] = ([i1,t1],[t2,i2]) - rewritePT2 [h1,h2,i1,i2] = ([i1,h1],[h2,i2]) - pt = tabulated2 $ - pt1 <<< t ~~~|| i >>>|| rewritePT1 ||| - pt2 <<< h ~~~|| i >>>|| rewritePT2 - - rewriteT1 [one1,one2,hs11,hs12,hs21,hs22] = ([hs11,one1,hs21],[hs12,one2,hs22]) - rewriteT2 [one1,one2,g1,g2,hs1,hs2] = ([g1,one1,hs1,one2,g2],[hs2]) - rewriteT3 [one1,one2,hs1,hs2,g1,g2] = ([hs1],[g1,one1,hs2,one2,g2]) - rewriteT4 [one1,one2,one3,one4,g11,g12,hs1,hs2,g21,g22] = ([g11,one1,hs1,one2,g12],[g21,one3,hs2,one4,g22]) - rewriteT5 [one1,one2,one3,one4,one5,one6,g11,g12,hs11,hs12,hs21,hs22,g21,g22] - = ([g11,one1,hs11,one2,hs21,one3,g12],[g21,one4,hs12,one5,hs22,one6,g22]) - 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 ||| - 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 ||| - t7 <<< one ~~~ one ~~~ one ~~~ one ~~~ hs ~~~ hs ~~~ g >>>|| rewriteT7 - - rewriteHs2 [one1,one2,h1,h2,hs1,hs2] = ([h1,one1,hs1],[hs2,one2,h2]) - hs = tabulated2 $ - h ||| - hs2 <<< one ~~~ one ~~~ h ~~~|| hs >>>|| rewriteHs2 - - rewriteH1 [p1,p2,ub1,ub2,h1,h2] = ([p1,ub1,h1],[h2,ub2,p2]) - h = tabulated2 $ - h1 <<< p ~~~ ub ~~~ ub ~~~|| h >>>|| rewriteH1 ||| - h2 <<< p >>>|| id2 - - rewriteG1 [p1,p2,one1,one2,g1,g2] = ([p1,one1,g1],[g2,one2,p2]) - g = tabulated2 $ - g1 <<< p ~~~ one ~~~ one ~~~|| g >>>|| rewriteG1 ||| - g2 <<< p >>>|| id2 - - ub = tabulated1 $ - ub1 <<< b ~~~| ub >>>| id ||| - ub2 <<< EPS >>>| id - - b = tabulated1 $ - base <<< 'a' >>>| id ||| - base <<< 'u' >>>| id ||| - base <<< 'c' >>>| id ||| - base <<< 'g' >>>| id - - p = tabulated2 $ - basepair <<< ('a', 'u') >>>|| id2 ||| - basepair <<< ('u', 'a') >>>|| id2 ||| - basepair <<< ('c', 'g') >>>|| id2 ||| - basepair <<< ('g', 'c') >>>|| id2 ||| - basepair <<< ('g', 'u') >>>|| id2 ||| - basepair <<< ('u', 'g') >>>|| id2 - - tabulated1 = table1 z - tabulated2 = table2 z - +{- This example implements the grammar for 0-structures over two backbones from+ "Topology of RNA-RNA interaction structures" by Andersen et al., 2012+ + It uses the 1-structure grammar from+ "Topology and prediction of RNA pseudoknots" by Reidys et al., 2011+ by importing it from ADP.Tests.OneStructureExample+-}+module ADP.Tests.ZeroStructureTwoBackbonesExample where++import Data.Array++import ADP.Multi.All+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)+-- 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+ answerOne -> answerOne -> answer -> answer -> answer, -- t1+ answerOne -> answerOne -> answer -> answer -> answer, -- t2+ answerOne -> answerOne -> answer -> answer -> answer, -- t3+ answerOne -> answerOne -> answerOne -> answerOne -> answer -> answer -> answer -> answer, -- t4+ answerOne -> answerOne -> answerOne -> answerOne -> answerOne -> answerOne -> answer -> answer -> answer -> answer -> answer, -- t5+ answerOne -> answerOne -> answerOne -> answerOne -> answer -> answer -> answer -> answer, -- t6+ 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+ )++data T = OneStructure One.T+ | I1 T One.T One.T+ | I2 One.T One.T+ | PT1 T T+ | PT2 T T+ | T1 One.T One.T T T+ | T2 One.T One.T T T+ | T3 One.T One.T T T+ | T4 One.T One.T One.T One.T T T T+ | T5 One.T One.T One.T One.T One.T One.T T T T T+ | T6 One.T One.T One.T One.T T T T+ | T7 One.T One.T One.T One.T T T T+ | Hs2 One.T One.T T T+ | H1 T T T T+ | H2 T+ | G1 T One.T One.T T+ | G2 T + | Ub1 T T+ | Ub2+ | Base Char+ | BasePair (Char, Char)+ deriving (Eq, Show)++enum :: ZeroStructureTwoBackbones_Algebra Char One.T T+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).+-}+zeroStructureTwoBackbones :: ZeroStructureTwoBackbones_Algebra Char answerOne answer -> (String,String) -> [answer]+zeroStructureTwoBackbones algebra (inp1,inp2) =+ let z = mkTwoTrack inp1 inp2+ grammar = zeroStructureTwoBackbonesGrammar algebra z+ in axiomTwoTrack z inp1 inp2 grammar++zeroStructureTwoBackbonesGrammar :: ZeroStructureTwoBackbones_Algebra Char answerOne answer -> Array Int Char -> RichParser Char answer+zeroStructureTwoBackbonesGrammar algebra z =+ let + (oneStructureAlgebra,i1,i2,pt1,pt2,t1,t2,t3,t4,t5,t6,t7,hs2,h1,h2,g1,g2,ub1,ub2,base,basepair,h') = algebra+ + one = One.oneStructureGrammar oneStructureAlgebra z+ + rewriteI1, rewriteI2, rewritePT1, rewritePT2 :: Dim2+ + rewriteI1 [pt1,pt2,one1,one2] = ([pt1,one1],[one2,pt2])+ rewriteI2 [one1,one2] = ([one1],[one2])+ i = tabulated2 $+ i1 <<< pt ~~~ one ~~~ one >>> rewriteI1 |||+ i2 <<< one ~~~ one >>> rewriteI2+ + rewritePT1 [t1,t2,i1,i2] = ([i1,t1],[t2,i2])+ rewritePT2 [h1,h2,i1,i2] = ([i1,h1],[h2,i2])+ pt = tabulated2 $+ yieldSize2 (1,Nothing) (1,Nothing) $+ pt1 <<< t ~~~ i >>> rewritePT1 |||+ pt2 <<< h ~~~ i >>> rewritePT2+ + rewriteT1, rewriteT2, rewriteT3, rewriteT4, rewriteT5, rewriteT6, rewriteT7 :: Dim2+ + rewriteT1 [one1,one2,hs11,hs12,hs21,hs22] = ([hs11,one1,hs21],[hs12,one2,hs22])+ rewriteT2 [one1,one2,g1,g2,hs1,hs2] = ([g1,one1,hs1,one2,g2],[hs2])+ rewriteT3 [one1,one2,hs1,hs2,g1,g2] = ([hs1],[g1,one1,hs2,one2,g2])+ rewriteT4 [one1,one2,one3,one4,g11,g12,hs1,hs2,g21,g22] = ([g11,one1,hs1,one2,g12],[g21,one3,hs2,one4,g22])+ rewriteT5 [one1,one2,one3,one4,one5,one6,g11,g12,hs11,hs12,hs21,hs22,g21,g22]+ = ([g11,one1,hs11,one2,hs21,one3,g12],[g21,one4,hs12,one5,hs22,one6,g22])+ 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 |||+ 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 |||+ t7 <<< one ~~~ one ~~~ one ~~~ one ~~~ hs ~~~ hs ~~~ g >>> rewriteT7+ + rewriteHs2, rewriteH1, rewriteG1 :: Dim2+ + rewriteHs2 [one1,one2,h1,h2,hs1,hs2] = ([h1,one1,hs1],[hs2,one2,h2])+ hs = tabulated2 $+ yieldSize2 (1,Nothing) (1,Nothing) $+ h |||+ hs2 <<< one ~~~ one ~~~ h ~~~ hs >>> rewriteHs2+ + rewriteH1 [p1,p2,ub1,ub2,h1,h2] = ([p1,ub1,h1],[h2,ub2,p2])+ h = tabulated2 $+ yieldSize2 (1,Nothing) (1,Nothing) $+ h1 <<< p ~~~ ub ~~~ ub ~~~ h >>> rewriteH1 |||+ h2 <<< p >>> id2+ + rewriteG1 [p1,p2,one1,one2,g1,g2] = ([p1,one1,g1],[g2,one2,p2])+ g = tabulated2 $+ yieldSize2 (1,Nothing) (1,Nothing) $+ g1 <<< p ~~~ one ~~~ one ~~~ g >>> rewriteG1 |||+ g2 <<< p >>> id2+ + ub = tabulated1 $+ yieldSize1 (0,Nothing) $+ ub1 <<< b ~~~ ub >>> id1 |||+ ub2 <<< EPS >>> id1+ + b = tabulated1 $+ base <<< 'a' >>> id1 |||+ base <<< 'u' >>> id1 |||+ base <<< 'c' >>> id1 |||+ base <<< 'g' >>> id1+ + p = tabulated2 $+ basepair <<< ('a', 'u') >>> id2 |||+ basepair <<< ('u', 'a') >>> id2 |||+ basepair <<< ('c', 'g') >>> id2 |||+ basepair <<< ('g', 'c') >>> id2 |||+ basepair <<< ('g', 'u') >>> id2 |||+ basepair <<< ('u', 'g') >>> id2+ + tabulated1 = table1 z+ tabulated2 = table2 z+ in i
+ tests/MCFG/MCFG.hs view
@@ -0,0 +1,118 @@+ +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 + +import qualified Data.Map as M +import Control.Monad.State.Strict +import Data.List ( inits, tails ) + +-- | * data type for grammar + +data Nonterminal = N { arity :: Int, name :: String } + deriving ( Eq, Ord, Show ) + +newtype Terminal = T Char + deriving ( Eq, Ord, Show ) + +data MCFG = MCFG + { start :: Nonterminal + , rules :: [ Rule ] } + deriving ( Eq, Ord, Show ) + +data Rule = Rule + { lhs :: Nonterminal + , function :: [[ Either (Int,Int) Terminal ]] + , rhs :: [ Nonterminal ] + } + deriving ( Eq, Ord, Show ) + +-- | * data types for derivation trees + +data Derivation = + Derivation { result :: [[ Terminal ]] + , apply :: Rule + , children :: [ Derivation ] + } + deriving ( Show ) + +consistent :: Derivation -> Bool +consistent d = + and ( map consistent $ children d ) + && result d == do + xs <- function ( apply d ) + return $ do + x <- xs + case x of + Right t -> [ t ] + Left (i,j) -> + result ( children d !! i ) !! j + +-- | * CYK tabled parser + + +parse :: MCFG -> [ Terminal ] -> [ Derivation ] +parse g w = fst $ cyk g w + + +-- | speichert jeweils alle Ableitungen. +-- später dann: die beste Ableitung und ihre Kosten. +type Table = M.Map ( Nonterminal, [[Terminal]] ) + [ Derivation ] + +-- | Die Tabelle ist nur polynomiell groß, weil die +-- Schlüssel aus Teilwörtern der Eingabe bestehen + +cyk :: MCFG -> [ Terminal ] -> ( [Derivation], Table ) +cyk g w = flip runState M.empty + $ build (rules g) (start g , [w] ) + + +build :: [ Rule ] + -> ( Nonterminal, [[Terminal]] ) + -> State Table [ Derivation ] +build rules (var, ws) = do + t <- get + case M.lookup ( var, ws ) t of + Just r -> return r + Nothing -> do + dss <- sequence $ do + r <- rules + guard $ var == lhs r + sub <- forM ( zip ( function r ) ws ) splits + let c :: M.Map ( Int,Int ) [Terminal] + c = M.fromListWith ( error "not linear") + $ concat sub + return $ do + css <- forM ( zip (rhs r ) [0..] ) + $ \ (var' @ (N a _), i) -> do + let ws' = for [ 0 .. a-1 ] $ \ j -> c M.! (i,j) + build rules ( var' , ws' ) + return $ for ( combine css ) $ \ cs -> + Derivation { result = ws, apply = r, children = cs } + let ds :: [ Derivation ] + ds = concat dss + modify $ M.insert (var, ws) ds + return ds + +splits :: Eq b + => ([Either a b], [b]) + -> [[(a, [b])]] +splits (f, w) = case (f,w) of + ( [], [] ) -> return [] + (Right x : f', y : w') | x == y -> + splits (f', w') + (Left a : f', _) -> do + ( pre, post ) <- zip ( inits w ) ( tails w ) + later <- splits (f', post) + return $ ( a , pre ) : later + _ -> [] + +for :: [a] -> (a -> b) -> [b] +for = flip map + +combine :: [[a]] -> [[a]] +combine = foldr ( \ xs ys -> do x <- xs ; y <- ys ; return $ x : y ) [[]]