relation 0.2.1 → 0.3
raw patch · 6 files changed
+530/−803 lines, 6 filesdep +hedgehogdep +hspecdep +hw-hspec-hedgehogdep −arraydep −groomdep ~basedep ~containersnew-uploader
Dependencies added: hedgehog, hspec, hw-hspec-hedgehog, relation
Dependencies removed: array, groom
Dependency ranges changed: base, containers
Files
- Changes.txt +0/−3
- Examples/T01_Relation.hs +0/−100
- relation.cabal +44/−64
- src/Data/Relation.hs +485/−444
- src/Data/Relation/Examples/E02.hs +0/−192
- test/Spec.hs +1/−0
− Changes.txt
@@ -1,3 +0,0 @@- Change log. - - 2010/nov/14 [LFL]: coined as a library.
− Examples/T01_Relation.hs
@@ -1,100 +0,0 @@--- | Leonel Fonseca. 2010/nov/14. --- Dull test module. - -module T01_Relation - -where - -import qualified Data.Relation as R -import qualified Data.Set as S -import qualified Data.Map as M -import Data.Maybe (fromMaybe) - -x1 :: [(Int, String)] -x1 = [ (1, "a"), (1, "b"), (1, "c"), (2, "c") - , (2, "f"), (2, "g"), (1, "d") - ] - - -r01 = R.fromList x1 -- construye a partir de una lista. -r02 = R.empty -- construye una relación vacía. -r03 = R.singleton 2 "c" -- construye una relación unitaria. -r04 = R.singleton 3 "i" -r05 = R.insert 3 "i" r03 - -t01 r = putStrLn $ - "size = " ++ (show $ R.size r) - ++ (if x1 == R.toList r01 - then "\ntoList funciona como identidad " - else "\ntoList no converge ") - ++ (if (r02 `R.union` r01 == r01 `R.union` r02) - then "\nunion tiene elemento neutro" - else "\nunion no converge") - - -r06 = R.unions [r01, r02, r03, r04] -r07 = r01 `R.union` r04 - -- Concatena una lista de relaciones -t02 = if r06 == r07 - then "unions ok" - else "unions falla" - -t03 = if R.null r02 && (not . R.null) r01 - then "null ok" - else "null incorrecto" - - --- genera un producto cartesiano entre --- el dominio a asociado al N --- y el rango asociado a C. --- Luego para cada elemento del producto cartesiano, --- indica si ese par existe en la relación r01. - -t04 n c = map mem drive - - where - - mem = \(x,y) -> (x, y, R.member x y r01) - - -- proyecta y de (1,y) - dom = S.toList . fromMaybe S.empty $ R.lookupDom n r01 - - -- proyecta x de (x,"c") - ran = S.toList . fromMaybe S.empty $ R.lookupRan c r01 - - -- recombinarlos dominios y rangos de parejas - -- distintas produce pares que antes no existían. - drive = [ (x,y) | x <- ran, y <- dom ] - - - -- otra versión -t04b n c = map mem drive - - where - - mem = \(x,y) -> (x, y, R.member x y r01) - - -- proyecta y de (1,y) - dom = S.toList . fromMaybe S.empty $ R.lookupDom n r01 - - -- proyecta x de (x,"c") - ran = S.toList . fromMaybe S.empty $ R.lookupRan c r01 - - -- recombinarlos dominios y rangos de parejas - -- distintas produce pares que antes no existían. - drive = [ (x,y) | x <- ran, y <- dom ] - -t05 = R.member 2 "c" r01 - -r08 = R.delete 1 "a" $ - R.delete 1 "b" $ - R.delete 1 "d" $ - r01 - -t06 = (R.dom r01) R.<$| (R.ran r01) $ r01 - -t07 = (R.dom r01) R.|$> (R.ran r01) $ r01 - -t09 = (R.dom r01) R.<$| (R.ran r08) $ r01 -- usando r08 - -t10 = (S.singleton 1) R.|$> (R.ran r01) $ r01
relation.cabal view
@@ -1,80 +1,60 @@+cabal-version: 2.2+ name: relation-version: 0.2.1+version: 0.3 synopsis: A data structure representing Relations on Sets.-description:- A library to model relationships between two objects that are subclasses of- Ord.- .- Instead using a Map structure we use a two Maps that allows - fast searching either by the key element or the value element.- .- Each of Map is between an element and a set of values. - Thus careful coordination of operations is required.- . - This library lacks of extensive testing, formal testing or automated testing.- Also in comparison to Data.Set or Data.Map (which provide the underlying- infrastructure used) there are some missing methods.- . - Two small examples are currently provided.- .- Changes:- .- @- \ 0.2 -> 0.2.1 2012.06.07. DD. Added Doctests, Example02. Added "Text.Groom" dependency.- .- \ 0.1 -> 0.2 2012.06.06. DD. Translated to English.- .- \ 0.1 2009.11.09. LFL. Corrected the definition of delete.- .- \ 0.0 2009.11.26. LFL. Construction- @- .-homepage: https://www.github.com/d-day/relation/-bug-reports: https://www.github.com/d-day/relation/issues-license: BSD3+description: A library to model relationships between two objects that are subclasses of Ord.++ We use a two Maps that allows fast searching either by the key element or the value element.+homepage: https://www.github.com/haskell-works/relation/+bug-reports: https://www.github.com/haskell-works/relation/issues+license: BSD-3-Clause license-file: LICENSE author: Leonel Fonseca-maintainer: Drew Day-copyright: (C) 2012 Drew Day,+maintainer: John Ky+copyright: (C) 2019 John Ky,+ (C) 2012 Drew Day, (C) 2010 Leonel Fonseca category: Data Structures stability: Experimental build-type: Simple-cabal-version: >= 1.8 tested-with: GHC==7.4--extra-source-files:- LICENSE+extra-source-files: LICENSE README.md- Changes.txt- src/Data/Relation.hs- src/Data/Relation/Examples/E02.hs- Examples/T01_Relation.hs --library- hs-source-dirs : src- exposed-modules: Data.Relation,- Data.Relation.Examples.E02-- build-depends : base >= 4.2 && < 6.0,- array >= 0.4 && < 0.5,- containers >= 0.4 && < 0.6,--- doctest >= 0.7.0 && < 0.8,- groom >= 0.1.1 && < 0.2----- test-suite dt-examples--- type: exitcode-stdio-1.0--- hs-source-dirs: tests--- main-is: doctest-examples.hs--- ghc-options: -threaded--- build-depends: base >= 4.2 && < 6.0,--- doctest >= 0.7.0 && < 0.8- source-repository head type: git- location: https://www.github.com/d-day/relation+ location: https://www.github.com/haskell-works/relation +common base { build-depends: base >= 4 && < 5 } +common containers { build-depends: containers >= 0.5 && < 0.7 }+common hedgehog { build-depends: hedgehog >= 0.5 && < 0.7 }+common hspec { build-depends: hspec >= 2.4 && < 3 }+common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.4 && < 0.2 } +common common+ default-language: Haskell2010+ ghc-options: -Wall -O2++library+ import: base, common+ , containers+ hs-source-dirs: src+ exposed-modules: Data.Relation++test-suite relation-test+ import: base+ , common+ , hedgehog+ , hspec+ , hw-hspec-hedgehog+ build-depends: relation+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-depends: relation+ other-modules: Paths_relation+ autogen-modules: Paths_relation+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends: hspec-discover:hspec-discover
src/Data/Relation.hs view
@@ -1,444 +1,485 @@------------------------------------------------------------------------------ --- | --- Module : Data.Relation --- Copyright : (c) DD. 2012 --- (c) LFL. 2009 --- License : BSD-style --- Maintainer : Drew Day<drewday@gmail.com> --- Stability : experimental --- Portability : portable --- --- Relations are modeled as assciations between two elements. --- --- Relations offer efficient search for any of the two elements. --- --- Unlike "Data.Map", an element ca be associated more than once. --- --- The two purposes of this structure are: --- --- 1. Associating elements --- --- 2. Provide efficient searches for either of the two elements. --- --- Since neither 'map' nor 'fold' are implemented, you /must/ convert --- the structure to a list to process sequentially. --- --- -module Data.Relation ( - - -- * The @Relation@ Type - - Relation () - - -- * Provided functionality: - - -- ** Questions - - , size -- # Tuples in the relation? - , null -- Is empty? - - -- ** Construction - - , empty -- Construct an empty relation. - , fromList -- Relation <- [] - , singleton -- Construct a relation with a single element. - - -- ** Operations - - , union -- Union of two relations. - , unions -- Union on a list of relations. - , insert -- Insert a tuple to the relation. - , delete -- Delete a tuple from the relation. - -- The Set of values associated with a value in the domain. - , lookupDom - -- The Set of values associated with a value in the range. - , lookupRan - , memberDom -- Is the element in the domain? - , memberRan -- Is the element in the range? - , member -- Is the tuple in the relation? - , notMember - - -- ** Conversion - - , toList -- Construct a list from a relation - -- Extract the elements of the range to a Set. - , dom - -- Extract the elements of the domain to a Set. - , ran - - -- ** Utilities - - , compactSet -- Compact a Set of Maybe's. - - -- $selectops - , (|$>) -- Restrict the range according to a subset. PICA. - - , (<$|) -- Restrict the domain according to a subset. PICA. - - , (<|) -- Domain restriction. Z. - - , (|>) -- Range restriction. z. - - -- Not implemented - -- filter :: (a -> b -> Bool) -> Relation a b -> Relation a b - -- map -) - -where - -import Prelude hiding (null) -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Maybe (isJust, fromJust, fromMaybe) - --- | --- This implementation avoids using @"S.Set (a,b)"@ because --- it it is necessary to search for an item without knowing both @D@ and @R@. --- --- In "S.Set", you must know both values to search. --- --- Thus, we have are two maps to updated together. --- --- 1. Always be careful with the associated set of the key. --- --- 2. If you union two relations, apply union to the set of values. --- --- 3. If you subtract, take care when handling the set of values. --- --- As a multi-map, each key is asscoated with a Set of values v. --- --- We do not allow the associations with the 'empty' Set. --- - -data Relation a b = Relation { domain :: M.Map a (S.Set b) - , range :: M.Map b (S.Set a) - } - - deriving (Show, Eq, Ord) - - --- * Functions about relations - - --- The size is calculated using the domain. --- | @size r@ returns the number of tuples in the relation. - -size :: Relation a b -> Int -size r = M.fold ((+) . S.size) 0 (domain r) - - - --- | Construct a relation with no elements. - -empty :: Relation a b -empty = Relation M.empty M.empty - - - --- | --- The list must be formatted like: [(k1, v1), (k2, v2),..,(kn, vn)]. - -fromList :: (Ord a, Ord b) => [(a, b)] -> Relation a b -fromList xs = - Relation - { domain = M.fromListWith S.union $ snd2Set xs - , range = M.fromListWith S.union $ flipAndSet xs - } - where - snd2Set = map ( \(x,y) -> (x, S.singleton y) ) - flipAndSet = map ( \(x,y) -> (y, S.singleton x) ) - - --- | --- Builds a List from a Relation. -toList :: Relation a b -> [(a,b)] -toList r = concatMap - ( \(x,y) -> zip (repeat x) (S.toList y) ) - ( M.toList . domain $ r) - - - --- | --- Builds a 'Relation' consiting of an association between: @x@ and @y@. - -singleton :: a -> b -> Relation a b -singleton x y = Relation - { domain = M.singleton x (S.singleton y) - , range = M.singleton y (S.singleton x) - } - - - --- | The 'Relation' that results from the union of two relations: @r@ and @s@. - -union :: (Ord a, Ord b) - => Relation a b -> Relation a b -> Relation a b - -union r s = - Relation - { domain = M.unionWith S.union (domain r) (domain s) - , range = M.unionWith S.union (range r) (range s) - } - - ---------------------------------------------------------------- --- | --- This fragment provided by: --- --- @ --- \ Module : Data.Map --- \ Copyright : (c) Daan Leijen 2002 --- \ (c) Andriy Palamarchuk 2008 --- \ License : BSD-style --- \ Maintainer : libraries\@haskell.org --- \ Stability : provisional --- \ Portability : portable --- @ --- --- -foldlStrict :: (a -> b -> a) -> a -> [b] -> a -foldlStrict f z xs = case xs of - [] -> z - (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) ---------------------------------------------------------------- - - --- | Union a list of relations using the 'empty' relation. - -unions :: (Ord a, Ord b) => [Relation a b] -> Relation a b - -unions = foldlStrict union empty - - - --- | Insert a relation @ x @ and @ y @ in the relation @ r @ - -insert :: (Ord a, Ord b) - => a -> b -> Relation a b -> Relation a b - -insert x y r = -- r { domain = domain', range = range' } - Relation domain' range' - where - domain' = M.insertWith S.union x (S.singleton y) (domain r) - range' = M.insertWith S.union y (S.singleton x) (range r) - - --- $deletenotes --- --- The deletion is not difficult but is delicate: --- --- @ --- r = { domain { (k1, {v1a, v3}) --- , (k2, {v2a}) --- , (k3, {v3b, v3}) --- } --- , range { (v1a, {k1} --- , (v2a, {k2{ --- , (v3 , {k1, k3} --- , (v3b, {k3} --- } --- } --- @ --- --- To delete (k,v) in the relation do: --- 1. Working with the domain: --- 1a. Delete v from the Set VS associated with k. --- 1b. If VS is empty, delete k in the domain. --- 2. Working in the range: --- 2a. Delete k from the Set VS associated with v. --- 2b. If VS is empty, delete v in the range. --- --- - --- | Delete an association in the relation. -delete :: (Ord a, Ord b) - => a -> b -> Relation a b -> Relation a b - -delete x y r = r { domain = domain', range = range' } - where - domain' = M.update (erase y) x (domain r) - range' = M.update (erase x) y (range r) - erase e s = if S.singleton e == s - then Nothing - else Just $ S.delete e s - --- | The Set of values associated with a value in the domain. - -lookupDom :: Ord a => a -> Relation a b -> Maybe (S.Set b) -lookupDom x r = M.lookup x (domain r) - - - --- | The Set of values associated with a value in the range. - -lookupRan :: Ord b => b -> Relation a b -> Maybe (S.Set a) -lookupRan y r = M.lookup y (range r) - - - --- | True if the element @ x @ exists in the domain of @ r @. - -memberDom :: Ord a => a -> Relation a b -> Bool -memberDom x r = isJust $ lookupDom x r - - - --- | True if the element exists in the range. - -memberRan :: Ord b => b -> Relation a b -> Bool -memberRan y r = isJust $ lookupRan y r - - - --- | --- True if the relation @r@ is the 'empty' relation. -null :: Relation a b -> Bool -null r = M.null $ domain r --- Before 2010/11/09 null::Ord b => Relation a b -> Bool - - - --- | True if the relation contains the association @x@ and @y@ - -member :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool -member x y r = case lookupDom x r of - Just s -> S.member y s - Nothing -> False - - - --- | True if the relation /does not/ contain the association @x@ and @y@ - -notMember :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool -notMember x y r = not $ member x y r - - - --- | Returns the domain in the relation, as a Set, in its entirety. - -dom :: Relation a b -> S.Set a -dom r = M.keysSet (domain r) - - - --- | Returns the range of the relation, as a Set, in its entirety. - -ran :: Relation a b -> S.Set b -ran r = M.keysSet (range r) - - - --- | --- A compact set of sets the values of which can be @Just (Set x)@ or @Nothing@. --- --- The cases of 'Nothing' are purged. --- --- It is similar to 'concat'. -compactSet :: Ord a => S.Set (Maybe (S.Set a)) -> S.Set a - -compactSet = S.fold ( S.union . fromMaybe S.empty ) S.empty - - - --- $selectops --- --- Primitive implementation for the /right selection/ and /left selection/ operators. --- --- PICA provides both operators: --- '|>' and '<|' --- and '|$>' and '<$|' --- --- in this library, for working with Relations and OIS (Ordered, Inductive Sets?). --- --- PICA exposes the operators defined here, so as not to interfere with the abstraction --- of the Relation type and because having access to Relation hidden components is a more --- efficient implementation of the operation of restriction. --- --- @ --- (a <$| b) r --- --- denotes: for every element @b@ from the Set @B@, --- select an element @a@ from the Set @A@ , --- if @a@ --- is related to @b@ --- in @r@ --- @ --- --- @ --- (a |$> b) r --- --- denotes: for every element @a@ from the Set @A@ , --- select an element @b@ from the Set @B@, --- if @a@ --- is related to @b@ --- in @r@ --- @ --- --- With regard to domain restriction and range restriction operators --- of the language, those are described differently and return the domain or the range. - --- | --- @(Case b <| r a)@ --- -(<$|) :: (Ord a, Ord b) - => S.Set a -> S.Set b -> Relation a b -> S.Set a - -(as <$| bs) r = as `S.intersection` generarAS bs - - where generarAS = compactSet . S.map (`lookupRan` r) - - -- The subsets of the domain (a) associated with each @b@ - -- such that @b@ in @B@ and (b) are in the range of the relation. - -- The expression 'S.map' returns a set of @Either (S.Set a)@. - - --- | --- @( Case a |> r b )@ -(|$>) :: (Ord a, Ord b) - => S.Set a -> S.Set b -> Relation a b -> S.Set b - -(as |$> bs) r = bs `S.intersection` generarBS as - - where generarBS = compactSet . S.map (`lookupDom` r) - - - --- | Domain restriction for a relation. Modeled on z. - -(<|) :: (Ord a, Ord b) => S.Set a -> Relation a b -> Relation a b - -s <| r = fromList $ concatMap - ( \(x,y) -> zip (repeat x) (S.toList y) ) - ( M.toList domain' ) - where - domain' = M.unions . map filtrar . S.toList $ s - filtrar x = M.filterWithKey (\k _ -> k == x) dr - dr = domain r -- just to memoize the value - - --- | Range restriction for a relation. Modeled on z. - -(|>) :: (Ord a, Ord b) => Relation a b -> S.Set b -> Relation a b - -r |> t = fromList $ concatMap - ( \(x,y) -> zip (S.toList y) (repeat x) ) - ( M.toList range' ) - where - range' = M.unions . map filtrar . S.toList $ t - filtrar x = M.filterWithKey (\k _ -> k == x) rr - rr = range r -- just to memoize the value - - --- Note: --- --- As you have seen this implementation is expensive in terms --- of storage. Information is registered twice. --- For the operators |> and <| we follow a pattern used in --- the @fromList@ constructor and @toList@ flattener: --- It is enough to know one half of the Relation (the domain or --- the range) to create to other half. --- --- - - - +-----------------------------------------------------------------------------+-- |+-- Module : Data.Relation+-- Copyright : (c) DD. 2012+-- (c) LFL. 2009+-- License : BSD-style+-- Maintainer : Drew Day<drewday@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Relations are modeled as assciations between two elements.+--+-- Relations offer efficient search for any of the two elements.+--+-- Unlike "Data.Map", an element ca be associated more than once.+--+-- The two purposes of this structure are:+--+-- 1. Associating elements+--+-- 2. Provide efficient searches for either of the two elements.+--+-- Since neither 'map' nor 'fold' are implemented, you /must/ convert+-- the structure to a list to process sequentially.+--+--+module Data.Relation (++ -- * The @Relation@ Type++ Relation ()++ -- * Provided functionality:++ -- ** Questions++ , size -- # Tuples in the relation?+ , null -- Is empty?++ -- ** Construction++ , empty -- Construct an empty relation.+ , fromList -- Relation <- []+ , singleton -- Construct a relation with a single element.++ -- ** Operations++ , union -- Union of two relations.+ , unions -- Union on a list of relations.+ , intersection -- Intersection of two relations.+ , insert -- Insert a tuple to the relation.+ , delete -- Delete a tuple from the relation.+ -- The Set of values associated with a value in the domain.+ , lookupDom+ -- The Set of values associated with a value in the range.+ , lookupRan+ , memberDom -- Is the element in the domain?+ , memberRan -- Is the element in the range?+ , member -- Is the tuple in the relation?+ , notMember++ -- ** Conversion++ , toList -- Construct a list from a relation+ -- Extract the elements of the range to a Set.+ , dom+ -- Extract the elements of the domain to a Set.+ , ran++ -- ** Invertible Relations+ , c++ -- ** Utilities++ , compactSet -- Compact a Set of Maybe's.++ -- $selectops+ , (|$>) -- Restrict the range according to a subset. PICA.++ , (<$|) -- Restrict the domain according to a subset. PICA.++ , (<|) -- Domain restriction. Z.++ , (|>) -- Range restriction. z.++ -- Not implemented+ -- filter :: (a -> b -> Bool) -> Relation a b -> Relation a b+ -- map+)++where++import Control.Monad (MonadPlus, guard)+import Data.Functor (Functor ((<$)))+import qualified Data.Map as M+import Data.Maybe (fromJust, fromMaybe, isJust)+import qualified Data.Set as S+import Prelude hiding (null)++-- |+-- This implementation avoids using @"S.Set (a,b)"@ because+-- it it is necessary to search for an item without knowing both @D@ and @R@.+--+-- In "S.Set", you must know both values to search.+--+-- Thus, we have are two maps to updated together.+--+-- 1. Always be careful with the associated set of the key.+--+-- 2. If you union two relations, apply union to the set of values.+--+-- 3. If you subtract, take care when handling the set of values.+--+-- As a multi-map, each key is asscoated with a Set of values v.+--+-- We do not allow the associations with the 'empty' Set.+--++data Relation a b = Relation { domain :: M.Map a (S.Set b)+ , range :: M.Map b (S.Set a)+ }++ deriving (Show, Eq, Ord)+++++-- * Functions about relations+++-- The size is calculated using the domain.+-- | @size r@ returns the number of tuples in the relation.++size :: Relation a b -> Int+size r = M.foldr ((+) . S.size) 0 (domain r)++++-- | Construct a relation with no elements.++empty :: Relation a b+empty = Relation M.empty M.empty++++-- |+-- The list must be formatted like: [(k1, v1), (k2, v2),..,(kn, vn)].++fromList :: (Ord a, Ord b) => [(a, b)] -> Relation a b+fromList xs =+ Relation+ { domain = M.fromListWith S.union $ snd2Set xs+ , range = M.fromListWith S.union $ flipAndSet xs+ }+ where+ snd2Set = map ( \(x,y) -> (x, S.singleton y) )+ flipAndSet = map ( \(x,y) -> (y, S.singleton x) )+++-- |+-- Builds a List from a Relation.+toList :: Relation a b -> [(a,b)]+toList r = concatMap+ ( \(x,y) -> zip (repeat x) (S.toList y) )+ ( M.toList . domain $ r)++++-- |+-- Builds a 'Relation' consiting of an association between: @x@ and @y@.++singleton :: a -> b -> Relation a b+singleton x y = Relation+ { domain = M.singleton x (S.singleton y)+ , range = M.singleton y (S.singleton x)+ }++++-- | The 'Relation' that results from the union of two relations: @r@ and @s@.++union :: (Ord a, Ord b)+ => Relation a b -> Relation a b -> Relation a b++union r s =+ Relation+ { domain = M.unionWith S.union (domain r) (domain s)+ , range = M.unionWith S.union (range r) (range s)+ }+++---------------------------------------------------------------+-- |+-- This fragment provided by:+--+-- @+-- \ Module : Data.Map+-- \ Copyright : (c) Daan Leijen 2002+-- \ (c) Andriy Palamarchuk 2008+-- \ License : BSD-style+-- \ Maintainer : libraries\@haskell.org+-- \ Stability : provisional+-- \ Portability : portable+-- @+--+--+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f z xs = case xs of+ [] -> z+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)+---------------------------------------------------------------+++-- | Union a list of relations using the 'empty' relation.++unions :: (Ord a, Ord b) => [Relation a b] -> Relation a b++unions = foldlStrict union empty++++-- | Intersection of two relations: @a@ and @b@ are related by @intersection r+-- s@ exactly when @a@ and @b@ are related by @r@ and @s@.++intersection :: (Ord a, Ord b)+ => Relation a b -> Relation a b -> Relation a b++intersection r s = Relation+ { domain = doubleIntersect (domain r) (domain s)+ , range = doubleIntersect (range r) (range s)+ }+++ensure :: MonadPlus m => (a -> Bool) -> a -> m a+ensure p x = x <$ guard (p x)++-- This function is like M.intersectionWith S.intersection except that it+-- also removes keys that would then be associated with empty sets.+doubleIntersect :: (Ord k, Ord v)+ => M.Map k (S.Set v)+ -> M.Map k (S.Set v)+ -> M.Map k (S.Set v)+doubleIntersect = M.mergeWithKey+ (\_ l r -> ensure (not . S.null) (S.intersection l r))+ (const M.empty)+ (const M.empty)+++-- | Insert a relation @ x @ and @ y @ in the relation @ r @++insert :: (Ord a, Ord b)+ => a -> b -> Relation a b -> Relation a b++insert x y r = -- r { domain = domain', range = range' }+ Relation domain' range'+ where+ domain' = M.insertWith S.union x (S.singleton y) (domain r)+ range' = M.insertWith S.union y (S.singleton x) (range r)+++-- $deletenotes+--+-- The deletion is not difficult but is delicate:+--+-- @+-- r = { domain { (k1, {v1a, v3})+-- , (k2, {v2a})+-- , (k3, {v3b, v3})+-- }+-- , range { (v1a, {k1}+-- , (v2a, {k2{+-- , (v3 , {k1, k3}+-- , (v3b, {k3}+-- }+-- }+-- @+--+-- To delete (k,v) in the relation do:+-- 1. Working with the domain:+-- 1a. Delete v from the Set VS associated with k.+-- 1b. If VS is empty, delete k in the domain.+-- 2. Working in the range:+-- 2a. Delete k from the Set VS associated with v.+-- 2b. If VS is empty, delete v in the range.+--+--++-- | Delete an association in the relation.+delete :: (Ord a, Ord b)+ => a -> b -> Relation a b -> Relation a b++delete x y r = r { domain = domain', range = range' }+ where+ domain' = M.update (erase y) x (domain r)+ range' = M.update (erase x) y (range r)+ erase e s = if S.singleton e == s+ then Nothing+ else Just $ S.delete e s++-- | The Set of values associated with a value in the domain.++lookupDom :: Ord a => a -> Relation a b -> S.Set b+lookupDom x r = fromMaybe S.empty+ $ M.lookup x (domain r)++++-- | The Set of values associated with a value in the range.++lookupRan :: Ord b => b -> Relation a b -> S.Set a+lookupRan y r = fromMaybe S.empty+ $ M.lookup y (range r)++++-- | True if the element @ x @ exists in the domain of @ r @.++memberDom :: Ord a => a -> Relation a b -> Bool+memberDom x r = not . S.null $ lookupDom x r++++-- | True if the element exists in the range.++memberRan :: Ord b => b -> Relation a b -> Bool+memberRan y r = not . S.null $ lookupRan y r++++-- |+-- True if the relation @r@ is the 'empty' relation.+null :: Relation a b -> Bool+null r = M.null $ domain r+-- Before 2010/11/09 null::Ord b => Relation a b -> Bool++++-- | True if the relation contains the association @x@ and @y@++member :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool+member x y r = S.member y (lookupDom x r)++++-- | True if the relation /does not/ contain the association @x@ and @y@++notMember :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool+notMember x y r = not $ member x y r++++-- | Returns the domain in the relation, as a Set, in its entirety.++dom :: Relation a b -> S.Set a+dom r = M.keysSet (domain r)++++-- | Returns the range of the relation, as a Set, in its entirety.++ran :: Relation a b -> S.Set b+ran r = M.keysSet (range r)+++-- | Returns the converse of the relation.+c :: Relation a b -> Relation b a++c r = Relation {+ domain = range'+ ,range = domain'+ }+ where+ range' = range r+ domain' = domain r++-- |+-- A compact set of sets the values of which can be @Just (Set x)@ or @Nothing@.+--+-- The cases of 'Nothing' are purged.+--+-- It is similar to 'concat'.+compactSet :: Ord a => S.Set (S.Set a) -> S.Set a++compactSet = S.foldr S.union S.empty++++-- $selectops+--+-- Primitive implementation for the /right selection/ and /left selection/ operators.+--+-- PICA provides both operators:+-- '|>' and '<|'+-- and '|$>' and '<$|'+--+-- in this library, for working with Relations and OIS (Ordered, Inductive Sets?).+--+-- PICA exposes the operators defined here, so as not to interfere with the abstraction+-- of the Relation type and because having access to Relation hidden components is a more+-- efficient implementation of the operation of restriction.+--+-- @+-- (a <$| b) r+--+-- denotes: for every element @b@ from the Set @B@,+-- select an element @a@ from the Set @A@ ,+-- if @a@+-- is related to @b@+-- in @r@+-- @+--+-- @+-- (a |$> b) r+--+-- denotes: for every element @a@ from the Set @A@ ,+-- select an element @b@ from the Set @B@,+-- if @a@+-- is related to @b@+-- in @r@+-- @+--+-- With regard to domain restriction and range restriction operators+-- of the language, those are described differently and return the domain or the range.++-- |+-- @(Case b <| r a)@+--+(<$|) :: (Ord a, Ord b)+ => S.Set a -> S.Set b -> Relation a b -> S.Set a++(as <$| bs) r = as `S.intersection` generarAS bs++ where generarAS = compactSet . S.map (`lookupRan` r)++ -- The subsets of the domain (a) associated with each @b@+ -- such that @b@ in @B@ and (b) are in the range of the relation.+ -- The expression 'S.map' returns a set of @Either (S.Set a)@.+++-- |+-- @( Case a |> r b )@+(|$>) :: (Ord a, Ord b)+ => S.Set a -> S.Set b -> Relation a b -> S.Set b++(as |$> bs) r = bs `S.intersection` generarBS as++ where generarBS = compactSet . S.map (`lookupDom` r)++++-- | Domain restriction for a relation. Modeled on z.++(<|) :: (Ord a, Ord b) => S.Set a -> Relation a b -> Relation a b++s <| r = fromList $ concatMap+ ( \(x,y) -> zip (repeat x) (S.toList y) )+ ( M.toList domain' )+ where+ domain' = M.unions . map filtrar . S.toList $ s+ filtrar x = M.filterWithKey (\k _ -> k == x) dr+ dr = domain r -- just to memoize the value+++-- | Range restriction for a relation. Modeled on z.++(|>) :: (Ord a, Ord b) => Relation a b -> S.Set b -> Relation a b++r |> t = fromList $ concatMap+ ( \(x,y) -> zip (S.toList y) (repeat x) )+ ( M.toList range' )+ where+ range' = M.unions . map filtrar . S.toList $ t+ filtrar x = M.filterWithKey (\k _ -> k == x) rr+ rr = range r -- just to memoize the value+++-- Note:+--+-- As you have seen this implementation is expensive in terms+-- of storage. Information is registered twice.+-- For the operators |> and <| we follow a pattern used in+-- the @fromList@ constructor and @toList@ flattener:+-- It is enough to know one half of the Relation (the domain or+-- the range) to create to other half.+
− src/Data/Relation/Examples/E02.hs
@@ -1,192 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Relation.Examples.E02--- Copyright : (c) DD. 2012--- (c) LFL. 2009--- License : BSD-style--- Maintainer : Drew Day<drewday@gmail.com>--- Stability : experimental--- Portability : portable----module Data.Relation.Examples.E02 where --import Data.Relation -import qualified Data.Set as S-import Text.Groom----- | ------ Documentation Tests------ All examples in this module are tested automatically with Doctest, and pretty printed with "Text.Groom".--- --- This output is provided as proof of the correctness of the REPL (@>>>@) text:------ @--- There are 12 tests, with 12 total interactions.--- Examples: 12 Tried: 12 Errors: 0 Failures: 0--- @----p f = putStrLn $ groom $ f---- | Example 2:------ A student x can take n classes.------ * Each student must take at least 1 class------ * Each class must have at least one student.--enrollment = fromList - [ ("Rebeca" , "History" )- , ("Rebeca" , "Mathematics" )- , ("Rolando", "Religion" )- , ("Rolando", "Comunication")- , ("Teresa" , "Religion" )- , ("Teresa" , "Architecture")- , ("Antonio", "History" )- ]---- ^--- >>> p enrollment--- Relation{domain =--- fromList--- [("Antonio", fromList ["History"]),--- ("Rebeca", fromList ["History", "Mathematics"]),--- ("Rolando", fromList ["Comunication", "Religion"]),--- ("Teresa", fromList ["Architecture", "Religion"])],--- range =--- fromList--- [("Architecture", fromList ["Teresa"]),--- ("Comunication", fromList ["Rolando"]),--- ("History", fromList ["Antonio", "Rebeca"]),--- ("Mathematics", fromList ["Rebeca"]),--- ("Religion", fromList ["Rolando", "Teresa"])]}-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------rebecaenrollment = (S.singleton "Rebeca" |$> ran enrollment) enrollment --- ^--- >>> p rebecaenrollment--- fromList ["History", "Mathematics"]--takingreligion = (dom enrollment <$| S.singleton "Religion") enrollment--- ^--- >>> p takingreligion--- fromList ["Rolando", "Teresa"]----- others courses for those taking religion-others = (takingreligion |$> ran enrollment) enrollment--- ^--- >>> p others--- fromList ["Architecture", "Comunication", "Religion"]---------test1 = (takingreligion <$| ran enrollment) enrollment == takingreligion------ ^--- >>> p test1--- True---- Exploring |> ----takingreligion2 = enrollment |> S.singleton "Religion"--- ^--- >>> p takingreligion2--- Relation{domain =--- fromList--- [("Rolando", fromList ["Religion"]),--- ("Teresa", fromList ["Religion"])],--- range = fromList [("Religion", fromList ["Rolando", "Teresa"])]}---id1 s = ( v1 == v2, v1 )- where- v1 = (dom enrollment |$> s) enrollment- v2 = ran (enrollment |> s)- --id2 s = ( v1 == v2, v1 )- where- v1 = (dom enrollment <$| s) enrollment- v2 = dom (enrollment |> s) ----- Exploring <|--id3 s = ( v1 == v2, v1 )- where- v1 = (s <$| ran enrollment) enrollment- v2 = dom (s <| enrollment)---id4 s = ( v1 == v2, v2 )- where- v1 = (s |$> ran enrollment) enrollment- v2 = ran (s <| enrollment)---religion = S.singleton "Religion" -- has students-teresa = S.singleton "Teresa" -- enrolled------- ^--- >>> p religion--- fromList ["Religion"]--t11 = id1 religion ------ ^--- >>> p t11--- (True, fromList ["Religion"])--t12 = id2 religion ------ ^--- >>> p t12--- (True, fromList ["Rolando", "Teresa"])---t13 = id3 teresa ------ ^--- >>> p t13--- (True, fromList ["Teresa"])--t14 = id4 teresa ------ ^--- >>> p t14--- (True, fromList ["Architecture", "Religion"])---id1R, id2R - :: (Ord a, Ord b) => S.Set b -> Relation a b -> Bool--id3R , id4R- :: (Ord a, Ord b) => S.Set a -> Relation a b -> Bool--id1R s r = (dom r |$> s) r == ran (r |> s)-id2R s r = (dom r <$| s) r == dom (r |> s) -id3R s r = (s <$| ran r) r == dom (s <| r)-id4R s r = (s |$> ran r) r == ran (s <| r)--testAll = all id [ id1R religion enrollment- , id2R religion enrollment- , id3R teresa enrollment- , id4R teresa enrollment- ]--- ^--- >>> p testAll--- True-
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}