packages feed

adp-multi-monadiccp (empty) → 0.1

raw patch · 7 files changed

+324/−0 lines, 7 filesdep +adp-multidep +basedep +containerssetup-changed

Dependencies added: adp-multi, base, containers, monadiccp

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (C) 2013 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-monadiccp.cabal view
@@ -0,0 +1,40 @@+name:           adp-multi-monadiccp
+version:        0.1
+cabal-version:  >=1.8
+build-type:     Simple
+author:         Maik Riechert
+stability:      experimental
+bug-reports:    https://github.com/neothemachine/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
+maintainer:     Maik Riechert
+category:       Algorithms, Data Structures, Bioinformatics
+synopsis:       Subword construction in adp-multi using monadiccp
+description:    
+                This is an experimental subword construction algorithm
+                for the adp-multi package. It uses the constraint
+                programming framework monadiccp with the constraint solver
+                OvertonFD. It is slower than the built-in algorithm in
+                adp-multi and serves research purposes.
+                Use it by importing ADP.Multi.Constraint.All instead
+                of ADP.Multi.Rewriting.All in your grammar files.
+
+source-repository head
+  type:      git
+  location:  git://github.com/neothemachine/adp-multi-monadiccp.git
+
+library
+  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: 
+                   ADP.Multi.Constraint.All,
+                   ADP.Multi.Constraint.Combinators,
+                   ADP.Multi.Constraint.ConstraintSolver
+  other-modules:   ADP.Multi.Constraint.MonadicCpHelper
+ src/ADP/Multi/Constraint/All.hs view
@@ -0,0 +1,6 @@+-- | Convenience module to import the specific rewriting function model+--   and combinator implementation known as /constraint solver/.+module ADP.Multi.Constraint.All (module X) where++import ADP.Multi.Rewriting.Model as X
+import ADP.Multi.Constraint.Combinators()
+ src/ADP/Multi/Constraint/Combinators.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Use this set of combinators instead of ADP.Multi.Rewriting.Combinators to+use a constraint solver for constructing the subword ranges.++Note: This is experimental and slow.+-} +module ADP.Multi.Constraint.Combinators where++import ADP.Multi.Combinators+import ADP.Multi.Rewriting.YieldSize+import ADP.Multi.Rewriting.Model+import ADP.Multi.Constraint.ConstraintSolver++instance Rewritable Dim1 a b where+    (>>>) (infos,p) f = +      (determineYieldSize1 f infos, rewrite constructSubwords1 (infos,p) f)+    +instance Rewritable Dim2 a b where+    (>>>) (infos,p) f = +      (determineYieldSize2 f infos, rewrite constructSubwords2 (infos,p) f)
+ src/ADP/Multi/Constraint/ConstraintSolver.hs view
@@ -0,0 +1,183 @@+{-# 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.Constraint.ConstraintSolver (+        constructSubwords1,+        constructSubwords2+) where++import Control.Exception +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.Model+import ADP.Multi.Rewriting.YieldSize+import ADP.Multi.Rewriting.RangesHelper+import ADP.Multi.Constraint.MonadicCpHelper+import Control.CP.FD.Interface+++constructSubwords1 :: SubwordConstructionAlgorithm Dim1+constructSubwords1 _ _ b | trace ("constructSubwords1 " ++ show b) False = undefined+constructSubwords1 f infos [i,j] =+        assert (i <= j) $+        let yieldSizeMap = buildYieldSizeMap infos+            symbolIDs = Map.keys yieldSizeMap+            rewritten = f symbolIDs+            parserCount = length infos+            remainingParsers = [parserCount,parserCount-1..1] `zip` infos+            rangeDesc = [(i,j,rewritten)]+            rangeDescFiltered = filterEmptyRanges rangeDesc+        in trace ("f " ++ show symbolIDs ++ " = " ++ show rewritten) $+           assert (length rewritten == Map.size yieldSizeMap && all (`elem` rewritten) symbolIDs) $+           if any (\(m,n,d) -> null d && m /= n) rangeDesc then []+           else constructSubwordsRec yieldSizeMap remainingParsers rangeDescFiltered++constructSubwords2 :: SubwordConstructionAlgorithm Dim2+constructSubwords2 _ _ b | trace ("constructSubwords2 " ++ show b) False = undefined+constructSubwords2 f infos [i,j,k,l] =+        assert (i <= j && j <= k && k <= l) $+        let yieldSizeMap = buildYieldSizeMap infos+            symbolIDs = Map.keys yieldSizeMap+            (left,right) = f symbolIDs+            parserCount = length infos+            remainingParsers = [parserCount,parserCount-1..1] `zip` infos+            rangeDesc = [(i,j,left),(k,l,right)]+            rangeDescFiltered = filterEmptyRanges rangeDesc+        in trace ("f " ++ show symbolIDs ++ " = (" ++ show left ++ "," ++ show right ++ ")") $+           assert (length left + length right == Map.size yieldSizeMap && all (`elem` (left ++ right)) symbolIDs) $+           if any (\(m,n,d) -> null d && m /= n) rangeDesc then []+           else constructSubwordsRec yieldSizeMap remainingParsers rangeDescFiltered++++constructSubwordsRec :: YieldSizeMap -> [(Int,ParserInfo)] -> [RangeDesc] -> [SubwordTree]+constructSubwordsRec a b c | trace ("constructRangesRec " ++ show a ++ " " ++ show b ++ " " ++ show c) False = undefined+constructSubwordsRec _ [] [] = []+constructSubwordsRec yieldSizeMap ((current,ParserInfo1 {}):rest) rangeDescs =+        let symbolLoc = findSymbol1 current rangeDescs+            subwords = calcSubwords1 yieldSizeMap symbolLoc+        in trace ("calc subwords for dim1") $+           trace ("subwords: " ++ show subwords) $+           [ SubwordTree [i,j] restTrees |+             (i,j) <- subwords,+             let newDescs = constructNewRangeDescs1 rangeDescs symbolLoc (i,j),+             let restTrees = constructSubwordsRec yieldSizeMap rest newDescs+           ]+constructSubwordsRec yieldSizeMap ((current,ParserInfo2 {}):rest) rangeDescs =+        let symbolLocs = findSymbol2 current rangeDescs+            subwords = calcSubwords2 yieldSizeMap symbolLocs+        in trace ("calc subwords for dim2") $+           trace ("subwords: " ++ show subwords) $+           [ SubwordTree [i,j,k,l] restTrees |+             (i,j,k,l) <- subwords,+             let newDescs = constructNewRangeDescs2 rangeDescs symbolLocs (i,j,k,l),+             let restTrees = constructSubwordsRec yieldSizeMap rest newDescs+           ]+constructSubwordsRec _ [] r@(_:_) = error ("programming error " ++ show r)+++calcSubwords2 :: YieldSizeMap -> ((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 :: YieldSizeMap -> (RangeDesc,Int) -> [Subword1]+calcSubwords1 _ b | trace ("calcSubwordsIndependent " ++ show b) False = undefined+calcSubwords1 infoMap pos@((i,j,_),_) =+        let (minY,maxY) = yieldSizeOf infoMap pos+            (minYLeft,maxYLeft) = combinedYieldSizeLeftOf infoMap pos+            (minYRight,maxYRight) = combinedYieldSizeRightOf 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 :: YieldSizeMap -> 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 :: YieldSizeMap -> RangeDesc -> Int -> Int -> [Subword2]+doCalcSubwords2Dependent infoMap desc@(i,j,_) a1Idx a2Idx =+        let (minY1,maxY1) = yieldSizeOf infoMap (desc,a1Idx)+            (minY2,maxY2) = yieldSizeOf infoMap (desc,a2Idx)+            (minYLeft1,maxYLeft1) = combinedYieldSizeLeftOf infoMap (desc,a1Idx)+            (minYRight1,maxYRight1) = combinedYieldSizeRightOf infoMap (desc,a1Idx)+            (minYRight2,maxYRight2) = combinedYieldSizeRightOf 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/Constraint/MonadicCpHelper.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module ADP.Multi.Constraint.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