AlanDeniseEricLauren (empty) → 0.1.0.0
raw patch · 7 files changed
+482/−0 lines, 7 filesdep +AlanDeniseEricLaurendep +MonadRandomdep +QuickChecksetup-changed
Dependencies added: AlanDeniseEricLauren, MonadRandom, QuickCheck, base, containers, criterion, hspec, hspec-core, mtl, random, random-shuffle, transformers, vector
Files
- AlanDeniseEricLauren.cabal +60/−0
- LICENSE +30/−0
- README.md +23/−0
- Setup.hs +2/−0
- bench/Main.hs +37/−0
- src/ADEL.hs +212/−0
- test/Main.hs +118/−0
+ AlanDeniseEricLauren.cabal view
@@ -0,0 +1,60 @@+name: AlanDeniseEricLauren+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2016 Echo Nolan+maintainer: echo@echonolan.net+homepage: http://github.com/enolan/AlanDeniseEricLauren+synopsis: Find the minimal subset/submap satisfying some property.+description:+ Please see README.md+category: Algoritms+author: Echo Nolan+extra-doc-files: README.md++library+ exposed-modules:+ ADEL+ build-depends:+ base >=4.8.2.0 && <4.9,+ containers >=0.5.6.2 && <0.6,+ MonadRandom >=0.4.2.3 && <0.5,+ mtl >=2.2.1 && <2.3,+ random ==1.1.*,+ random-shuffle >=0.0.4 && <0.1,+ vector >=0.11.0.0 && <0.12+ default-language: Haskell2010+ default-extensions: FlexibleContexts RankNTypes+ hs-source-dirs: src+ ghc-options: -fdefer-typed-holes -Wall -O2++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends:+ AlanDeniseEricLauren >=0.1.0.0 && <0.2,+ base >=4.8.2.0 && <4.9,+ containers >=0.5.6.2 && <0.6,+ hspec >=2.2.3 && <2.3,+ hspec-core >=2.2.3 && <2.3,+ QuickCheck >=2.8.2 && <2.9,+ random ==1.1.*,+ transformers >=0.4.2.0 && <0.5,+ MonadRandom >=0.4.2.3 && <0.5+ default-language: Haskell2010+ default-extensions: ScopedTypeVariables+ hs-source-dirs: test++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends:+ AlanDeniseEricLauren >=0.1.0.0 && <0.2,+ base >=4.8.2.0 && <4.9,+ containers >=0.5.6.2 && <0.6,+ criterion >=1.1.1.0 && <1.2+ default-language: Haskell2010+ hs-source-dirs: bench+ ghc-options: -O2
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Echo Nolan 2016++All rights reserved.++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.++ * Neither the name of Author name here nor the names of other+ contributors may 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.
+ README.md view
@@ -0,0 +1,23 @@+AlanDeniseEricLauren is an implementation of the ADEL algorithm for efficiently+finding the minimal subset of an input set satisfying some arbitrary+upward-closed property. "Upward-closed" means if the property is true of some+set S it is true of all supersets of S. My implementation is trivially extended+to maps (dictionaries).++This can be used for e.g. narrowing down bugs by finding the minimal subset of+a complex failing test case that still exhibits the issue. In addition, I+provide a method for finding the minimal set of *changes* between a known-good+and known-bad example needed to trigger a bug. (Equivalently, a set where the+property is false and a set where it's true.)++The ADEL algorithm is due to Philippe Laborie in his paper "An Optimal Iterative+Algorithm for Extracting MUCs in a Black-box Constraint Network" published in+ECAI 2014. doi:10.3233/978-1-61499-419-0-1051. The paper is available at+http://ebooks.iospress.nl/publication/37115.++The project's homepage is https://github.com/enolan/AlanDeniseEricLauren. Bug+reports and PRs can be submitted there.++As of August 2016, I am looking for work. If your company needs a good+programmer, my email is echo@echonolan.net. My resume is available+[here](http://www.echonolan.net/resume/cv.html).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TupleSections #-}+module Main (main) where++import Criterion.Main+import qualified Data.Map.Strict as M++import ADEL++mapUpTo :: Int -> M.Map Int ()+mapUpTo x = M.fromList $ map (,()) [0 .. x]++findNofM :: Int -> Int -> Benchmark+findNofM numToFind totalNum = if numToFind > totalNum+ then bench "numToFind > totalNum" $ nfIO (return ()) --error "findNofM numToFind > totalNum"+ else env+ (return (mapUpTo numToFind, mapUpTo totalNum))+ (\ ~(find, whole) -> bench+ ("find " ++ show numToFind ++ " of " ++ show totalNum)+ (nfIO $ minimalSubmapSatisfying whole (return . M.isSubmapOf find)))++findHalf :: Int -> Benchmark+findHalf n = findNofM (n `div` 2) n++findNone :: Int -> Benchmark+findNone = findNofM 0++findAll :: Int -> Benchmark+findAll n = findNofM n n++range = [0, 2500..100000]++main = defaultMain $ concat+ [map findHalf [0,2500..20000],+ map findAll range,+ map findNone range,+ map (findNofM 20) range,+ map (findNofM 50) range]
+ src/ADEL.hs view
@@ -0,0 +1,212 @@+-- | Construct minimal submaps satisfying arbitrary properties. This extends to+-- sets by simply creating a @Map k ()@. Based on the ADEL algorithm from "An+-- Optimal Iterative Algorithm for Extracting MUCs in a Black-box Constraint+-- Network" Philippe Laborie, ECAI 2014. doi:10.3233/978-1-61499-419-0-1051+-- available at: http://ebooks.iospress.nl/publication/37115++module ADEL+ (minimalSubmapSatisfying+ , minimalDifferenceSatisfying+ , KeyDiff(..)+ , mapDifference+ , applyDifference) where++import Control.Monad.Random+import Control.Monad.Reader+import Control.Monad.State.Strict+import qualified Data.Vector as V+import qualified Data.Map.Strict as M+import System.Random.Shuffle (shuffleM)++-- | Given a map M and a function that describes an upward-closed property on+-- maps, return the minimal submap of M satisfying the property.+--+-- Assumptions:+--+-- * M satisfies the property.+--+-- * the property is "upward-closed" i.e. for all maps N where the property+-- is true, the property is true of all supermaps of N.+--+-- This is a Las Vegas-ish algorithm. You need 'MonadRandom' but the result is+-- deterministic provided the passed predicate is deterministic and there is a+-- unique minimal submap.+minimalSubmapSatisfying :: (MonadRandom m, Ord k) =>+ M.Map k v -> (M.Map k v -> m Bool) -> m (M.Map k v)+minimalSubmapSatisfying bigMap p = do+ trueOfWholeMap <- p bigMap+ unless trueOfWholeMap $ error+ "minimalSubMapSatisfyingM: supplied property isn't true of supplied map"+ runADELT bigMap p $ go 0 (M.size bigMap) 0 0+ where+ go idx step elDistanceSum elCount = do+ newI <- findNext idx step+ case newI of+ Nothing -> get+ Just newI' -> do+ let elDistanceSum' = elDistanceSum + newI' + 1 - idx+ elCount' = elCount + 1+ step' = elDistanceSum' `div` elCount'+ recur = go (newI' + 1) step' elDistanceSum' elCount'+ recur++-- We need to carry around: the map being minimized, a random permutation of the+-- keys, and the property of interest.+type ADELT k v m a = (Ord k, Monad m) =>+ StateT (M.Map k v) (ReaderT (V.Vector (k, v), M.Map k v -> m Bool) m) a++runADELT :: (Ord k, MonadRandom m) =>+ M.Map k v -> (M.Map k v -> m Bool) -> ADELT k v m a -> m a+runADELT m p adelT = do+ shuffledKeys <- V.fromList <$> shuffleM (M.toList m)+ runReaderT (evalStateT adelT m) (shuffledKeys, p)++mapSatisfies :: ADELT k v m Bool+mapSatisfies = do+ p <- snd <$> ask+ mapBeingConstructed <- get+ -- Never change, monad transformers+ lift $ lift $ p mapBeingConstructed++-- Find the next element of the minimal submap or return Nothing if the current+-- candidate already satisfies the property.+-- Postcondition: the map has exactly the elements between idx and the return+-- value removed.+findNext :: Int -> Int -> ADELT k v m (Maybe Int)+findNext idx step = do+ mbInterval <- accelerate idx step+ case mbInterval of+ Nothing -> return Nothing+ Just (lower, upper) ->+ Just <$> dichotomize lower upper++-- Acceleration step: we test exponentially smaller submaps until we either find+-- the interval the next element of the minimal submap must be in, or find out+-- the property is true with all the elements after idx removed.+-- Precondition: the property is satisfied+-- Postcondition:+-- - if Just is returned, the map has exactly the elements with indices+-- between idx and the returned upper bound removed and the property is not+-- satisfied.+-- - if Nothing is returned, the map has all elements after idx removed.+accelerate :: Int -> Int -> ADELT k v m (Maybe (Int, Int))+accelerate idx step = do+ shuffled <- fst <$> ask+ if idx >= V.length shuffled+ then return Nothing+ else do modify $ \m -> rmSlice idx step m shuffled+ accelerate' idx step idx++-- Precondition: the elements between idx and idx + step and not in the map.+accelerate' :: Int -> Int -> Int -> ADELT k v m (Maybe (Int, Int))+accelerate' idx step lowerBound = do+ shuffled <- fst <$> ask+ satisfies <- mapSatisfies+ if satisfies+ then if idx + step < V.length shuffled+ then do modify $ \m -> rmSlice (idx + step) step m shuffled+ accelerate' idx (step * 2) (idx + step)+ else return Nothing+ else return $ Just (lowerBound, min (V.length shuffled) (idx + step) - 1)++-- Remove the len elements in a vector starting at start from a map.+rmSlice :: Ord k => Int -> Int -> M.Map k v -> V.Vector (k, v) -> M.Map k v+rmSlice start len inMap elsVec =+ V.foldl' (\m (k,_) -> M.delete k m) inMap elsToRemove+ where elsToRemove = if start + len <= V.length elsVec+ then V.slice start len elsVec+ else sliceToEnd start elsVec++addSlice :: Int -> Int -> ADELT k v m ()+addSlice idx len = do+ vect <- fst <$> ask+ let sliceToAdd = V.slice idx len vect+ modify $ \m -> V.foldl'+ (\m' (k, v) -> M.insert k v m')+ m+ sliceToAdd++-- Slice from a given index (inclusive) to the end of a vector.+sliceToEnd :: Int -> V.Vector a -> V.Vector a+sliceToEnd x v = let len = V.length v in if x > len then+ error "sliceToEnd: index out of range" else+ V.slice x (len - x) v++-- Given an interval, find the next element of the minimal submap by binary+-- search.+-- Precondition:+-- - the elements with indices greater than the upper bound are in the map+-- - the minimal next element has an index between the lower and upper bounds+-- Postcondition: All the elements after the initial lower bound and before the+-- returned index are removed.+dichotomize :: Int -> Int -> ADELT k v m Int+dichotomize lower upper = do+ let midpoint' = midpoint lower upper+ addSlice midpoint' (upper - midpoint' + 1)+ dichotomize' lower upper++-- Precondition: the elements with indices >= ceil((lower + upper) / 2) are in+-- the map.+dichotomize' :: Int -> Int -> ADELT k v m Int+dichotomize' lower upper = do+ shuffled <- fst <$> ask+ let midpoint' = midpoint lower upper+ if lower == upper+ then do addSlice lower 1+ return lower+ else do+ satisfies <- mapSatisfies+ if satisfies+ then do let newMidpoint = midpoint midpoint' upper+ modify $ \m -> rmSlice midpoint' (newMidpoint - midpoint') m shuffled+ dichotomize' midpoint' upper+ else do let newMidpoint = midpoint lower (midpoint' - 1)+ addSlice newMidpoint (midpoint' - newMidpoint)+ dichotomize' lower (midpoint' - 1)++midpoint :: Int -> Int -> Int+midpoint lower upper = ceiling $+ (fromIntegral lower + fromIntegral upper :: Double) / 2++-- | A change in a key of a 'M.Map'.+data KeyDiff v = Removed+ | Added v+ | Changed v+ deriving (Eq, Show, Read)++-- | An invertible map difference. Regular 'M.difference' only gives you things+-- that are in the first map but not the second. This tracks keys that are+-- in the second map but not in the first, as well as keys that are in both maps+-- with different values.+mapDifference ::+ (Ord k, Eq v) => M.Map k v -> M.Map k v -> M.Map k (KeyDiff v)+mapDifference = M.mergeWithKey both left right where+ both _ av bv = if av == bv then Nothing else Just $ Changed bv+ left = M.map (const Removed)+ right = M.map Added++-- | Given a map and and a difference, apply the difference.+--+-- prop> applyDifference m (mapDifference m n) = n+applyDifference :: Ord k => M.Map k v -> M.Map k (KeyDiff v) -> M.Map k v+applyDifference = M.mergeWithKey both left right where+ both _ _ Removed = Nothing+ both _ _ (Added _ ) = error "impossible, applyDifference both Added"+ both _ _ (Changed v) = Just v+ left = id+ right = M.map checkDiff+ checkDiff Removed = error "impossible, applyDifference right Removed"+ checkDiff (Added v) = v+ checkDiff (Changed _) = error "impossible, applyDifference right Changed"++-- | Given a property P, a map for which P is false and a map for which P is+-- true, find the minimal set of changes from the first map to the second map+-- that makes the property true.+--+-- The comments re randomness from 'minimalSubmapSatisfying' applies.+minimalDifferenceSatisfying :: (Eq v, Ord k, MonadRandom m) =>+ M.Map k v -> M.Map k v -> (M.Map k v -> m Bool) -> m (M.Map k (KeyDiff v))+minimalDifferenceSatisfying falseSet trueSet prop =+ let largestDifference = mapDifference falseSet trueSet+ prop' diff = prop $ applyDifference falseSet diff in+ minimalSubmapSatisfying largestDifference prop'
+ test/Main.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TupleSections,TypeFamilies #-}+import Control.Exception (ErrorCall(..), try)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Random (evalRand, Rand, RandT)+import Data.Functor.Identity (Identity)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (sort)+import qualified Data.Map.Strict as M+import Data.Maybe (fromJust, isNothing)+import Data.Ord (Down(..))+import System.Random (getStdGen, mkStdGen, RandomGen, StdGen)+import Test.Hspec+import Test.Hspec.Core.Spec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import ADEL++main :: IO ()+main = hspec $ do+ describe "minimalSubmapSatisfying" $ do+ before getStdGen $ do+ it "finds the minimal submap of empty maps" $ idRand $ do+ res <- minimalSubmapSatisfying+ (makeSizedMap 0)+ (const (return True))+ return (res `shouldBe` M.empty)+ it "finds a subset of size 5" $ idRand $ do+ res <- minimalSubmapSatisfying+ (makeSizedMap 200)+ (\m -> return $ M.size m >= 5)+ return (res `shouldSatisfy` (\m -> M.size m == 5))+ prop "finds a subset of arbitrary size" $+ \sizeA sizeB -> idRand $ do+ let [NonNegative smaller, NonNegative bigger] =+ sort [sizeA, sizeB]+ submap <- minimalSubmapSatisfying+ (makeSizedMap bigger)+ (\m -> return $ M.size m >= smaller)+ return $ M.size submap == smaller+ prop "finds a specific arbitrary subset" $+ \nums -> not (null nums) ==> idRand $ do+ let nums' :: [Int] = map (\(Down n) -> n) $ sort $+ map (Down . getPositive) nums+ bigSet = makeSizedMap (head nums')+ subsetNums = M.fromList $ map (,()) $ tail nums'+ res <- minimalSubmapSatisfying+ bigSet+ (return . M.isSubmapOf subsetNums)+ return $ res == subsetNums+ prop+ "throws an exception if the property is not true of the argument"+ $ \size -> ioProperty $ do+ res <- try (minimalSubmapSatisfying+ (makeSizedMap size)+ (return . const False))+ case res of+ Left (ErrorCall _) -> return True+ _ -> return False+ describe "minimalDifferenceSatisfying" $ do+ prop "finds minimal additions to an empty set"+ $ \(els :: [(Int, ())]) -> idRand $ do+ let targetSet = M.fromList els+ res <- minimalDifferenceSatisfying+ M.empty+ targetSet+ (\s -> return $ targetSet `M.isSubmapOf` s)+ return $ res == fmap Added targetSet+ prop "adds the minimal set with arbitrary false and true parameters"+ $ \(elsTrue :: [(Int, ())]) cutoff (elsFalse :: [(Int, ())]) ->+ cutoff < length elsTrue &&+ disjoint (M.fromList elsTrue) (M.fromList elsFalse) ==>+ idRand $ do+ let alreadyThere = M.fromList $ take cutoff elsTrue+ falseSet = M.fromList elsFalse+ trueSet = M.fromList elsTrue+ expectedResult = fmap Added (M.difference trueSet alreadyThere)+ res <- minimalDifferenceSatisfying+ (falseSet `M.union` alreadyThere)+ (falseSet `M.union` trueSet)+ (\s -> return $ trueSet `M.isSubmapOf` s)+ return $ res === expectedResult+ prop "removes the correct arbitrary element" $+ \(els1 :: [(Int, Char)])+ (els2 :: [(Int, Char)])+ (toRemove :: (Int, Char)) -> idRand $ do+ let trueSet = M.delete (fst toRemove) (M.fromList els1)+ falseSet = uncurry M.insert toRemove $ M.fromList els2+ res <- minimalDifferenceSatisfying+ falseSet+ trueSet+ (return . isNothing . M.lookup (fst toRemove))+ return (res === M.singleton (fst toRemove) Removed)++disjoint :: (Ord k, Eq v) => M.Map k v -> M.Map k v -> Bool+disjoint m1 m2 = M.intersection m1 m2 == M.empty++instance RandomGen g => Example (RandT g Identity Expectation) where+ type Arg (RandT g Identity Expectation) = g+ evaluateExample randEx params act progressCallback = do+ resRef <- newIORef Nothing+ act $ \gen -> writeIORef resRef $ Just $ evalRand randEx gen+ res <- fromJust <$> readIORef resRef+ evaluateExample res params (\act' -> act' ()) progressCallback++instance Arbitrary StdGen where+ arbitrary = mkStdGen <$> arbitrary++idRand :: Rand StdGen a -> Rand StdGen a+idRand = id++makeSizedMap :: Int -> M.Map Int ()+makeSizedMap 0 = M.empty+makeSizedMap n | n > 0 = M.insert n () $ makeSizedMap (n-1)+ | otherwise = error "makeSizedMap negative"++instance Testable prop => Testable (Rand StdGen prop) where+ property randAct = property $ \g -> evalRand randAct g