packages feed

homeomorphic (empty) → 0.1

raw patch · 15 files changed

+601/−0 lines, 15 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, mtl

Files

+ Data/Homeomorphic.hs view
@@ -0,0 +1,35 @@++module Data.Homeomorphic(+    Shell, shell,+    (<<|), couple, dive,+    Homeomorphic, empty, insert, find, findOne+    ) where++import qualified Data.Homeomorphic.MemoCache as H+import Data.Homeomorphic.Internal++-- wrap the Homeomorphic library in a newtype, to get+-- better haddocks in the right place+--+-- document the general interface here, document the specific variants+-- in the individual modules++-- | Datatype to store a homemorphic embedding.+newtype Homeomorphic k v = Homeomorphic (H.Homeomorphic k v)++-- | An empty embedding+empty :: Homeomorphic k v+empty = Homeomorphic H.empty++-- | Insert a new key (coded as a shell) and an associated value+--   into an embedding.+insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v+insert a b (Homeomorphic c) = Homeomorphic (H.insert a b c)++-- | Does any relation xs <| y hold, given y.+find :: Ord k => Shell k -> Homeomorphic k v -> [v]+find a (Homeomorphic b) = H.find a b++-- | @findOne y = listToMaybe . find y@+findOne :: Ord k => Shell k -> Homeomorphic k v -> Maybe v+findOne a (Homeomorphic b) = H.findOne a b
+ Data/Homeomorphic/Check.hs view
@@ -0,0 +1,68 @@++module Data.Homeomorphic.Check where++import qualified Data.Homeomorphic.Simple as H1+import qualified Data.Homeomorphic.SimpleParallel as H2+import qualified Data.Homeomorphic.Hash1 as H3+import qualified Data.Homeomorphic.Hash2 as H4+import qualified Data.Homeomorphic.Memo as H5+import qualified Data.Homeomorphic.MemoCache as H6++import Data.Homeomorphic.Internal+import Data.Maybe+import Data.List(sort,(\\))+++data Homeomorphic k v = Homeomorphic+    (H1.Homeomorphic k v)+    (H2.Homeomorphic k v)+    (H3.Homeomorphic k v)+    (H4.Homeomorphic k v)+    (H5.Homeomorphic k v)+    (H6.Homeomorphic k v)++empty :: Homeomorphic k v+empty = Homeomorphic+    H1.empty+    H2.empty+    H3.empty+    H4.empty+    H5.empty+    H6.empty+++insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v+insert k v (Homeomorphic h1 h2 h3 h4 h5 h6) = Homeomorphic+    (H1.insert k v h1)+    (H2.insert k v h2)+    (H3.insert k v h3)+    (H4.insert k v h4)+    (H5.insert k v h5)+    (H6.insert k v h6)+++-- additional Eq v constraint required to check the answers+-- additional Show constraints required to give a meainingful error message+find :: (Ord k, Eq v, Show v, Show k) => Shell k -> Homeomorphic k v -> [v]+find k (Homeomorphic h1 h2 h3 h4 h5 h6) = check+    [H1.find k h1 >< H1.findOne k h1+    ,H2.find k h2 >< H2.findOne k h2+    ,H3.find k h3 >< H3.findOne k h3+    ,H4.find k h4 >< H4.findOne k h4+    ,H5.find k h5 >< H5.findOne k h5+    ,H6.find k h6 >< H6.findOne k h6+    ]+    where+        [] >< Nothing = []+        xs >< Just x | x `elem` xs = xs+        _ >< _ = error "Find, inconsistent between find and findOne"++        check (x:xs) | all (setEq x) xs = x+        check _ = error "Find, inconsistent between different ones"++        setEq x y = null (x \\ y) && null (y \\ x)+++-- find does lots of checking, so can just use that+findOne :: (Ord k, Eq v, Show v, Show k) => Shell k -> Homeomorphic k v -> Maybe v+findOne k = listToMaybe . find k
+ Data/Homeomorphic/Hash1.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}++#define NAME Hash1+#include "Include/Hash.hs"+++type Hash k = Set.Set (Int,k)++calcHash :: Ord k => Shell k -> Hash k+calcHash = f Set.empty+    where f x (Shell a b c) = foldl' f (Set.insert (b,a) x) c++-- important: calculate the hash of y only once per invokation+checkHash :: Ord k => Shell k -> Hash k -> Bool+checkHash y = (`Set.isSubsetOf` calcHash y)
+ Data/Homeomorphic/Hash2.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}++#define NAME Hash2+#include "Include/Hash.hs"+++-- how many of each arity+type Hash k = [(Int,Int)]++calcHash :: Ord k => Shell k -> Hash k+calcHash = IntMap.toAscList . f IntMap.empty+    where f x (Shell a b c) = foldl' f (IntMap.insertWith (\_ i -> i+1) b 1 x) c++-- important: calculate the hash of y only once per invokation+checkHash :: Ord k => Shell k -> Hash k -> Bool+checkHash y = (`listSubset` calcHash y)++listSubset [] _ = True+listSubset ((x1,x2):xs) ((y1,y2):ys) =+    case compare x1 y1 of+        EQ -> x2 <= y2 && listSubset xs ys+        LT -> False+        GT -> listSubset ((x1,x2):xs) ys+listSubset _ _ = False
+ Data/Homeomorphic/Include/Hash.hs view
@@ -0,0 +1,28 @@++module Data.Homeomorphic.NAME(+    Homeomorphic, empty, insert, find, findOne+    ) where++import Data.Homeomorphic.Internal+import Data.Maybe++import Data.List(foldl')+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+++data Homeomorphic k v = Homeomorphic [(Shell k, Hash k, v)]+++empty :: Homeomorphic k v+empty = Homeomorphic []++insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v+insert k v (Homeomorphic xs) = Homeomorphic ((k,calcHash k,v):xs)++find :: Ord k => Shell k -> Homeomorphic k v -> [v]+find k (Homeomorphic xs) = [c | (a,b,c) <- xs, check b, a <<| k]+    where check = checkHash k++findOne :: Ord k => Shell k -> Homeomorphic k v -> Maybe v+findOne k = listToMaybe . find k
+ Data/Homeomorphic/Internal.hs view
@@ -0,0 +1,40 @@++module Data.Homeomorphic.Internal where++import Test.QuickCheck+++-- | The central data type. All data structures must be converted so they+--   consist of @Shell@\'s, which split a value into a component at this+--   level and the children. Create a @Shell@ with 'shell'.+data Shell a = Shell a Int [Shell a]+               deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (Shell a) where+    arbitrary = sized $ \s -> do+        x <- arbitrary+        let c = resize (s `div` 2) arbitrary+        xs <- oneof $ map sequence $ take s [[], [c], [c,c], [c,c,c]]+        return $ shell x xs++    coarbitrary (Shell a b c) =+        error "Data.Homeomorphic.Internal.Arbitrary.coarbitrary: Not implemented"+++-- | Create a value with a component at the current level+--   and all the children.+shell :: a -> [Shell a] -> Shell a+shell a b = Shell a (length b) b+++-- | A simple homeomorphic embedding. /O(expensive)/+(<<|) :: Eq a => Shell a -> Shell a -> Bool+(<<|) x y = dive x y || couple x y++-- | Does the dive rule apply.+dive :: Eq a => Shell a -> Shell a -> Bool+dive x (Shell _ _ ys) = any (x <<|) ys++-- | Does the couple rule apply.+couple :: Eq a => Shell a -> Shell a -> Bool+couple (Shell x1 x2 x3) (Shell y1 y2 y3) = x1 == y1 && x2 == y2 && and (zipWith (<<|) x3 y3)
+ Data/Homeomorphic/Memo.hs view
@@ -0,0 +1,73 @@++module Data.Homeomorphic.Memo where++import Data.Homeomorphic.Internal+import Data.Maybe+import Data.IORef+import System.IO.Unsafe+import qualified Data.Map as Map+import Control.Monad.State+++data Homeomorphic k v = Homeomorphic (IORef (Cache k)) [(Shell k, v)]++type Cache k = Map.Map (Shell k) (Map.Map (Shell k) Bool)+++empty :: Homeomorphic k v+empty = Homeomorphic (unsafePerformIO $ newIORef Map.empty) []++insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v+insert k v (Homeomorphic a b) = Homeomorphic a ((k,v):b)++findOne :: Ord k => Shell k -> Homeomorphic k v -> Maybe v+findOne k = listToMaybe . find k++find :: Ord k => Shell k -> Homeomorphic k v -> [v]+find y (Homeomorphic a b) = concatMap f b+    where+        f (x,v) = unsafePerformIO $ do+            s <- readIORef a+            let (r,s2) = runState (test x y) s+            writeIORef a s2+            return [v | r]+++getCache :: Ord k => Shell k -> Shell k -> State (Cache k) (Maybe Bool)+getCache x y = do+    s <- get+    return $ Map.lookup y s >>= Map.lookup x+++addCache :: Ord k => Shell k -> Shell k -> Bool -> State (Cache k) ()+addCache x y b = modify $ Map.insertWith add y (Map.singleton x b)+    where add _ old = Map.insert x b old+++-- given a cache, test if it exists, then work the way back+test :: Ord k => Shell k -> Shell k -> State (Cache k) Bool+test x y = do+    v <- getCache x y+    case v of+        Just b -> return b+        Nothing -> do+            b <- diveM x y `orM` coupleM x y+            addCache x y b+            return b++diveM :: Ord k => Shell k -> Shell k -> State (Cache k) Bool+diveM x (Shell _ _ ys) = anyM (x `test`) ys++coupleM :: Ord k => Shell k -> Shell k -> State (Cache k) Bool+coupleM (Shell x1 x2 x3) (Shell y1 y2 y3)+    | x1 == y1 && x2 == y2 = andsM (zipWith test x3 y3)+    | otherwise = return False++++orM a b = do a <- a; if a then return True else b+orsM x = foldr orM (return False) x+anyM f = orsM . map f++andM a b = do a <- a; if a then b else return False+andsM x = foldr andM (return True) x
+ Data/Homeomorphic/MemoCache.hs view
@@ -0,0 +1,92 @@++module Data.Homeomorphic.MemoCache where++import Data.Homeomorphic.Internal+import Data.Maybe+import Data.IORef+import System.IO.Unsafe+import qualified Data.IntMap as Map+import Control.Monad.State+import Data.Homeomorphic.ShellId as S+++-- Both the data structures in IORef's store a minimum amount of information+-- If some action happens, and additional (useless) information is added, this will not+-- break correctness. Since IORef's are only modified to add info, they are safe.+data Homeomorphic k v = Homeomorphic (IORef Cache) [(ShellId, v)] (IORef (ShellIds k))++type Cache = Map.IntMap (Map.IntMap Bool)+++empty :: Homeomorphic k v+empty = Homeomorphic+    (unsafePerformIO $ newIORef Map.empty)+    []+    (unsafePerformIO $ newIORef S.empty)+++insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v+insert k v (Homeomorphic a b c) = unsafePerformIO $ do+    c2 <- readIORef c+    (c2,k2) <- return $ retrieve k c2+    writeIORef c c2+    return $ Homeomorphic a ((k2,v):b) c+++findOne :: Ord k => Shell k -> Homeomorphic k v -> Maybe v+findOne k = listToMaybe . find k+++find :: Ord k => Shell k -> Homeomorphic k v -> [v]+find y (Homeomorphic a b c) = concatMap f b+    where+        y2 = unsafePerformIO $ do+            c2 <- readIORef c+            (c2,y2) <- return $ retrieve y c2+            writeIORef c c2+            return y2++        f (x,v) = unsafePerformIO $ do+            s <- readIORef a+            let (r,s2) = runState (test x y2) s+            writeIORef a s2+            return [v | r]+++getCache :: ShellId -> ShellId -> State Cache (Maybe Bool)+getCache x y = do+    s <- get+    return $ Map.lookup (allId y) s >>= Map.lookup (allId x)+++addCache :: ShellId -> ShellId -> Bool -> State Cache ()+addCache x y b = modify $ Map.insertWith add (allId y) (Map.singleton (allId x) b)+    where add _ old = Map.insert (allId x) b old+++-- given a cache, test if it exists, then work the way back+test :: ShellId -> ShellId -> State Cache Bool+test x y | allId x == allId y = return True -- use the property the test is reflexive+test x y = do+    v <- getCache x y+    case v of+        Just b -> return b+        Nothing -> do+            b <- diveM x y `orM` coupleM x y+            addCache x y b+            return b++diveM :: ShellId -> ShellId -> State Cache Bool+diveM x y = anyM (x `test`) (restId y)++coupleM :: ShellId -> ShellId -> State Cache Bool+coupleM x y = return (headId x == headId y) `andM` andsM (zipWith test (restId x) (restId y))++++orM a b = do a <- a; if a then return True else b+orsM x = foldr orM (return False) x+anyM f = orsM . map f++andM a b = do a <- a; if a then b else return False+andsM x = foldr andM (return True) x
+ Data/Homeomorphic/ShellId.hs view
@@ -0,0 +1,40 @@++module Data.Homeomorphic.ShellId(+    ShellIds, ShellId(..), empty, retrieve+    ) where++import qualified Data.Map as Map+import Data.List+import Data.Homeomorphic.Internal+++data ShellId = ShellId {allId :: Int, headId :: Int, restId :: [ShellId]}++data ShellIds k = ShellIds+    (Map.Map (Shell k) ShellId)  -- for the entire result+    (Map.Map (k,Int) Int)              -- for the headId+++empty :: ShellIds k+empty = ShellIds Map.empty Map.empty+++retrieve :: Ord k => Shell k -> ShellIds k -> (ShellIds k, ShellId)+retrieve x@(Shell a b c) o@(ShellIds mAll mHead) =+    case Map.lookup x mAll of+        Just y -> (o, y)+        Nothing -> (ShellIds mAll3 mHead3, rAll)+            where+                (ShellIds mAll2 mHead2, cs) = mapAccumL (flip retrieve) o c+                (mHead3, rHead) = retrieveHead (a,b) mHead2+                rAll = ShellId (Map.size mAll2) rHead cs+                mAll3 = Map.insert x rAll mAll2+                  +++retrieveHead :: Ord k => (k,Int) -> Map.Map (k,Int) Int -> (Map.Map (k,Int) Int, Int)+retrieveHead x m =+    case Map.lookup x m of+        Just y -> (m, y)+        Nothing -> (Map.insert x r m, r)+            where r = Map.size m
+ Data/Homeomorphic/Simple.hs view
@@ -0,0 +1,20 @@++module Data.Homeomorphic.Simple where++import Data.Homeomorphic.Internal+import Data.Maybe++data Homeomorphic k v = Homeomorphic [(Shell k, v)]+++empty :: Homeomorphic k v+empty = Homeomorphic []++insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v+insert k v (Homeomorphic xs) = Homeomorphic ((k,v):xs)++find :: Ord k => Shell k -> Homeomorphic k v -> [v]+find k (Homeomorphic xs) = [b | (a,b) <- xs, a <<| k]++findOne :: Ord k => Shell k -> Homeomorphic k v -> Maybe v+findOne k = listToMaybe . find k
+ Data/Homeomorphic/SimpleParallel.hs view
@@ -0,0 +1,60 @@++module Data.Homeomorphic.SimpleParallel where++import qualified Data.Map as Map+import qualified Data.IntMap as IntMap++import Data.Homeomorphic.Internal+import Data.List+import Debug.Trace++{-+Problem: a <<| b may happen twice, since there may be+two different dive/couple ways to end up with a.++Solution: Store Int's, lookup each only once.+-}++data Homeomorphic k v = Homeomorphic (IntMap.IntMap v) (H k)++data H k = H [Int] (Map.Map (Int,k) (H k))+++empty :: Homeomorphic k v+empty = Homeomorphic IntMap.empty emptyH++emptyH = H [] Map.empty+++insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v+insert k v (Homeomorphic a b) = Homeomorphic (IntMap.insert i v a) (add (flatten k) b)+    where+        i = IntMap.size a+        flatten (Shell a b c) = (b,a) : concatMap flatten c++        add []     (H a b) = H (i:a) b+        add (x:xs) (H a b) = H a b2+            where+                b2 = Map.insertWith comb x (add xs emptyH) b+                comb new old = add xs old+++find :: Ord k => Shell k -> Homeomorphic k v -> [v]+find k (Homeomorphic a b) = map (a IntMap.!) res+    where res = reverse $ sort $ nub $ findIds [k] b+++findOne :: Ord k => Shell k -> Homeomorphic k v -> Maybe v+findOne k (Homeomorphic a b) =+    case findIds [k] b of+         [] -> Nothing+         i:_ -> Just $ a IntMap.! i+++findIds :: Ord k => [Shell k] -> H k -> [Int]+findIds []     (H ans _ ) = ans+findIds (k:ks) (H _   mp) = concatMap f (shell k)+    where+        f (a,b) = maybe [] (findIds $ b++ks) $ Map.lookup a mp++        shell (Shell a b c) = ((b,a), c) : concatMap shell c
+ Data/Homeomorphic/Test.hs view
@@ -0,0 +1,34 @@++module Data.Homeomorphic.Test where++import Data.Homeomorphic.Internal+import Data.Homeomorphic.Check++import Test.QuickCheck+import Control.Monad+import Data.List(sort)+++data AB = A | B+          deriving (Eq, Ord, Show)++instance Arbitrary AB where+    arbitrary = elements [A,B]+    coarbitrary = error "Data.Homoemorphic.Test.coarbitrary (ABC): Not implemented"+++data Command = Insert (Shell AB)+             | Find (Shell AB)+             deriving (Eq, Ord, Show)++instance Arbitrary Command where+    arbitrary = oneof [liftM Insert arbitrary, liftM Find arbitrary]+    coarbitrary = error "Data.Homoemorphic.Test.coarbitrary (Command): Not implemented"++++tester :: [Command] -> Bool+tester xs = foldl f empty (zip [0..] xs) `seq` True+    where+        f x (v,Insert k) = insert k v x+        f x (v,Find   k) = find k x `seq` x
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2007-2008.+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 Neil Mitchell 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ homeomorphic.cabal view
@@ -0,0 +1,40 @@+Cabal-Version:      >= 1.2+Name:               homeomorphic+Version:            0.1+Copyright:          2007-8, Neil Mitchell+Maintainer:         ndmitchell@gmail.com+Homepage:           http://www-users.cs.york.ac.uk/~ndm/homeomorphic/+License:            BSD3+License-File:       LICENSE+Build-Type:         Simple+Author:             Neil Mitchell+Category:           Math+Synopsis:           Homeomorphic Embedding Test+Description:+    A library to carry out homeomorphic embedding tests.+Extra-Source-Files:+    Data/Homeomorphic/Include/Hash.hs++Flag splitBase+    Description: Choose the new smaller, split-up base package.++Library+    if flag(splitBase)+        build-depends: base >= 3, QuickCheck, mtl, containers+    else+        build-depends: base <  3, QuickCheck, mtl++    Exposed-modules:+        Data.Homeomorphic+        Data.Homeomorphic.Check+        Data.Homeomorphic.Hash1+        Data.Homeomorphic.Hash2+        Data.Homeomorphic.Internal+        Data.Homeomorphic.Memo+        Data.Homeomorphic.MemoCache+        Data.Homeomorphic.ShellId+        Data.Homeomorphic.Simple+        Data.Homeomorphic.SimpleParallel+        Data.Homeomorphic.Test++    Extensions: CPP