adp-multi-monadiccp 0.1 → 0.2.0

raw patch · 9 files changed

+329/−13 lines, 9 filesdep +QuickCheckdep +mtldep +test-framework

Dependencies added: QuickCheck, mtl, test-framework, test-framework-quickcheck2

Files

adp-multi-monadiccp.cabal +37/−9
src/ADP/Multi/Constraint/ConstraintSolver.hs +2/−4
tests/ADP/Tests/CombinatorsTest.hs +49/−0
tests/ADP/Tests/RGExample.hs +28/−0
tests/ADP/Tests/RGExampleConstraint.hs +60/−0
tests/ADP/Tests/RGExampleExplicit.hs +55/−0
tests/ADP/Tests/Suite.hs +44/−0
tests/Control/CP/MonadicCpExample.hs +23/−0
tests/Control/CP/MonadicCpProblems.hs +31/−0

adp-multi-monadiccp.cabal view

@@ -1,15 +1,17 @@ name:           adp-multi-monadiccp
-version:        0.1
+version:        0.2.0
 cabal-version:  >=1.8
 build-type:     Simple
 author:         Maik Riechert
 stability:      experimental
-bug-reports:    https://github.com/neothemachine/adp-multi-monadiccp/issues
+bug-reports:    https://github.com/adp-multi/adp-multi-monadiccp/issues
 homepage:       http://adp-multi.ruhoh.com
 copyright:      Maik Riechert, 2013
 license:        BSD3
 license-file:   LICENSE
-tested-with:    GHC==7.4.1
+tested-with:    
+                GHC==7.4.1,
+                GHC==7.6.2
 maintainer:     Maik Riechert
 category:       Algorithms, Data Structures, Bioinformatics
 synopsis:       Subword construction in adp-multi using monadiccp
@@ -24,17 +26,43 @@ 
 source-repository head
   type:      git
-  location:  git://github.com/neothemachine/adp-multi-monadiccp.git
+  location:  git://github.com/adp-multi/adp-multi-monadiccp.git
 
 library
-  hs-source-dirs:  src
-  build-depends:   base == 4.*,
+  hs-source-dirs:   src
+  build-depends:    
+                   base == 4.*,
                    containers >= 0.4 && < 0.6,
                    adp-multi == 0.2.*,
                    monadiccp == 0.7.*
-  ghc-options:     -Wall
-  exposed-modules: 
+  ghc-options:      -Wall
+  exposed-modules:  
                    ADP.Multi.Constraint.All,
                    ADP.Multi.Constraint.Combinators,
                    ADP.Multi.Constraint.ConstraintSolver
-  other-modules:   ADP.Multi.Constraint.MonadicCpHelper
+  other-modules:    ADP.Multi.Constraint.MonadicCpHelper
+
+test-suite Test
+  type:            exitcode-stdio-1.0
+  x-uses-tf:       true
+  ghc-options:     -Wall -rtsopts
+  build-depends:   
+                   base == 4.*,
+                   containers >= 0.4 && < 0.6,
+                   adp-multi == 0.2.*,
+                   monadiccp == 0.7.*,
+                   QuickCheck == 2.5.*,
+                   test-framework == 0.8.*,
+                   test-framework-quickcheck2 == 0.3.*,
+                   mtl >= 2.0 && < 2.2
+  hs-source-dirs:  tests,src
+  main-is:         ADP/Tests/Suite.hs
+  other-modules:   
+                   ADP.Tests.CombinatorsTest,
+                   ADP.Tests.RGExample,
+                   ADP.Tests.RGExampleConstraint,
+                   ADP.Tests.RGExampleExplicit,
+                   Control.CP.MonadicCpExample,
+                   Control.CP.MonadicCpProblems
+  
+

src/ADP/Multi/Constraint/ConstraintSolver.hs view

@@ -4,10 +4,10 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-}  {--Use monadiccp as a finite-domain constraint solver to construct+Use monadiccp/OvertonFD 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+TODO It is really slow. 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 -}@@ -111,8 +111,6 @@                   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'

+ tests/ADP/Tests/CombinatorsTest.hs view

