adp-multi (empty) → 0.1.0
raw patch · 22 files changed
+2561/−0 lines, 22 filesdep +HUnitdep +QuickCheckdep +arraysetup-changed
Dependencies added: HUnit, QuickCheck, array, base, containers, criterion, htrace, monadiccp, mtl, random-shuffle, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- adp-multi.cabal +116/−0
- benchmarks/Benchmarks.hs +42/−0
- src/ADP/Multi/Combinators.hs +201/−0
- src/ADP/Multi/Helpers.hs +27/−0
- src/ADP/Multi/Parser.hs +30/−0
- src/ADP/Multi/Rewriting.hs +16/−0
- src/ADP/Multi/Rewriting/ConstraintSolver.hs +297/−0
- src/ADP/Multi/Rewriting/Explicit.hs +347/−0
- src/ADP/Multi/Rewriting/MonadicCpHelper.hs +42/−0
- src/ADP/Multi/Rewriting/YieldSize.hs +70/−0
- src/ADP/Multi/SimpleParsers.hs +108/−0
- src/ADP/Multi/Tabulation.hs +35/−0
- tests/ADP/Multi/Rewriting/Tests/YieldSize.hs +88/−0
- tests/ADP/Tests/Main.hs +68/−0
- tests/ADP/Tests/NestedExample.hs +140/−0
- tests/ADP/Tests/OneStructureExample.hs +214/−0
- tests/ADP/Tests/RGExample.hs +286/−0
- tests/ADP/Tests/RIGExample.hs +88/−0
- tests/ADP/Tests/Suite.hs +148/−0
- tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs +169/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (C) 2012 Maik Riechert++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++The names of its contributors may not be used to endorse or promote products+derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ adp-multi.cabal view
@@ -0,0 +1,116 @@+name: adp-multi +version: 0.1.0 +cabal-version: >= 1.8 +build-type: Simple +author: Maik Riechert +stability: experimental +bug-reports: https://github.com/neothemachine/adp-multi/issues +homepage: http://adp-multi.ruhoh.com +copyright: Maik Riechert, 2012 +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.4.1 +maintainer: Maik Riechert +category: Algorithms, Data Structures, Bioinformatics +synopsis: ADP for multiple context-free languages +description: adp-multi is an implementation of Algebraic Dynamic Programming + for multiple context-free languages. + It is a library based on the original Haskell implementation + and can be considered an unoptimized prototype. + + +source-repository head + type: git + location: git://github.com/neothemachine/adp-multi.git + +Flag buildTests + description: Build test / benchmark executables + default: False + +library + build-depends: base == 4.*, + array == 0.4.*, + containers == 0.5.*, + htrace == 0.1.*, + mtl == 2.1.*, + monadiccp == 0.7.* + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: ADP.Multi.Combinators, + ADP.Multi.Helpers, + ADP.Multi.Parser, + ADP.Multi.Rewriting.ConstraintSolver, + ADP.Multi.Rewriting.Explicit, + ADP.Multi.SimpleParsers, + ADP.Multi.Tabulation + +test-suite MainTestSuite + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base == 4.*, + HUnit == 1.2.*, + QuickCheck == 2.5.*, + test-framework == 0.6.*, + test-framework-quickcheck2 == 0.2.*, + test-framework-hunit == 0.2.*, + random-shuffle == 0.0.4 + hs-source-dirs: src, + tests + ghc-options: -Wall -rtsopts + other-modules: + ADP.Multi.Combinators, + ADP.Multi.Helpers, + ADP.Multi.Parser, + ADP.Multi.Rewriting, + ADP.Multi.Rewriting.ConstraintSolver, + ADP.Multi.Rewriting.Explicit, + ADP.Multi.Rewriting.MonadicCpHelper, + ADP.Multi.Rewriting.Tests.YieldSize, + ADP.Multi.Rewriting.YieldSize, + ADP.Multi.SimpleParsers, + ADP.Multi.Tabulation, + ADP.Tests.Main, + ADP.Tests.NestedExample, + ADP.Tests.OneStructureExample, + ADP.Tests.RGExample, + ADP.Tests.RIGExample, + ADP.Tests.ZeroStructureTwoBackbonesExample + main-is: ADP/Tests/Suite.hs + +executable adp-multi-benchmarks + if flag(buildTests) + build-depends: base == 4.*, + criterion == 0.6.* + else + buildable: False + hs-source-dirs: benchmarks, + src, + tests + ghc-options: -Wall -rtsopts + other-modules: + ADP.Tests.RGExample, + ADP.Tests.NestedExample, + ADP.Tests.RIGExample, + ADP.Tests.OneStructureExample, + ADP.Tests.ZeroStructureTwoBackbonesExample + main-is: Benchmarks.hs + +executable adp-test + if !flag(buildTests) + buildable: False + build-depends: base == 4.* + hs-source-dirs: + src, + tests + ghc-options: -Wall -rtsopts -O0 + main-is: ADP/Tests/Main.hs + other-modules: + ADP.Multi.Rewriting.ConstraintSolver, + ADP.Multi.Rewriting.Explicit, + ADP.Tests.RGExample, + ADP.Tests.NestedExample, + ADP.Tests.RIGExample, + ADP.Tests.OneStructureExample, + ADP.Tests.ZeroStructureTwoBackbonesExample +
+ benchmarks/Benchmarks.hs view
@@ -0,0 +1,42 @@+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"
+ src/ADP/Multi/Combinators.hs view
@@ -0,0 +1,201 @@+{-# 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 [] + )
+ src/ADP/Multi/Helpers.hs view
@@ -0,0 +1,27 @@+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 +mkTwoTrack xs ys = mk (xs ++ ys)
+ src/ADP/Multi/Parser.hs view
@@ -0,0 +1,30 @@+{-# 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
+ src/ADP/Multi/Rewriting.hs view
@@ -0,0 +1,16 @@+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."
+ src/ADP/Multi/Rewriting/ConstraintSolver.hs view
@@ -0,0 +1,297 @@+{-# 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
@@ -0,0 +1,347 @@+{-# 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"
+ src/ADP/Multi/Rewriting/MonadicCpHelper.hs view
@@ -0,0 +1,42 @@+{-# 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/YieldSize.hs view
@@ -0,0 +1,70 @@+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 + in Map.fromList list
+ src/ADP/Multi/SimpleParsers.hs view
@@ -0,0 +1,108 @@+{-# 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
@@ -0,0 +1,35 @@+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
+ tests/ADP/Multi/Rewriting/Tests/YieldSize.hs view
@@ -0,0 +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) ] +
+ tests/ADP/Tests/Main.hs view
@@ -0,0 +1,68 @@+import System.IO (hSetBuffering, stdout, BufferMode (LineBuffering)) +import Data.Char (toLower) +import Control.Monad (forM_) +import qualified ADP.Tests.RGExample as RG +import qualified ADP.Tests.NestedExample as N +import qualified ADP.Tests.CopyExample as C +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 + + +main::IO() +main = do + hSetBuffering stdout LineBuffering + + --forM_ result print + --forM_ result2 print + --forM_ result3 print + --forM_ result4 print + --forM_ result53 print + --forM_ result6 putStrLn + --forM_ result7 print + --forM_ result8 print + --forM_ result9 print + forM_ result10 print+ + where + -- http://www.ekevanbatenburg.nl/PKBASE/PKB00279.HTML + -- struc = ".(((((..[[[))))).]]]." + --inp = map toLower "CAAUUUUCUGAAAAUUUUCAC" + + -- http://www.ekevanbatenburg.nl/PKBASE/PKB00289.HTML + -- struc = "..((((..[[[[)))).....]]]]..." + -- inp = map toLower "ACCGUCGUUCCCGACGUAAAAGGGAUGU" + + -- https://github.com/neothemachine/rna/wiki/Example + inp = "agcguu" + + --inp = map toLower "ACGAUUCAACGU" + + rg = RG.rgknot determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + + result = rg RG.enum inp + result2 = rg RG.maxBasepairs inp + result3 = rg RG.maxKnots inp + result4 = rg RG.prettyprint inp + + result5 = rg (RG.enum RG.*** RG.prettyprint) inp + result51 = rg (RG.prettyprint RG.*** RG.pstree) inp + result52 = rg (RG.prettyprint RG.*** RG.pstreeYield) inp + result53 = rg (RG.prettyprint RG.*** RG.pstreeEval) inp + + nested = N.nested determineYieldSize1 constructRanges1 + result6 = nested (N.pstree) inp + + copy = C.copyGr determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + result7 = copy (C.countABs) "abaaabaa" + + oneStructure = One.oneStructure determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + result8 = oneStructure (One.prettyprint) inp + + zeroStructureTT = ZeroTT.zeroStructureTwoBackbones determineYieldSize1 constructRanges1 determineYieldSize2 constructRanges2 + result9 = zeroStructureTT (ZeroTT.enum) (inp,inp) + + alignment = Alignment.alignmentGr determineYieldSize2 constructRanges2 + result10 = alignment (Alignment.unit Alignment.*** Alignment.count) ("darling","airline")
+ tests/ADP/Tests/NestedExample.hs view
@@ -0,0 +1,140 @@+{-# 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 + +type Nested_Algebra alphabet answer = ( + EPS -> answer, -- nil + answer -> answer -> answer, -- left + answer -> answer -> answer, -- pair + alphabet -> answer -> alphabet -> answer, -- basepair + alphabet -> answer, -- base + [answer] -> [answer] -- h + ) + +-- test using record syntax +data NestedAlgebra alphabet answer = NestedAlgebra { + nil :: EPS -> answer, + left :: answer -> answer -> answer, + pair :: answer -> answer -> answer, + basepair :: alphabet -> answer -> alphabet -> answer, + base :: alphabet -> answer, + h :: [answer] -> [answer] + } + +infixl *** +(***) :: (Eq b, Eq c) => Nested_Algebra a b -> Nested_Algebra a c -> Nested_Algebra a (b,c) +alg1 *** alg2 = (nil,left,pair,basepair,base,h) where + (nil',left',pair',basepair',base',h') = alg1 + (nil'',left'',pair'',basepair'',base'',h'') = alg2 + + nil a = (nil' a, nil'' a) + left (b1,b2) (s1,s2) = (left' b1 s1, left'' b2 s2) + pair (p1,p2) (s1,s2) = (pair' p1 s1, pair'' p2 s2) + basepair a (s1,s2) b = (basepair' a s1 b, basepair'' a s2 b) + base a = (base' a, base'' a) + h xs = [ (x1,x2) | + x1 <- h' [ y1 | (y1,_) <- xs] + , x2 <- h'' [ y2 | (y1,y2) <- xs, y1 == x1] + ] + + +data Start = Nil + | Left' Start Start + | Pair Start Start + | BasePair Char Start Char + | Base Char + deriving (Eq, Show) + +-- without consistency checks +enum :: Nested_Algebra Char Start +enum = (nil,left,pair,basepair,base,h) where + nil _ = Nil + left = Left' + pair = Pair + basepair = BasePair + base = Base + h = id + +enum' :: NestedAlgebra Char Start +enum' = NestedAlgebra { + nil = \ _ -> Nil, -- hmm, this sucks + left = Left', + pair = Pair, + basepair = BasePair, + base = Base, + h = id + } + +maxBasepairs :: Nested_Algebra Char Int +maxBasepairs = (nil,left,pair,basepair,base,h) where + nil _ = 0 + left a b = a + b + pair a b = a + b + basepair _ _ _ = 1 + base _ = 0 + h [] = [] + h xs = [maximum xs] + +-- 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) + pair (pl,pr) (sl,sr) = (pl ++ sl, pr ++ sr) + basepair b1 (sl,sr) b2 = ("(" ++ sl ++ ")", [b1] ++ sr ++ [b2]) + base b = (".", [b]) + h = id + +pstree :: Nested_Algebra Char String +pstree = (nil,left,pair,basepair,base,h) where + nil _ = "\\emptyword" + left b s = nonterm "B" b ++ nonterm "S" s + pair p s = nonterm "P" p ++ nonterm "S" s + basepair b1 s b2 = base b1 ++ nonterm "S" s ++ base b2 + base b = "\\terminal{" ++ [b] ++ "}" + h = id + + 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 + + (nil,left,pair,basepair,base,h) = algebra + + s = tabulated $ + nil <<< EPS >>>| id ||| + left <<< b ~~~| s >>>| id ||| + pair <<< p ~~~| s >>>| id + ... h + + b = tabulated $ + base <<< 'a' >>>| id ||| + base <<< 'u' >>>| id ||| + base <<< 'c' >>>| id ||| + base <<< 'g' >>>| id + + 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 + + z = mk inp + tabulated = table1 z + + in axiom z s
+ tests/ADP/Tests/OneStructureExample.hs view
@@ -0,0 +1,214 @@+{-# 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 + + in i
+ tests/ADP/Tests/RGExample.hs view
@@ -0,0 +1,286 @@+{-# 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.RGExample where++{-+S -> € | BS | P_1 S P_2 S | K_1^1 S K_1^2 S K_2^1 S K_2^2 S+[K_1,K_2] -> [K_1 P_1, P_2 K_2] | [P_1, P_2]+[P_1,P_2] -> [a,u] | [u,a] | [g,c] | [c,g] | [g,u] | [u,g]+B -> a | u | c | g+-}++import 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+ +-- TODO as in CopyExample, use separate answer type for each dimension +type RG_Algebra alphabet answer = (+ 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+ 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 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]++-- 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 :: 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+ + 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+ ... h+ + 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+ + rewriteKnot1 [p1,p2,k1,k2] = ([k1,p1],[p2,k2])+ + k = tabulated2 $+ 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 view
@@ -0,0 +1,88 @@+{-# 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
@@ -0,0 +1,148 @@+{-# 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
+ tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs view
@@ -0,0 +1,169 @@+{-# 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 + + in i