relation 0.4 → 0.5
raw patch · 7 files changed
+473/−423 lines, 7 files
Files
- LICENSE +31/−30
- relation.cabal +8/−4
- src/Data/Relation.hs +136/−389
- src/Data/Relation/Internal.hs +13/−0
- src/Data/Relation/Internal/Set.hs +16/−0
- src/Data/Relation/Ops.hs +74/−0
- test/Data/RelationSpec.hs +195/−0
LICENSE view
@@ -1,30 +1,31 @@-Copyright (c)2010, Leonel Fonseca - -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 Leonel Fonseca 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. +Copyright (c)2019, John Ky+Copyright (c)2010, Leonel Fonseca++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.
relation.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: relation-version: 0.4+version: 0.5 synopsis: A data structure representing Relations on Sets. description: A library to model relationships between two objects that are subclasses of Ord. @@ -42,10 +42,13 @@ , containers hs-source-dirs: src exposed-modules: Data.Relation+ , Data.Relation.Ops+ , Data.Relation.Internal+ , Data.Relation.Internal.Set test-suite relation-test- import: base- , common+ import: base, common+ , containers , hedgehog , hspec , hw-hspec-hedgehog@@ -53,7 +56,8 @@ type: exitcode-stdio-1.0 main-is: Spec.hs build-depends: relation- other-modules: Paths_relation+ other-modules: Data.RelationSpec+ , Paths_relation autogen-modules: Paths_relation hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N
src/Data/Relation.hs view
@@ -1,7 +1,8 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Relation--- Copyright : (c) DD. 2012+-- Copyright : (c) JK. 2019+-- (c) DD. 2012 -- (c) LFL. 2009 -- License : BSD-style -- Maintainer : Drew Day<drewday@gmail.com>@@ -25,461 +26,207 @@ -- -- 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)+ -- * The @Relation@ Type+ Relation --- |--- 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.---+ -- * Provided functionality:+ -- ** Questions+ , size -- Number of Tuples in the relation?+ , null -- Is empty? -data Relation a b = Relation { domain :: M.Map a (S.Set b)- , range :: M.Map b (S.Set a)- }+ -- ** Construction+ , empty -- Construct an empty relation.+ , fromList -- Relation <- []+ , singleton -- Construct a relation with a single element. - deriving (Show, Eq, Ord)+ -- ** 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.+ , lookupDom -- The Set of values associated with a value in the domain.+ , lookupRan -- The Set of values associated with a value in the range.+ , memberDom -- Is the element in the domain?+ , memberRan -- Is the element in the range?+ , member -- Is the tuple in the relation?+ , notMember+ , restrictDom -- Restrict the domain to that of the provided set+ , restrictRan -- Restrict the range to that of the provided set+ , withoutDom -- Restrict the domain to exclude elements of the provided set+ , withoutRan -- Restrict the range to exclude elements of the provided set + -- ** Conversion+ , toList -- Construct a list from a relation+ , dom -- Extract the elements of the range to a Set.+ , ran -- Extract the elements of the domain to a Set.+ , converse -- Converse of the relation+ ) where +import Control.Monad (MonadPlus, guard)+import Data.Functor (Functor ((<$)))+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Relation.Internal (Relation (Relation))+import Data.Set (Set)+import Prelude hiding (null) +import qualified Data.Foldable as F+import qualified Data.Map as M+import qualified Data.Relation.Internal as R+import qualified Data.Relation.Internal.Set as S+import qualified Data.Set as S -- * 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)--+size :: Relation a b -> Int+size r = M.foldr ((+) . S.size) 0 (R.domain r) -- | Construct a relation with no elements.--empty :: Relation a b-empty = Relation M.empty M.empty--+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) )-+fromList :: (Ord a, Ord b) => [(a, b)] -> Relation a b+fromList xs = Relation+ { R.domain = M.fromListWith S.union $ snd2Set xs+ , R.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)--+toList :: Relation a b -> [(a, b)]+toList r = concatMap (\(x, y) -> zip (repeat x) (S.toList y)) (M.toList . R.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)- }--+singleton :: a -> b -> Relation a b+singleton x y = Relation+ { R.domain = M.singleton x (S.singleton y)+ , R.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 :: (Ord a, Ord b) => Relation a b -> Relation a b -> Relation a b+union r s = Relation+ { R.domain = M.unionWith S.union (R.domain r) (R.domain s)+ , R.range = M.unionWith S.union (R.range r) (R.range s)+ } -- | Union a list of relations using the 'empty' relation.--unions :: (Ord a, Ord b) => [Relation a b] -> Relation a b--unions = foldlStrict union empty--+unions :: (Ord a, Ord b) => [Relation a b] -> Relation a b+unions = F.foldl' 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 :: (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)+ { R.domain = doubleIntersect (R.domain r) (R.domain s)+ , R.range = doubleIntersect (R.range r) (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 :: (Ord k, Ord v) => Map k (Set v) -> Map k (Set v) -> Map k (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.------+insert :: (Ord a, Ord b) => a -> b -> Relation a b -> Relation a b+insert x y r = Relation domain' range'+ where domain' = M.insertWith S.union x (S.singleton y) (R.domain r)+ range' = M.insertWith S.union y (S.singleton x) (R.range r) -- | 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+delete :: (Ord a, Ord b) => a -> b -> Relation a b -> Relation a b+delete x y r = Relation+ { R.domain = domain'+ , R.range = range'+ }+ where domain' = M.update (erase y) x (R.domain r)+ range' = M.update (erase x) y (R.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)--+lookupDom :: Ord a => a -> Relation a b -> Set b+lookupDom x r = fromMaybe S.empty $ M.lookup x (R.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)--+lookupRan :: Ord b => b -> Relation a b -> Set a+lookupRan y r = fromMaybe S.empty $ M.lookup y (R.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--+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--+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--+null :: Relation a b -> Bool+null r = M.null $ R.domain r -- | 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)--+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--+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)--+dom :: Relation a b -> Set a+dom r = M.keysSet (R.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)-+ran :: Relation a b -> Set b+ran r = M.keysSet (R.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+converse :: Relation a b -> Relation b a+converse r = Relation+ { R.domain = range'+ , R.range = domain'+ }+ where range' = R.range r+ domain' = R.domain r -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+-- | Restrict the domain to that of the provided set+restrictDom :: (Ord a, Ord b) => S.Set a -> Relation a b -> Relation a b+restrictDom s r = Relation+ { R.domain = M.restrictKeys (R.domain r) s+ , R.range = M.mapMaybe (S.justUnlessEmpty . S.intersection s) (R.range r)+ } +-- | Restrict the range to that of the provided set+restrictRan :: (Ord a, Ord b) => S.Set b -> Relation a b -> Relation a b+restrictRan s r = Relation+ { R.domain = M.mapMaybe (S.justUnlessEmpty . S.intersection s) (R.domain r)+ , R.range = M.restrictKeys (R.range r) s+ } --- 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.+-- | Restrict the domain to exclude elements of the provided set+withoutDom :: (Ord a, Ord b) => S.Set a -> Relation a b -> Relation a b+withoutDom s r = Relation+ { R.domain = M.withoutKeys (R.domain r) s+ , R.range = M.mapMaybe (S.justUnlessEmpty . flip S.difference s) (R.range r)+ } +-- | Restrict the range to exclude elements of the provided set+withoutRan :: (Ord a, Ord b) => S.Set b -> Relation a b -> Relation a b+withoutRan s r = Relation+ { R.domain = M.mapMaybe (S.justUnlessEmpty . flip S.difference s) (R.domain r)+ , R.range = M.withoutKeys (R.range r) s+ }
+ src/Data/Relation/Internal.hs view
@@ -0,0 +1,13 @@+module Data.Relation.Internal+ ( Relation(..)+ ) where++import qualified Data.Map as M+import qualified Data.Set as S++-- |+-- Representation of a relation on ordered (@Ord@) values+data Relation a b = Relation+ { domain :: M.Map a (S.Set b)+ , range :: M.Map b (S.Set a)+ } deriving (Show, Eq, Ord)
+ src/Data/Relation/Internal/Set.hs view
@@ -0,0 +1,16 @@+module Data.Relation.Internal.Set+ ( flatten+ , justUnlessEmpty+ ) where++import Data.Set (Set)++import qualified Data.Set as S++-- |+-- Flatten a set of sets.+flatten :: Ord a => Set (Set a) -> Set a+flatten = S.foldr S.union S.empty++justUnlessEmpty :: S.Set a -> Maybe (S.Set a)+justUnlessEmpty c = if S.null c then Nothing else Just c
+ src/Data/Relation/Ops.hs view
@@ -0,0 +1,74 @@+module Data.Relation.Ops+ ( -- $selectops+ (|$>) -- Restrict the range according to a subset. PICA.+ , (<$|) -- Restrict the domain according to a subset. PICA.+ , (<|) -- Domain restriction. Z.+ , (|>) -- Range restriction. z.+ ) where++import Data.Relation.Internal (Relation)+import Data.Set (Set)++import qualified Data.Relation as R+import qualified Data.Relation.Internal.Set as S+import qualified Data.Set as S++-- $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) => Set a -> Set b -> Relation a b -> Set a+(as <$| bs) r = as `S.intersection` generarAS bs+ where generarAS = S.flatten . S.map (`R.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 (Set a)@.++-- |+-- @(Case a |> r b)@+(|$>) :: (Ord a, Ord b) => Set a -> Set b -> Relation a b -> Set b+(as |$> bs) r = bs `S.intersection` generarBS as+ where generarBS = S.flatten . S.map (`R.lookupDom` r)++-- | Domain restriction for a relation. Modeled on z.+(<|) :: (Ord a, Ord b) => Set a -> Relation a b -> Relation a b+s <| r = R.restrictDom s r++-- | Range restriction for a relation. Modeled on z.+(|>) :: (Ord a, Ord b) => Relation a b -> Set b -> Relation a b+r |> t = R.restrictRan t r
+ test/Data/RelationSpec.hs view
@@ -0,0 +1,195 @@+module Data.RelationSpec+ ( spec+ ) where++import Data.Relation.Ops+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Relation as DR+import qualified Data.Relation.Internal as DR+import qualified Data.Set as S+import qualified Hedgehog.Gen as G+import qualified Hedgehog.Range as R++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++e :: DR.Relation String String+e = DR.fromList+ [ ("Rebeca" , "History" )+ , ("Rebeca" , "Mathematics" )+ , ("Rolando", "Religion" )+ , ("Rolando", "Comunication" )+ , ("Teresa" , "Religion" )+ , ("Teresa" , "Architecture" )+ , ("Antonio", "History" )+ ]++rebecaE :: S.Set String+rebecaE = (S.singleton "Rebeca" |$> DR.ran e) e++takingreligion :: S.Set String+takingreligion = (DR.dom e <$| S.singleton "Religion") e++others :: S.Set String+others = (takingreligion |$> DR.ran e) e++takingreligion2 :: DR.Relation String String+takingreligion2 = e |> S.singleton "Religion"++twoStudents :: DR.Relation String String+twoStudents = (<|) (S.union (S.singleton "Rolando") (S.singleton "Teresa")) e++id1 :: S.Set String -> (Bool, S.Set String)+id1 s = (v1 == v2, v1)+ where v1 = (DR.dom e |$> s) e+ v2 = DR.ran (e |> s)++id2 :: S.Set String -> (Bool, S.Set String)+id2 s = (v1 == v2, v1)+ where v1 = (DR.dom e <$| s) e+ v2 = DR.dom (e |> s)++id3 :: S.Set String -> (Bool, S.Set String)+id3 s = (v1 == v2, v1)+ where v1 = (s <$| DR.ran e) e+ v2 = DR.dom (s <| e)++id4 :: S.Set String -> (Bool, S.Set String)+id4 s = (v1 == v2, v2)+ where v1 = (s |$> DR.ran e) e+ v2 = DR.ran (s <| e)++religion :: S.Set String+religion = S.singleton "Religion" -- has students++teresa :: S.Set String+teresa = S.singleton "Teresa" -- enrolled++spec :: Spec+spec = describe "Data.RelationSpec" $ do+ describe "Unit tests" $ do+ it "fromList" $ requireTest $ do+ e === DR.Relation+ { DR.domain = M.fromList+ [ ("Antonio" , S.fromList ["History" ])+ , ("Rebeca" , S.fromList ["History", "Mathematics" ])+ , ("Rolando" , S.fromList ["Comunication", "Religion"])+ , ("Teresa" , S.fromList ["Architecture", "Religion"])+ ]+ , DR.range = M.fromList+ [ ("Architecture" , S.fromList ["Teresa" ])+ , ("Comunication" , S.fromList ["Rolando" ])+ , ("History" , S.fromList ["Antonio", "Rebeca" ])+ , ("Mathematics" , S.fromList ["Rebeca" ])+ , ("Religion" , S.fromList ["Rolando", "Teresa" ])+ ]+ }+ it "singleton & range" $ requireTest $ do+ rebecaE === S.fromList ["History", "Mathematics"]+ it "singleton & domain" $ requireTest $ do+ takingreligion === S.fromList ["Rolando", "Teresa"]+ it "(|$>)" $ requireTest $ do+ others === S.fromList ["Architecture", "Comunication", "Religion"]+ it "test1" $ requireTest $ do+ (takingreligion <$| DR.ran e) e === takingreligion+ it "Exploring |>" $ requireTest $ do+ takingreligion2 === DR.Relation+ { DR.domain = M.fromList+ [ ("Rolando" , S.fromList ["Religion" ])+ , ("Teresa" , S.fromList ["Religion" ])+ ]+ , DR.range = M.fromList+ [ ("Religion" , S.fromList ["Rolando", "Teresa" ])+ ]+ }+ it "twoStudents" $ requireTest $ do+ twoStudents === DR.Relation+ { DR.domain = M.fromList+ [ ("Rolando" , S.fromList ["Comunication", "Religion"])+ , ("Teresa" , S.fromList ["Architecture", "Religion"])+ ]+ , DR.range = M.fromList+ [ ("Architecture" , S.fromList ["Teresa" ])+ , ("Comunication" , S.fromList ["Rolando" ])+ , ("Religion" , S.fromList ["Rolando", "Teresa" ])+ ]+ }+ it "test 2" $ requireTest $ do+ (|$>) (S.union (S.singleton "Rolando") (S.singleton "Teresa")) (DR.ran e) e === S.fromList ["Architecture", "Comunication", "Religion"]+ it "test 3" $ requireTest $ do+ id1 religion === (True, S.fromList ["Religion"])+ it "test 4" $ requireTest $ do+ id2 religion === (True, S.fromList ["Rolando", "Teresa"])+ it "test 5" $ requireTest $ do+ id3 teresa === (True, S.fromList ["Teresa"])+ it "test 6" $ requireTest $ do+ id4 teresa === (True, S.fromList ["Architecture", "Religion"])+ it "test 7" $ requireTest $ do+ (DR.dom e |$> religion) e === DR.ran (e |> religion)+ it "test 8" $ requireTest $ do+ (DR.dom e <$| religion) e === DR.dom (e |> religion)+ it "test 9" $ requireTest $ do+ (teresa <$| DR.ran e) e === DR.dom (teresa <| e)+ it "test 10" $ requireTest $ do+ (teresa |$> DR.ran e) e === DR.ran (teresa <| e)++ describe "property tests" $ do+ it "List roundtrip" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha+ L.sort (DR.toList (DR.fromList as)) === L.sort as+ it "Full domain restriction" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha++ DR.restrictDom S.empty (DR.fromList as) === DR.empty+ it "Full range restriction" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha++ DR.restrictRan S.empty (DR.fromList as) === DR.empty+ it "No domain restriction" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha+ let r = DR.fromList as++ DR.restrictDom (DR.dom r) r === r+ it "No range restriction" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha+ let r = DR.fromList as+ DR.restrictRan (DR.ran r) r === r+ it "Full domain without" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha+ let r = DR.fromList as+ DR.withoutDom S.empty r === r+ it "Full range without" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha+ let r = DR.fromList as+ DR.withoutRan S.empty r === r+ it "No domain without" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha+ let r = DR.fromList as++ DR.withoutDom (DR.dom r) r === DR.empty+ it "No range without" $ require $ property $ do+ as <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.int R.constantBounded+ <*> G.alpha+ let r = DR.fromList as+ DR.withoutRan (DR.ran r) r === DR.empty