@@ -0,0 +1,49 @@+{-+An alternative to ADP.Multi.Constraint.All if both subword+construction algorithms should be used together in a project,+e.g. for benchmarking.++Using ADP.Multi.Rewriting.All and ADP.Multi.Constraint.All together+would lead to overlapping instances. As a remedy, this module can be+used and >>> has to be replaced by >>>| and >>>|| for dimension 1 and 2.++Phantom types could have been used to prevent overlapping instances,+but then Dim1 and Dim2 would have to be made newtype's instead of+type synonyms which would lead to something like:++rewritePair = Dim1 $ \[p1,p2,s1,s2] -> [p1,s1,p2,s2]++for rewriting functions, and++pair <<< p ~~~ s ~~~ s >>> (rewritePair :: Dim1 Explicit) |||++or alternatively++pair <<< p ~~~ s ~~~ s >>> (rewritePair :: Dim1 ConstraintSolver) |||++for productions. As the case of using both algorithms together is+not the standard use case and the syntax would become very noise,+phantom types were not used.+-}+module ADP.Tests.CombinatorsTest (+    (>>>|), (>>>||),+    id1, id2, Dim1, Dim2+) where++import ADP.Multi.Parser+import ADP.Multi.Rewriting+import ADP.Multi.Combinators (rewrite)+import ADP.Multi.Rewriting.Model+import ADP.Multi.Rewriting.YieldSize++import ADP.Multi.Constraint.ConstraintSolver++infix 6 >>>|+(>>>|) :: ([ParserInfo], [SubwordTree] -> Parser a b) -> Dim1 -> RichParser a b+(>>>|) (infos,p) f = +      (determineYieldSize1 f infos, rewrite constructSubwords1 (infos,p) f)++infix 6 >>>||+(>>>||) :: ([ParserInfo], [SubwordTree] -> Parser a b) -> Dim2 -> RichParser a b   +(>>>||) (infos,p) f = +      (determineYieldSize2 f infos, rewrite constructSubwords2 (infos,p) f)

+ tests/ADP/Tests/RGExample.hs view

@@ -0,0 +1,28 @@+module ADP.Tests.RGExample where++import ADP.Multi.All+                                +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+  )++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)++enum :: RG_Algebra Char Start+enum = (\_->Nil,Left',Pair,Knot,Knot1,Knot2,BasePair,Base,id)

+ tests/ADP/Tests/RGExampleConstraint.hs view

@@ -0,0 +1,60 @@+module ADP.Tests.RGExampleConstraint where++import ADP.Multi.All+import ADP.Tests.CombinatorsTest++import ADP.Tests.RGExample+   +{- +Note that >>>| and >>>|| are only necessary here as both subword construction+algorithms are used in the same project (for testing purposes).+See CombinatorsTest.hs for details.+-}   +rgknot :: RG_Algebra Char answer -> String -> [answer]+rgknot algebra inp =+  let  +  (nil,left,pair,knot,knot1,knot2,basepair,base,h) = algebra+   +  rewritePair, rewriteKnot :: Dim1+   +  rewritePair [p1,p2,s1,s2] = [p1,s1,p2,s2] +  rewriteKnot [k11,k12,k21,k22,s1,s2,s3,s4] = [k11,s1,k21,s2,k12,s3,k22,s4]+  +  s = tabulated1 $+      yieldSize1 (0,Nothing) $+      nil  <<< EPS >>>| id1 |||+      left <<< b ~~~ s >>>| id1 |||+      pair <<< p ~~~ s ~~~ s >>>| rewritePair |||+      knot <<< k ~~~ k ~~~ s ~~~ s ~~~ s ~~~ s >>>| rewriteKnot+      ... h+  +  b = tabulated1 $+      base <<< 'a' >>>| id1 |||+      base <<< 'u' >>>| id1 |||+      base <<< 'c' >>>| id1 |||+      base <<< 'g' >>>| id1+      ... h+  +  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+      ... h+  +  rewriteKnot1 :: Dim2+  rewriteKnot1 [p1,p2,k1,k2] = ([k1,p1],[p2,k2])+  +  k = tabulated2 $+      yieldSize2 (1,Nothing) (1,Nothing) $+      knot1 <<< p ~~~ k >>>|| rewriteKnot1 |||+      knot2 <<< p >>>|| id2+      ... h+      +  z = mk inp+  tabulated1 = table1 z+  tabulated2 = table2 z+  +  in axiom z s

+ tests/ADP/Tests/RGExampleExplicit.hs view

@@ -0,0 +1,55 @@+module ADP.Tests.RGExampleExplicit where++import ADP.Multi.All+import ADP.Multi.Rewriting.All++import ADP.Tests.RGExample+   +rgknot :: RG_Algebra Char answer -> String -> [answer]+rgknot algebra inp =+  let  +  (nil,left,pair,knot,knot1,knot2,basepair,base,h) = algebra+   +  rewritePair, rewriteKnot :: Dim1+   +  rewritePair [p1,p2,s1,s2] = [p1,s1,p2,s2]+  rewriteKnot [k11,k12,k21,k22,s1,s2,s3,s4] = [k11,s1,k21,s2,k12,s3,k22,s4]+  +  s = tabulated1 $+      yieldSize1 (0,Nothing) $+      nil  <<< EPS >>> id1 |||+      left <<< b ~~~ s >>> id1 |||+      pair <<< p ~~~ s ~~~ s >>> rewritePair |||+      knot <<< k ~~~ k ~~~ s ~~~ s ~~~ s ~~~ s >>> rewriteKnot+      ... h+  +  b = tabulated1 $+      base <<< 'a' >>> id1 |||+      base <<< 'u' >>> id1 |||+      base <<< 'c' >>> id1 |||+      base <<< 'g' >>> id1+      ... h+  +  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+      ... h+  +  rewriteKnot1 :: Dim2+  rewriteKnot1 [p1,p2,k1,k2] = ([k1,p1],[p2,k2])+  +  k = tabulated2 $+      yieldSize2 (1,Nothing) (1,Nothing) $+      knot1 <<< p ~~~ k >>> rewriteKnot1 |||+      knot2 <<< p >>> id2+      ... h+      +  z = mk inp+  tabulated1 = table1 z+  tabulated2 = table2 z+  +  in axiom z s

+ tests/ADP/Tests/Suite.hs view

@@ -0,0 +1,44 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty)+import Data.Monoid (mempty)++import Test.QuickCheck++import qualified ADP.Tests.RGExample as RG+import qualified ADP.Tests.RGExampleExplicit as RGE+import qualified ADP.Tests.RGExampleConstraint as RGC++main :: IO ()+main = defaultMainWithOpts+            [+                    testProperty "subword consistency" prop_constraint+            ]+       mempty { +            ropt_test_options = Just mempty {+                topt_maximum_generated_tests = Just 20+            }+       }++-- checks if both subword construction algorithms produce the same subwords+-- by testing whether a grammar produces the same terms in both cases+prop_constraint (RNAString w) =+    let resultsExplicit = RGE.rgknot RG.enum w+        resultsConstraint = RGC.rgknot RG.enum w+    in -- the constraint solver returns subwords in the same order+       -- as the explicit algorithm, therefore a simple equality test is enough +       resultsExplicit == resultsConstraint++          +                   +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/Control/CP/MonadicCpExample.hs view

