adp-multi 0.2.2 → 0.2.3
raw patch · 18 files changed
+486/−283 lines, 18 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- adp-multi.cabal +3/−1
- src/ADP/Multi/Combinators.hs +0/−1
- src/ADP/Multi/Rewriting/Explicit.hs +71/−81
- src/ADP/Multi/Rewriting/Model.hs +4/−3
- src/ADP/Multi/Rewriting/RangesHelper.hs +53/−55
- tests/ADP/Tests/AlignmentExample.hs +1/−1
- tests/ADP/Tests/CopyExample.hs +1/−1
- tests/ADP/Tests/CopyTwoTrackExample.hs +1/−1
- tests/ADP/Tests/Main.hs +0/−1
- tests/ADP/Tests/OneStructureExample.hs +37/−33
- tests/ADP/Tests/RGExample.hs +3/−3
- tests/ADP/Tests/RGExampleDim2.hs +40/−42
- tests/ADP/Tests/RGExampleStar.hs +3/−13
- tests/ADP/Tests/Suite.hs +16/−3
- tests/ADP/Tests/TermExample.hs +8/−8
- tests/ADP/Tests/ThesisExample.hs +87/−0
- tests/ADP/Tests/TreeAlignExample.hs +109/−0
- tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs +49/−36
adp-multi.cabal view
@@ -1,5 +1,5 @@ name: adp-multi -version: 0.2.2 +version: 0.2.3 cabal-version: >= 1.8 build-type: Simple author: Maik Riechert @@ -96,6 +96,8 @@ ADP.Tests.RGExampleDim2, ADP.Tests.RGExampleStar, ADP.Tests.TermExample, + ADP.Tests.ThesisExample, + ADP.Tests.TreeAlignExample, ADP.Tests.ZeroStructureTwoBackbonesExample, MCFG.MCFG main-is: ADP/Tests/Suite.hs
src/ADP/Multi/Combinators.hs view
@@ -18,7 +18,6 @@ import ADP.Multi.Rewriting - eval :: (b -> c) -> Parser a b -> ([SubwordTree] -> Parser a c) eval f parser [] z subword = map f (parser z subword)
src/ADP/Multi/Rewriting/Explicit.hs view
@@ -26,11 +26,9 @@ parserCount = length infos remainingParsers = [parserCount,parserCount-1..1] `zip` infos rangeDesc = [(i,j,rewritten)]- rangeDescFiltered = filterEmptyRanges rangeDesc in trace ("f " ++ show symbolIDs ++ " = " ++ show rewritten) $ assert (length rewritten == Map.size yieldSizeMap && all (`elem` rewritten) symbolIDs) $- if any (\(m,n,d) -> null d && m /= n) rangeDesc then []- else constructSubwordsRec yieldSizeMap remainingParsers rangeDescFiltered+ constructSubwordsRec yieldSizeMap remainingParsers rangeDesc constructSubwords2 :: SubwordConstructionAlgorithm Dim2 constructSubwords2 _ _ b | trace ("constructSubwords2 " ++ show b) False = undefined@@ -41,81 +39,79 @@ (left,right) = f symbolIDs parserCount = length infos remainingParsers = [parserCount,parserCount-1..1] `zip` infos- rangeDesc = [(i,j,left),(k,l,right)]- rangeDescFiltered = filterEmptyRanges rangeDesc+ rangeDescs = [(i,j,left),(k,l,right)] in trace ("f " ++ show symbolIDs ++ " = (" ++ show left ++ "," ++ show right ++ ")") $- assert (length left + length right == Map.size yieldSizeMap && all (`elem` (left ++ right)) symbolIDs) $- if any (\(m,n,d) -> null d && m /= n) rangeDesc then []- else constructSubwordsRec yieldSizeMap remainingParsers rangeDescFiltered+ assert (length left + length right == Map.size yieldSizeMap && + all (`elem` (left ++ right)) symbolIDs &&+ not (null left) && not (null right)) $+ constructSubwordsRec yieldSizeMap remainingParsers rangeDescs constructSubwordsRec :: YieldSizeMap -> [(Int,ParserInfo)] -> [RangeDesc] -> [SubwordTree]-constructSubwordsRec a b c | trace ("constructRangesRec " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined-constructSubwordsRec _ [] [] = []+constructSubwordsRec a b c | trace ("constructSubwordsRec " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined+constructSubwordsRec _ [] _ = [] constructSubwordsRec yieldSizeMap ((current,ParserInfo1 {}):rest) rangeDescs =- let symbolLoc = findSymbol1 current rangeDescs- subwords = calcSubwords1 yieldSizeMap symbolLoc+ let symbolPos = findSymbol1 current rangeDescs+ subwords = calcSubwords1 yieldSizeMap symbolPos in trace ("calc subwords for dim1") $ trace ("subwords: " ++ show subwords) $ [ SubwordTree [i,j] restTrees | (i,j) <- subwords,- let newDescs = constructNewRangeDescs1 rangeDescs symbolLoc (i,j),+ let newDescs = constructNewRangeDescs1 rangeDescs symbolPos (i,j), let restTrees = constructSubwordsRec yieldSizeMap rest newDescs ] constructSubwordsRec yieldSizeMap ((current,ParserInfo2 {}):rest) rangeDescs =- let symbolLocs = findSymbol2 current rangeDescs- subwords = calcSubwords2 yieldSizeMap symbolLocs+ let symbolPositions = findSymbol2 current rangeDescs+ subwords = calcSubwords2 yieldSizeMap symbolPositions in trace ("calc subwords for dim2") $ trace ("subwords: " ++ show subwords) $ [ SubwordTree [i,j,k,l] restTrees | (i,j,k,l) <- subwords,- let newDescs = constructNewRangeDescs2 rangeDescs symbolLocs (i,j,k,l),+ let newDescs = constructNewRangeDescs2 rangeDescs symbolPositions (i,j,k,l), let restTrees = constructSubwordsRec yieldSizeMap rest newDescs ]-constructSubwordsRec _ [] r@(_:_) = error ("programming error " ++ show r) --- Subword construction doesn't yet take the maximum yield sizes into account.--- This will further decrease the number of generated subwords and thus increase performance.-calcSubwords2 :: YieldSizeMap -> ((RangeDesc,Int),(RangeDesc,Int)) -> [Subword2]+-- The maximum yield sizes are only used in some cases at the moment.+-- They are not used in: +-- 1. last case of 'calcSubwords1'+-- 2. 'calcSubwords2Dependent'+-- Considering maximum yield sizes in all cases will further decrease+-- the number of generated subwords and thus increase performance.+calcSubwords2 :: YieldSizeMap -> (SymbolPos,SymbolPos) -> [Subword2] calcSubwords2 a b | trace ("calcSubwords2 " ++ show a ++ " " ++ show b) False = undefined-calcSubwords2 yieldSizeMap (left@((i,j,r),a1Idx),right@((m,n,r'),a2Idx))- | r == r' = calcSubwords2Dependent yieldSizeMap (i,j,r) a1Idx a2Idx+calcSubwords2 yieldSizeMap (left@((i,j,r),sym1Idx),right@((m,n,r'),sym2Idx))+ | r == r' = calcSubwords2Dependent yieldSizeMap (i,j,r) sym1Idx sym2Idx | length r == 1 && length r' == 1 = [(i,j,m,n)]- | length r == 1 = [ (i',j',k',l') |- let (i',j') = (i,j)- , (k',l') <- calcSubwords1 yieldSizeMap right+ | length r == 1 = [ (i,j,k',l') |+ (k',l') <- calcSubwords1 yieldSizeMap right ]- | length r' == 1 = [ (i',j',k',l') |- let (k',l') = (m,n)- , (i',j') <- calcSubwords1 yieldSizeMap left+ | length r' == 1 = [ (i',j',m,n) |+ (i',j') <- calcSubwords1 yieldSizeMap left ] | otherwise = [ (i',j',k',l') | (i',j') <- calcSubwords1 yieldSizeMap left , (k',l') <- calcSubwords1 yieldSizeMap right ] --- assumes that other component is in a different part-calcSubwords1 :: YieldSizeMap -> (RangeDesc,Int) -> [Subword1]+calcSubwords1 :: YieldSizeMap -> SymbolPos -> [Subword1] calcSubwords1 _ b | trace ("calcSubwords1 " ++ show b) False = undefined-calcSubwords1 yieldSizeMap pos@((i,j,r),axIdx)- | axIdx == 0 =- [ (k,l) |+calcSubwords1 yieldSizeMap pos@((i,j,r),symIdx)+ | symIdx == 0 =+ [ (i,l) | Just (minY',minYRight') <- [adjustMinYield (i,j) (minY,maxY) (minYRight,maxYRight)]- , let k = i , l <- [i+minY'..j-minYRight'] ]- | axIdx == length r - 1 =- [ (k,l) |+ | symIdx == length r - 1 =+ [ (k,j) | Just (minYLeft',minY') <- [adjustMinYield (i,j) (minYLeft,maxYLeft) (minY,maxY)]- , let l = j , k <- [i+minYLeft'..j-minY'] ] | otherwise = [ (k,l) |- k <- [i+minYLeft..j-minY]+ k <- [i+minYLeft..j-minY-minYRight] , l <- [k+minY..j-minYRight] ] where (minY,maxY) = yieldSizeOf yieldSizeMap pos@@ -126,7 +122,7 @@ adjustMinYield (i,j) (minl,maxl) (minr,maxr) = let len = j-i adjust oldMinY maxY = let x = maybe oldMinY (\m -> len - m) maxY- in if x > oldMinY then x else oldMinY+ in max x oldMinY minrAdj = adjust minr maxl minlAdj = adjust minl maxr in do@@ -134,89 +130,83 @@ 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+-- assumes that other nonterminal component is in the same part calcSubwords2Dependent :: YieldSizeMap -> RangeDesc -> Int -> Int -> [Subword2] calcSubwords2Dependent _ b c d | trace ("calcSubwords2Dependent " ++ show b ++ " " ++ show c ++ " " ++ show d) False = undefined-calcSubwords2Dependent yieldSizeMap (i,j,r) a1Idx a2Idx =- let a1Idx' = if a1Idx < a2Idx then a1Idx else a2Idx- a2Idx' = if a1Idx < a2Idx then a2Idx else a1Idx- subs = doCalcSubwords2Dependent yieldSizeMap (i,j,r) a1Idx' a2Idx'- in if a1Idx < a2Idx then subs+calcSubwords2Dependent yieldSizeMap (i,j,r) sym1Idx sym2Idx =+ let sym1Idx' = if sym1Idx < sym2Idx then sym1Idx else sym2Idx+ sym2Idx' = if sym1Idx < sym2Idx then sym2Idx else sym1Idx+ subs = doCalcSubwords2Dependent yieldSizeMap (i,j,r) sym1Idx' sym2Idx'+ in if sym1Idx < sym2Idx then subs else [ (k,l,m,n) | (m,n,k,l) <- subs ] doCalcSubwords2Dependent :: YieldSizeMap -> RangeDesc -> Int -> Int -> [Subword2]-doCalcSubwords2Dependent yieldSizeMap desc@(i,j,r) a1Idx a2Idx =- assert (a1Idx < a2Idx) $+doCalcSubwords2Dependent yieldSizeMap desc@(i,j,r) sym1Idx sym2Idx =+ assert (sym1Idx < sym2Idx) $ trace ("min yields: " ++ show minY1 ++ " " ++ show minY2 ++ " " ++ show minYLeft1 ++ " " ++ show minYLeft2 ++ " " ++ show minYRight1 ++ " " ++ show minYRight2 ++ " " ++ show minYBetween) $ trace ("max yields: " ++ show maxY1 ++ " " ++ show maxY2 ++ " " ++ show maxYLeft1 ++ " " ++ show maxYLeft2 ++ " " ++ show maxYRight1 ++ " " ++ show maxYRight2 ++ " " ++ show maxYBetween) $ result where - (minY1,maxY1) = yieldSizeOf yieldSizeMap (desc,a1Idx)- (minY2,maxY2) = yieldSizeOf yieldSizeMap (desc,a2Idx)- (minYLeft1,maxYLeft1) = combinedYieldSizeLeftOf yieldSizeMap (desc,a1Idx)- (minYLeft2,maxYLeft2) = combinedYieldSizeLeftOf yieldSizeMap (desc,a2Idx)- (minYRight1,maxYRight1) = combinedYieldSizeRightOf yieldSizeMap (desc,a1Idx)- (minYRight2,maxYRight2) = combinedYieldSizeRightOf yieldSizeMap (desc,a2Idx)+ (minY1,maxY1) = yieldSizeOf yieldSizeMap (desc,sym1Idx)+ (minY2,maxY2) = yieldSizeOf yieldSizeMap (desc,sym2Idx)+ (minYLeft1,maxYLeft1) = combinedYieldSizeLeftOf yieldSizeMap (desc,sym1Idx)+ (minYLeft2,maxYLeft2) = combinedYieldSizeLeftOf yieldSizeMap (desc,sym2Idx)+ (minYRight1,maxYRight1) = combinedYieldSizeRightOf yieldSizeMap (desc,sym1Idx)+ (minYRight2,maxYRight2) = combinedYieldSizeRightOf yieldSizeMap (desc,sym2Idx) minYBetween = minYRight1 - minYRight2 - minY2 maxYBetween = if isNothing maxYRight1 then Nothing else Just $ fromJust maxYRight1 - fromJust maxYRight2 - fromJust maxY2 - neighbors = a1Idx + 1 == a2Idx+ neighbors = sym1Idx + 1 == sym2Idx - result | a1Idx == 0 && a2Idx == length r - 1 && neighbors =- [ (k,l,l,n) |- let (k,n) = (i,j)- , l <- [i+minY1..j-minY2]+ result | sym1Idx == 0 && sym2Idx == length r - 1 && neighbors =+ [ (i,l,l,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]+ | sym1Idx == 0 && sym2Idx == length r - 1 =+ [ (i,l,m,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]+ | sym1Idx == 0 && neighbors =+ [ (i,l,l,n) |+ l <- [i+minY1..j-minYRight1] , n <- [l+minY2..j-minYRight2] ] - | a1Idx == 0 =- [ (k,l,m,n) |- let k = i- , l <- [i+minY1..j-minYRight1]+ | sym1Idx == 0 =+ [ (i,l,m,n) |+ 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]+ | sym2Idx == length r - 1 && neighbors =+ [ (k,m,m,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]+ | sym2Idx == length r - 1 =+ [ (k,l,m,j) |+ m <- [i+minYLeft2..j-minY2] , l <- [i+minY1+minYLeft1..m-minYBetween] , k <- [i+minYLeft1..l-minY1] ] - | a1Idx > 0 && a2Idx < length r - 1 && neighbors =+ | sym1Idx > 0 && sym2Idx < 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 =+ | sym1Idx > 0 && sym2Idx < length r - 1 = [ (k,l,m,n) | k <- [i+minYLeft1..j-minY1-minYRight1] , l <- [k+minY1..j-minYRight1]@@ -224,4 +214,4 @@ , n <- [m+minY2..j-minYRight2] ] - | otherwise = error "invalid conditions, e.g. a1Idx == a2Idx == 0"+ | otherwise = error "invalid conditions, e.g. sym1Idx == sym2Idx == 0"
src/ADP/Multi/Rewriting/Model.hs view
@@ -26,13 +26,14 @@ type Dim1 = [SymbolID] -> [SymbolID] -- | 2-dimensional rewriting function +-- Note: every dimension must contain at least one element type Dim2 = [SymbolID] -> ([SymbolID], [SymbolID]) --- | Convenience rewriting function for one or more dim1 symbols +-- | Convenience rewriting function for one or more dim1 parsers id1 :: Dim1 id1 = id --- | Convenience rewriting function for one dim2 symbol +-- | Convenience rewriting function for one dim2 parser id2 :: Dim2 id2 [c1,c2] = ([c1],[c2]) -id2 _ = error "Only use id2 for single symbols! Write your own rewrite function instead."+id2 _ = error "Only use id2 for single parsers! Write your own rewriting function instead."
src/ADP/Multi/Rewriting/RangesHelper.hs view
@@ -21,110 +21,108 @@ -- that name very much, but haven't found a good alternative. type RangeDesc = (Int,Int,[SymbolID]) +-- | The list index position of a SymbolID in a RangeDesc. +type SymbolPos = (RangeDesc,Int) + -- | Searches for the given SymbolID in a list of RangeDesc's --- and returns its index in the RangeDesc where it was found. -findSymbol :: SymbolID -> [RangeDesc] -> (RangeDesc,Int) -findSymbol (s,idx) r | trace ("findSymbol " ++ show s ++ "," ++ show idx ++ " " ++ show r) False = undefined -findSymbol (s,idx) rangeDesc = - let Just (i,j,r) = find (\(_,_,l') -> any (\(s',i') -> s' == s && i' == idx) l') rangeDesc - Just aIdx = elemIndex (s,idx) r - in ((i,j,r),aIdx) +-- and returns its position. +findSymbol :: SymbolID -> [RangeDesc] -> SymbolPos +findSymbol symId r | trace ("findSymbol " ++ show symId ++ " " ++ show r) False = undefined +findSymbol symId rangeDescs = + let Just (i,j,r) = find (\(_,_,l) -> symId `elem` l) rangeDescs + Just symIdx = elemIndex symId r + in ((i,j,r),symIdx) -findSymbol1 :: Int -> [RangeDesc] -> (RangeDesc,Int) +findSymbol1 :: Int -> [RangeDesc] -> SymbolPos findSymbol1 s = findSymbol (s,1) -findSymbol2 :: Int -> [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) -findSymbol2 s rangeDesc = (findSymbol (s,1) rangeDesc, findSymbol (s,2) rangeDesc) +findSymbol2 :: Int -> [RangeDesc] -> (SymbolPos,SymbolPos) +findSymbol2 s rangeDescs = (findSymbol (s,1) rangeDescs, findSymbol (s,2) rangeDescs) -constructNewRangeDescs1 :: [RangeDesc] -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] +constructNewRangeDescs1 :: [RangeDesc] -> SymbolPos -> 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) $ + countSymbols = foldr (\(_,_,l) r -> r + length l) 0 + in assert (countSymbols descs > countSymbols newDescs) $ trace (show newDescs) $ newDescs -constructNewRangeDescs2 :: [RangeDesc] -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] +constructNewRangeDescs2 :: [RangeDesc] -> (SymbolPos,SymbolPos) -> 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) $ + countSymbols = foldr (\(_,_,l) r -> r + length l) 0 + in assert (countSymbols descs > countSymbols newDescs) $ trace (show newDescs) $ newDescs -processRangeDesc1 :: RangeDesc -> (RangeDesc,Int) -> Subword1 -> [RangeDesc] +processRangeDesc1 :: RangeDesc -> SymbolPos -> Subword1 -> [RangeDesc] processRangeDesc1 a b c | trace ("processRangeDesc1 " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined -processRangeDesc1 inp (desc,aIdx) (m,n) +processRangeDesc1 inp (desc,symIdx) (m,n) | inp /= desc = [inp] - | otherwise = processRangeDescSingle desc aIdx (m,n) + | otherwise = processRangeDescSingle desc symIdx (m,n) -processRangeDesc2 :: RangeDesc -> ((RangeDesc,Int),(RangeDesc,Int)) -> Subword2 -> [RangeDesc] +processRangeDesc2 :: RangeDesc -> (SymbolPos,SymbolPos) -> 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) +processRangeDesc2 inp ((left,sym1Idx),(right,sym2Idx)) (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) + let (sym1Idx',sym2Idx',m',n',o',p') = + if sym1Idx < sym2Idx then + (sym1Idx,sym2Idx,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 + (sym2Idx,sym1Idx,o,p,m,n) + in processRangeDescDouble inp sym1Idx' sym2Idx' (m',n',o',p') + | inp == left = processRangeDescSingle left sym1Idx (m,n) + | inp == right = processRangeDescSingle right sym2Idx (o,p) 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)] +processRangeDescSingle (i,j,r) symIdx (k,l) + | symIdx == 0 = [(l,j,tail r)] + | symIdx == length r - 1 = [(i,k,init r)] + | otherwise = [(i,k,take symIdx r),(l,j,drop (symIdx + 1) r)] --- assumes that a1Idx < a2Idx, see processRangeDesc +-- assumes that sym1Idx < sym2Idx, 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)] +processRangeDescDouble (i,j,r) sym1Idx sym2Idx (k,l,m,n) = + assert (sym1Idx < sym2Idx) result where + result | sym1Idx == 0 && sym2Idx == length r - 1 = [(l,m,init (tail r))] + | sym1Idx == 0 = [(l,m,slice 1 (sym2Idx-1) r),(n,j,drop (sym2Idx+1) r)] + | sym2Idx == length r - 1 = [(i,k,take sym1Idx r),(l,m,slice (sym1Idx+1) (sym2Idx-1) r)] + | otherwise = [(i,k,take sym1Idx r),(l,m,slice (sym1Idx+1) (sym2Idx-1) r),(n,j,drop (sym2Idx+1) r)] where slice from to xs = take (to - from + 1) (drop from xs) -- | Returns the yield size of the symbol at the given index in -- the given RangeDesc. -yieldSizeOf :: YieldSizeMap -> (RangeDesc,Int) -> YieldSize -yieldSizeOf yieldSizeMap ((_,_,r),aIdx) = +yieldSizeOf :: YieldSizeMap -> SymbolPos -> YieldSize +yieldSizeOf yieldSizeMap ((_,_,r),symIdx) = -- TODO !! might be expensive as it's a list - yieldSizeMap Map.! (r !! aIdx) + yieldSizeMap Map.! (r !! symIdx) -- | calculates the combined yield size of all symbols left of the given one -combinedYieldSizeLeftOf :: YieldSizeMap -> (RangeDesc,Int) -> YieldSize -combinedYieldSizeLeftOf yieldSizeMap (desc,axIdx) - | axIdx == 0 = (0, Just 0) +combinedYieldSizeLeftOf :: YieldSizeMap -> SymbolPos -> YieldSize +combinedYieldSizeLeftOf yieldSizeMap (desc,symIdx) + | symIdx == 0 = (0, Just 0) | otherwise = - let leftYieldSizes = map (\i -> yieldSizeOf yieldSizeMap (desc,i)) [0..axIdx-1] + let leftYieldSizes = map (\i -> yieldSizeOf yieldSizeMap (desc,i)) [0..symIdx-1] in combineYields leftYieldSizes -- | calculates the combined yield size of all symbols right of the given one -combinedYieldSizeRightOf :: YieldSizeMap -> (RangeDesc,Int) -> YieldSize -combinedYieldSizeRightOf yieldSizeMap (desc@(_,_,r),axIdx) - | axIdx == length r - 1 = (0, Just 0) +combinedYieldSizeRightOf :: YieldSizeMap -> SymbolPos -> YieldSize +combinedYieldSizeRightOf yieldSizeMap (desc@(_,_,r),symIdx) + | symIdx == length r - 1 = (0, Just 0) | otherwise = - let rightYieldSizes = map (\i -> yieldSizeOf yieldSizeMap (desc,i)) [axIdx+1..length r - 1] + let rightYieldSizes = map (\i -> yieldSizeOf yieldSizeMap (desc,i)) [symIdx+1..length r - 1] in combineYields rightYieldSizes
tests/ADP/Tests/AlignmentExample.hs view
@@ -1,4 +1,4 @@--- Needleman/Wunsch global alignment+-- | Needleman/Wunsch global alignment of two sequences module ADP.Tests.AlignmentExample where import ADP.Debug
tests/ADP/Tests/CopyExample.hs view
@@ -1,4 +1,4 @@--- Copy language L = { ww | w € {a,b}^* }+-- | Copy language L = { ww | w in {a,b}^* } module ADP.Tests.CopyExample where import ADP.Multi.All
tests/ADP/Tests/CopyTwoTrackExample.hs view
@@ -1,4 +1,4 @@--- Copy language L = { (w,w) | w € {a,b}^* }+-- | Copy language L = { (w,w) | w in {a,b}^* } module ADP.Tests.CopyTwoTrackExample where import ADP.Debug
tests/ADP/Tests/Main.hs view
@@ -40,7 +40,6 @@ -- struc = "..((((..[[[[)))).....]]]]..." -- inp = map toLower "ACCGUCGUUCCCGACGUAAAAGGGAUGU" - -- https://github.com/neothemachine/rna/wiki/Example inp = "agcgu" --inp = map toLower "ACGAUUCAACGU"
tests/ADP/Tests/OneStructureExample.hs view
@@ -7,28 +7,28 @@ import ADP.Multi.All import ADP.Multi.Rewriting.All -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+type OneStructure_Algebra alphabet ans = (+ EPS -> ans, -- nil+ ans -> ans -> ans, -- left+ ans -> ans -> ans -> ans, -- pair+ (alphabet, alphabet) -> ans, -- basepair+ alphabet -> ans, -- base+ ans -> ans, -- i1+ ans -> ans, -- i2+ ans -> ans -> ans -> ans -> ans, -- tstart+ ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans, -- knotH+ ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans, -- knotK+ ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans, -- knotL+ ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans -> ans, -- knotM+ ans -> ans -> ans -> ans -> ans, -- aknot1+ ans -> ans, -- aknot2+ ans -> ans -> ans -> ans -> ans, -- bknot1+ ans -> ans, -- bknot2+ ans -> ans -> ans -> ans -> ans, -- cknot1+ ans -> ans, -- cknot2+ ans -> ans -> ans -> ans -> ans, -- dknot1+ ans -> ans, -- dknot2+ [ans] -> [ans] -- h ) data T = Nil@@ -80,7 +80,8 @@ dknot1 _ = xknot1 "<" ">" dknot2 _ = [ "<" , ">" ] - xknot1 parenL parenR i1 i2 [x1,x2] = [concat $ [parenL] ++ i1 ++ [x1], concat $ [x2] ++ i2 ++ [parenR]]+ xknot1 parenL parenR i1 i2 [x1,x2] = + [concat $ [parenL] ++ i1 ++ [x1], concat $ [x2] ++ i2 ++ [parenR]] h = id @@ -123,13 +124,13 @@ and a convenience function which actually runs the grammar on a given input (oneStructure). It is reused in ZeroStructureTwoBackbonesExample.hs -}-oneStructure :: OneStructure_Algebra Char answer -> String -> [answer]+oneStructure :: OneStructure_Algebra Char ans -> String -> [ans] oneStructure algebra inp = let z = mk inp grammar = oneStructureGrammar algebra z in axiom z grammar -oneStructureGrammar :: OneStructure_Algebra Char answer -> Array Int Char -> RichParser Char answer+oneStructureGrammar :: OneStructure_Algebra Char ans -> Array Int Char -> RichParser Char ans oneStructureGrammar algebra z = let (nil,left,pair,basepair,base,i1,i2,tstart,knotH,knotK,knotL,knotM,@@ -150,18 +151,21 @@ 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]+ 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]+ [i1,x11,i2,x21,i3,x31,i4,x12,i5,x41,i6,x22,i7,x32,i8,x42,s] t = tabulated1 $ yieldSize1 (2, Nothing) $ tstart <<< p ~~~ i ~~~ t ~~~ s >>> rewriteTStart |||- knotH <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb >>> rewriteKnotH |||- knotK <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc >>> rewriteKnotK |||- knotL <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc >>> rewriteKnotL |||- knotM <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc ~~~ xd >>> rewriteKnotM+ knotH <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb >>> rewriteKnotH |||+ knotK <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc >>> rewriteKnotK |||+ knotL <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc >>> rewriteKnotL |||+ knotM <<< s ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ i ~~~ xa ~~~ xb ~~~ xc ~~~ xd >>> rewriteKnotM rewriteXKnot1 :: Dim2 rewriteXKnot1 [p1,p2,i1,i2,x1,x2] = ([p1,i1,x1],[x2,i2,p2])
tests/ADP/Tests/RGExample.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-+{- | Example using the Reeder&Giegerich class of pseudoknots. (with only the first canonization rule applied) @@ -22,14 +22,14 @@ import ADP.Multi.Rewriting.All type RG_Algebra alphabet answer = (- EPS -> answer, -- nil+ 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+ alphabet -> answer, -- base [answer] -> [answer] -- h )
tests/ADP/Tests/RGExampleDim2.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-+{- | The same as RGExample.hs but all 1-dim nonterminals are encoded as 2-dim nonterminals. -}@@ -13,10 +13,10 @@ import ADP.Multi.Rewriting.All type RG_Algebra alphabet answer = (- (EPS,EPS) -> answer, -- nil- answer -> answer -> answer, -- left- answer -> answer -> answer -> answer, -- pair- answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knot+ (EPS,EPS) -> answer, -- nil+ EPS -> answer -> answer -> answer, -- left+ EPS -> answer -> answer -> answer -> answer, -- pair+ EPS -> answer -> answer -> answer -> answer -> answer -> answer -> answer, -- knot answer -> answer -> answer, -- knot1 answer -> answer, -- knot2 (alphabet, alphabet) -> answer, -- basepair@@ -31,10 +31,10 @@ (nil'',left'',pair'',knot'',knot1'',knot2'',basepair'',base'',h'') = alg2 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)+ left e (b1,b2) (s1,s2) = (left' e b1 s1, left'' e b2 s2)+ pair e (p1,p2) (s11,s21) (s12,s22) = (pair' e p1 s11 s12, pair'' e p2 s21 s22)+ knot e (k11,k21) (k12,k22) (s11,s21) (s12,s22) (s13,s23) (s14,s24) =+ (knot' e k11 k12 s11 s12 s13 s14, knot'' e 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)@@ -51,9 +51,9 @@ -- 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+ | Left' EPS Start Start+ | Pair EPS Start Start Start+ | Knot EPS Start Start Start Start Start Start | Knot1 Start Start | Knot2 Start | BasePair (Char, Char)@@ -72,14 +72,14 @@ k' = [Knot1 {}, Knot2 {}] nil _ = Nil- left b@(Base _) s - | s `isOf` s' = Left' b s+ left e b@(Base _) s + | s `isOf` s' = Left' e b s - pair p@(BasePair _) s1 s2 - | [s1,s2] `areOf` s' = Pair p s1 s2+ pair e p@(BasePair _) s1 s2 + | [s1,s2] `areOf` s' = Pair e 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+ knot e k1 k2 s1 s2 s3 s4 + | [k1,k2] `areOf` k' && [s1,s2,s3,s4] `areOf` s' = Knot e k1 k2 s1 s2 s3 s4 knot1 p@(BasePair _) k | k `isOf` k' = Knot1 p k@@ -95,9 +95,9 @@ 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+ 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@@ -108,9 +108,9 @@ 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+ left _ _ b = b+ pair _ _ b c = b + c+ knot _ _ _ c d e f = 1 + c + d + e + f knot1 _ _ = 0 knot2 _ = 0 basepair _ = 0@@ -118,22 +118,21 @@ h [] = [] h xs = [maximum xs] --- TODO don't need [String] here as it's all dim2, use (String,String) instead -- The left part is the structure and the right part the reconstructed input. prettyprint :: RG_Algebra Char ([String],[String]) prettyprint = (nil,left,pair,knot,knot1,knot2,basepair,base,h) where nil _ = ([""],[""])- left (bl,br) (sl,sr) = + left _ (bl,br) (sl,sr) = ( [concat $ bl ++ sl], [concat $ br ++ sr] )- pair ([p1l,p2l],[p1r,p2r]) (s1l,s1r) (s2l,s2r) = + 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) =+ knot _ ([k11l,k12l],[k11r,k12r]) ([k21l,k22l],[k21r,k22r]) (s1l,s1r) (s2l,s2r) (s3l,s3r) (s4l,s4r) = let (k11l',k12l') = square k11l k12l in (@@ -157,28 +156,27 @@ let (nil,left,pair,knot,knot1,knot2,basepair,base,h) = algebra - s1,s2,s3,s4,p',k1,k2 :: Dim2+ s2,s3,s4,p',k1,k2 :: Dim2 -- all s are 1-dim simulated as 2-dim- s1 [c1,c2] = ([],[c1,c2])- s2 [b1,b2,s1,s2] = ([],[b1,b2,s1,s2])- s3 [p1,p2,s11,s12,s21,s22] = ([],[p1,s11,s12,p2,s21,s22])- s4 [k11,k12,k21,k22,s11,s12,s21,s22,s31,s32,s41,s42] = - ([],[k11,s11,s12,k21,s21,s22,k12,s31,s32,k22,s41,s42])+ s2 [e,b1,b2,s1,s2] = ([e],[b1,b2,s1,s2])+ s3 [e,p1,p2,s11,s12,s21,s22] = ([e],[p1,s11,s12,p2,s21,s22])+ s4 [e,k11,k12,k21,k22,s11,s12,s21,s22,s31,s32,s41,s42] = + ([e],[k11,s11,s12,k21,s21,s22,k12,s31,s32,k22,s41,s42]) s = tabulated2 $ yieldSize2 (0,Nothing) (0,Nothing) $- nil <<< (EPS,EPS) >>> s1 |||- left <<< b ~~~ s >>> s2 |||- pair <<< p ~~~ s ~~~ s >>> s3 |||- knot <<< k ~~~ k ~~~ s ~~~ s ~~~ s ~~~ s >>> s4 + nil <<< (EPS,EPS) >>> id2 |||+ left <<< EPS ~~~ b ~~~ s >>> s2 |||+ pair <<< EPS ~~~ p ~~~ s ~~~ s >>> s3 |||+ knot <<< EPS ~~~ k ~~~ k ~~~ s ~~~ s ~~~ s ~~~ s >>> s4 ... h b = tabulated2 $- base <<< (EPS, 'a') >>> s1 |||- base <<< (EPS, 'u') >>> s1 |||- base <<< (EPS, 'c') >>> s1 |||- base <<< (EPS, 'g') >>> s1+ base <<< (EPS, 'a') >>> id2 |||+ base <<< (EPS, 'u') >>> id2 |||+ base <<< (EPS, 'c') >>> id2 |||+ base <<< (EPS, 'g') >>> id2 p' [c1,c2] = ([c1],[c2]) p = tabulated2 $
tests/ADP/Tests/RGExampleStar.hs view
@@ -1,24 +1,14 @@-{-+{- | This example is a copy of RGExample with the difference that-(A^*)^i is used in the signature instead of just A or (A,A).+(A^*)^i is used in the signature instead of just A^i. Also, the empty string is used instead of EPS. The purpose is to have a better relation to the examples in the thesis. -} module ADP.Tests.RGExampleStar where -{--S -> € | BS | P_1 S P_2 S | K_1^1 S K_1^2 S K_2^1 S K_2^2 S-[K_1,K_2] -> [K_1 P_1, P_2 K_2] | [P_1, P_2]-[P_1,P_2] -> [a,u] | [u,a] | [g,c] | [c,g] | [g,u] | [u,g]-B -> a | u | c | g--}--import qualified Control.Arrow as A-import Data.Typeable-import Data.Data import ADP.Multi.All-import ADP.Multi.Rewriting.All+import ADP.Multi.Rewriting.All type RG_Algebra alphabet answer = (
tests/ADP/Tests/Suite.hs view
@@ -10,6 +10,7 @@ import Test.QuickCheck import Data.Char (toLower)+import Data.List (sort) import qualified ADP.Tests.RGExample as RG import qualified ADP.Tests.RGExampleDim2 as RGDim2@@ -18,6 +19,7 @@ import qualified ADP.Tests.CopyTwoTrackExample as CopyTT import qualified MCFG.MCFG as MCFG import qualified ADP.Tests.NestedExample as Nested+import qualified ADP.Tests.Nussinov as Nussinov import qualified ADP.Tests.OneStructureExample as One import qualified ADP.Tests.ZeroStructureTwoBackbonesExample as ZeroTT @@ -26,7 +28,7 @@ main :: IO () main = defaultMainWithOpts [- testGroup "Property tests" [+ testGroup "Internal tests" [ testGroup "Yield size" [ testProperty "map size" prop_yieldSizeMapSize, testProperty "map elements" prop_yieldSizeMapElements,@@ -34,14 +36,15 @@ ] ], testGroup "System tests" [- testCase "finds all reference structures" testRgSimpleCompleteness,+ testCase "find all reference structures for 'agcgu'" testRgSimpleCompleteness, -- the following is commented out as it takes quite long --testCase "finds pseudoknot reference structure" testRgRealPseudoknot,- testCase "tests associative function with max basepairs" testRgSimpleBasepairs,+ testCase "test if max base pairs of 'agcgu' is 2" testRgSimpleBasepairs, testProperty "produces copy language" prop_copyLanguage, testProperty "produces same derivation trees for copy language grammar" prop_copyLanguageDerivation, testProperty "produces copy language (two track)" prop_copyLanguageTT, testProperty "produces nested rna" prop_nestedRna,+ testProperty "algebra product consistency" prop_nestedRna2, testProperty "produces 1-structure rna" prop_oneStructureRna, testProperty "produces RG rna" prop_rgRna, testProperty "produces RG (dim2) rna" prop_rgDim2Rna,@@ -124,6 +127,16 @@ prop_nestedRna (RNAString w) = let results = Nested.nested Nested.prettyprint w in not (null results) && all (\(_,result) -> result == w) results++-- checks if NestedExample.hs and Nussinov.hs produce the same results+-- this also tests the user-defined *** product operation+prop_nestedRna2 (RNAString w) =+ let results1 = Nested.nested (Nested.prettyprint Nested.*** Nested.maxBasepairs) w+ results2 = Nussinov.nussinov78' (Nussinov.prettyprint Nussinov.*** Nussinov.pairmax) w+ results3 = Nested.nested (Nested.maxBasepairs Nested.*** Nested.prettyprint) w+ results4 = Nussinov.nussinov78' (Nussinov.pairmax Nussinov.*** Nussinov.prettyprint) w+ in sort results1 == sort results2 &&+ sort results3 == sort results4 -- checks if input sequence can be reconstructed prop_oneStructureRna (RNAString w) =
tests/ADP/Tests/TermExample.hs view
@@ -6,14 +6,14 @@ import ADP.Multi.Rewriting.All type Term_Algebra alphabet answer = ( - answer -> answer, - answer -> answer, -- sym - alphabet -> answer -> answer, -- sym1 - alphabet -> answer, -- sym2 - alphabet -> alphabet -> alphabet -> alphabet, -- escape - answer -> alphabet -> answer -> alphabet -> answer, -- fun - answer -> answer, -- single - answer -> alphabet -> answer -> answer -- split + answer -> answer, -- wrap + answer -> answer, -- sym + alphabet -> answer -> answer, -- sym1 + alphabet -> answer, -- sym2 + alphabet -> alphabet -> alphabet -> alphabet, -- escape + answer -> alphabet -> answer -> alphabet -> answer, -- fun + answer -> answer, -- single + answer -> alphabet -> answer -> answer -- split ) prettyprint :: Term_Algebra Char String
+ tests/ADP/Tests/ThesisExample.hs view
@@ -0,0 +1,87 @@+-- | Example code corresponding to section 6.1 of the thesis.+-- The same but using signatures, products, and more algebras+-- can be found in RGExample*.hs (variable names are different).+module ADP.Tests.ThesisExample where++import ADP.Multi.All+import ADP.Multi.Rewriting.All hiding (id1,id2)++-- rewriting functions+id1,r0,r1,r2,r3 :: Dim1+id2,r4 :: Dim2++id1 [x] = [x]+id2 [x1,x2] = ([x1],[x2])+r0 [e] = [e]+r1 [b,z] = [b,z]+r2 [p1,p2,z1,z2] = [p1,z1,p2,z2]+r3 [m11,m12,m21,m22,z1,z2,z3,z4] = [m11,z1,m21,z2,m12,z3,m22,z4]+r4 [p1,p2,m1,m2] = ([m1,p1],[p2,m2])++-- evaluation algebra for terms+data Term = F1 Term Term+ | F2 Term Term Term+ | F3 String+ | F4 Term Term Term Term Term Term+ | F5 Term Term+ | F6 Term+ | F7 (String,String)+ | F8 String+ deriving (Eq, Show)+(f1,f2,f3,f4,f5,f6,f7,f8) = (F1,F2,F3,F4,F5,F6,F7,F8)+h = id++-- or alternatively: evaluation algebra for counting base pairs+--f1 b z = z+--f2 p z1 z2 = p + z1 + z2+--f3 _ = 0+--f4 m1 m2 z1 z2 z3 z4 = m1 + m2 + z1 + z2 + z3 + z4+--f5 m p = m + p+--f6 p = p+--f7 _ = 1+--f8 _ = 0+--h [] = []+--h xs = [maximum xs]++-- input+w = "agcguu"+w' = mk w++-- memoization+tabulated1 = table1 w'+tabulated2 = table2 w'++-- grammar productions+z = tabulated1 $+ yieldSize1 (0, Nothing) $+ f1 <<< b ~~~ z >>> r1 |||+ f2 <<< p ~~~ z ~~~ z >>> r2 |||+ f3 <<< "" >>> r0 |||+ f4 <<< m ~~~ m ~~~ z ~~~ z ~~~ z ~~~ z >>> r3+ ... h+ +m = tabulated2 $+ yieldSize2 (1, Nothing) (1, Nothing) $+ f5 <<< m ~~~ p >>> r4 |||+ f6 <<< p >>> id2+ ... h++p = tabulated2 $+ f7 <<< ("a","u") >>> id2 |||+ f7 <<< ("u","a") >>> id2 |||+ f7 <<< ("c","g") >>> id2 |||+ f7 <<< ("g","c") >>> id2 |||+ f7 <<< ("g","u") >>> id2 |||+ f7 <<< ("u","g") >>> id2+ ... h+ +b = tabulated1 $+ f8 <<< "a" >>> id1 |||+ f8 <<< "u" >>> id1 |||+ f8 <<< "c" >>> id1 |||+ f8 <<< "g" >>> id1+ ... h++-- result+(staticInfoZ,parserZ) = z+result = parserZ w' [0,length w]
+ tests/ADP/Tests/TreeAlignExample.hs view
@@ -0,0 +1,109 @@+-- | Alignment of trees / terms (Jiang et al., 1995)+module ADP.Tests.TreeAlignExample where++{-+In ADP-MCFL notation:++X -> (rep,r0)(L,L,X) |+ (del,r1)(L,X) |+ (ins,r2)(L,X) |+ (mty,r3)() |+ (concat,r4)(X,X)+L -> f | g++r0(l1,l2,(x1,x2)) = (l1(x1),l2(x2))+r1(l,(x1,x2)) = (l(x1),x2)+r2(l,(x1,x2)) = (x1,l(x2))+r3() = (,)+r4((x1,x2),(x3,x4)) = ( x1,x3 , x2,x4 )++In adp-multi, terminals in rewriting functions (here parentheses)+are moved to the productions.+-}++import ADP.Multi.All+import ADP.Multi.Rewriting.All+ + +type TreeAlign_Algebra alphabet answer = (+ alphabet -> alphabet -> answer -> alphabet -> alphabet -> alphabet -> alphabet -> answer, -- rep+ alphabet -> answer -> alphabet -> alphabet -> answer, -- del+ alphabet -> answer -> alphabet -> alphabet -> answer, -- ins+ (EPS,EPS) -> answer, -- mty+ answer -> answer -> alphabet -> alphabet -> answer, -- concat+ [answer] -> [answer] -- h+ )+ +infixl ***+(***) :: (Eq b, Eq c) => TreeAlign_Algebra a b -> TreeAlign_Algebra a c -> TreeAlign_Algebra a (b,c)+alg1 *** alg2 = (rep,del,ins,mty,concat,h) where+ (rep',del',ins',mty',concat',h') = alg1+ (rep'',del'',ins'',mty'',concat'',h'') = alg2+ + rep l1 l2 (x1,x2) po1 pc1 po2 pc2 = (rep' l1 l2 x1 po1 pc1 po2 pc2, rep'' l1 l2 x2 po1 pc1 po2 pc2)+ del l (x1,x2) po pc = (del' l x1 po pc, del'' l x2 po pc)+ ins l (x1,x2) po pc = (ins' l x1 po pc, ins'' l x2 po pc)+ mty e = (mty' e, mty'' e)+ concat (x1,x2) (x3,x4) c1 c2 = (concat' x1 x3 c1 c2, concat'' x2 x4 c1 c2)+ h xs = [ (x1,x2) |+ x1 <- h' [ y1 | (y1,_) <- xs]+ , x2 <- h'' [ y2 | (y1,y2) <- xs, y1 == x1]+ ]+ +data Term = Rep Char Char Term+ | Del Char Term+ | Ins Char Term+ | Mty+ | Concat Term Term+ deriving (Eq, Show)+ +term :: TreeAlign_Algebra Char Term+term = (rep,del,ins,mty,concat,h) where+ rep l1 l2 x _ _ _ _ = Rep l1 l2 x+ del l x _ _ = Del l x + ins l x _ _ = Ins l x+ mty _ = Mty+ concat x1 x2 _ _ = Concat x1 x2+ h = id++treeSimilarity :: TreeAlign_Algebra Char Int+treeSimilarity = (rep,del,ins,mty,concat,h) where+ rep l1 l2 x _ _ _ _ = x + (if l1 == l2 then 1 else 0)+ del _ x _ _ = x - 1+ ins _ x _ _ = x - 1+ mty _ = 0+ concat x1 x2 _ _ = x1 + x2+ h [] = []+ h xs = [maximum xs]++treeAlign :: TreeAlign_Algebra Char answer -> (String,String) -> [answer]+treeAlign algebra (inp1,inp2) =+ let + (rep,del,ins,mty,concat,h) = algebra+ + rRep, rDel, rIns, rConcat :: Dim2+ + rRep [l1,l2,x1,x2,po1,pc1,po2,pc2] = ([l1,po1,x1,pc1],[l2,po2,x2,pc2])+ rDel [l,x1,x2,po,pc] = ([l,po,x1,pc],[x2])+ rIns [l,x1,x2,po,pc] = ([x1],[l,po,x2,pc])+ rConcat [x1,x2,x3,x4,c1,c2] = ([x1,c1,x3],[x2,c2,x4])+ + x = tabulated2 $+ yieldSize2 (0,Nothing) (0,Nothing) $+ rep <<< l ~~~ l ~~~ x ~~~ '(' ~~~ ')' ~~~ '(' ~~~ ')' >>> rRep |||+ del <<< l ~~~ x ~~~ '(' ~~~ ')' >>> rDel |||+ ins <<< l ~~~ x ~~~ '(' ~~~ ')' >>> rIns |||+ mty <<< (EPS,EPS) >>> id2 |||+ concat <<< x ~~~ x ~~~ ',' ~~~ ',' >>> rConcat+ ... h+ + l = char 'f' |||+ char 'g'+ + z = mkTwoTrack inp1 inp2+ tabulated2 = table2 z+ + in axiomTwoTrack z inp1 inp2 x+ +test = treeAlign (treeSimilarity *** term) ("f(f(),g(f()))","f(f(),g(f()))")+test2 = treeAlign (treeSimilarity *** term) ("f(f(),g())","f(f(),g(f()))")
tests/ADP/Tests/ZeroStructureTwoBackbonesExample.hs view
@@ -1,4 +1,5 @@-{- This example implements the grammar for 0-structures over two backbones from+{- |+ 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@@ -13,31 +14,34 @@ import ADP.Multi.Rewriting.All import qualified ADP.Tests.OneStructureExample as One --- there are two answer types so that the enum algebra can be written (because ADTs aren't extensible)--- for algebras with numeric answer types it wouldn't matter and we'd only need one type -type ZeroStructureTwoBackbones_Algebra alphabet answerOne answer = (- One.OneStructure_Algebra alphabet answerOne,- answer -> answerOne -> answerOne -> answer, -- i1- answerOne -> answerOne -> answer, -- i2- answer -> answer -> answer, -- pt1- answer -> answer -> answer, -- pt2- 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+{- There are two ans types so that the enum+ algebra can be written (because ADTs aren't extensible).+ For algebras with numeric ans types it wouldn't matter+ and we'd only need one type.+-} +type ZeroStructureTwoBackbones_Algebra alphabet ansOne ans = (+ One.OneStructure_Algebra alphabet ansOne,+ ans -> ansOne -> ansOne -> ans, -- i1+ ansOne -> ansOne -> ans, -- i2+ ans -> ans -> ans, -- pt1+ ans -> ans -> ans, -- pt2+ ansOne -> ansOne -> ans -> ans -> ans, -- t1+ ansOne -> ansOne -> ans -> ans -> ans, -- t2+ ansOne -> ansOne -> ans -> ans -> ans, -- t3+ ansOne -> ansOne -> ansOne -> ansOne -> ans -> ans -> ans -> ans, -- t4+ ansOne -> ansOne -> ansOne -> ansOne -> ansOne -> ansOne -> ans -> ans -> ans -> ans -> ans, -- t5+ ansOne -> ansOne -> ansOne -> ansOne -> ans -> ans -> ans -> ans, -- t6+ ansOne -> ansOne -> ansOne -> ansOne -> ans -> ans -> ans -> ans, -- t7+ ansOne -> ansOne -> ans -> ans -> ans, -- hs2+ ans -> ans -> ans -> ans -> ans, -- h1+ ans -> ans, -- h2+ ans -> ansOne -> ansOne -> ans -> ans, -- g1+ ans -> ans, -- g2+ ans -> ans -> ans, -- ub1+ EPS -> ans, -- ub2+ alphabet -> ans, -- base+ (alphabet, alphabet) -> ans, -- basepair+ [ans] -> [ans] -- h ) data T = OneStructure One.T@@ -64,22 +68,28 @@ 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)+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 (zeroStructureTwoBackbonesGrammar)- and a convenience function which actually runs the grammar on a given input (zeroStructureTwoBackbones).+{- To make the grammar reusable, its definition has been split+ up into the actual grammar which exposes the start symbol+ as a parser (zeroStructureTwoBackbonesGrammar) and a+ convenience function which actually runs the grammar on+ a given input (zeroStructureTwoBackbones). -}-zeroStructureTwoBackbones :: ZeroStructureTwoBackbones_Algebra Char answerOne answer -> (String,String) -> [answer]+zeroStructureTwoBackbones :: ZeroStructureTwoBackbones_Algebra Char ansOne ans + -> (String,String) -> [ans] zeroStructureTwoBackbones algebra (inp1,inp2) = let z = mkTwoTrack inp1 inp2 grammar = zeroStructureTwoBackbonesGrammar algebra z in axiomTwoTrack z inp1 inp2 grammar -zeroStructureTwoBackbonesGrammar :: ZeroStructureTwoBackbones_Algebra Char answerOne answer -> Array Int Char -> RichParser Char answer+zeroStructureTwoBackbonesGrammar :: ZeroStructureTwoBackbones_Algebra Char ansOne ans + -> Array Int Char -> RichParser Char ans zeroStructureTwoBackbonesGrammar algebra z = let - (oneStructureAlgebra,i1,i2,pt1,pt2,t1,t2,t3,t4,t5,t6,t7,hs2,h1,h2,g1,g2,ub1,ub2,base,basepair,h') = algebra+ (oneStructureAlgebra,i1,i2,pt1,pt2,t1,t2,t3,t4,t5,+ t6,t7,hs2,h1,h2,g1,g2,ub1,ub2,base,basepair,h') = algebra one = One.oneStructureGrammar oneStructureAlgebra z @@ -103,11 +113,14 @@ 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])+ 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])+ 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 |||