@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module ADP.Tests.MonadicCpTest where++import Control.CP.FD.Interface+import ADP.Multi.Constraint.MonadicCpHelper++main :: IO ()+main = print $ solveModel model++model :: FDModel+model = exists $ \col -> do+  [x1,x2] <- colList col 2+  allin col (cte 0,cte 8)+  x1 + x2 @= 8+  x1 @>= 1+  x2 @>= 2+  x1 @<= 10+  x2 @<= 12+  -2 @<= x2+  -4 @<= x1+  return col

+ tests/Control/CP/MonadicCpProblems.hs view

@@ -0,0 +1,31 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module Control.CP.MonadicCpProblems where++import Control.CP.FD.Interface+import ADP.Multi.Constraint.MonadicCpHelper++main :: IO ()+main = print $ solveModel model+++-- throws Exception: Cannot process EGBoolValue BoolConst True+model :: FDModel+model = exists $ \col -> do+  [len1,len2] <- colList col 2+  xsum col @= 2+  len1 @>= 0+  len2 @>= 1+  2 @<= 1 -- this causes the exception +  return col++-- throws Exception: Cannot process EGLess True+model2 :: FDModel+model2 = exists $ \col -> do+  [x1,x2,x3,x4] <- colList col 4+  allin col (cte 0,cte 5)+  x1 @<= x2+  x3 @>= x4+  x3 @>= x2 @|| x4 @<= x1  -- this causes the exception +  return col