summaryrefslogtreecommitdiff
path: root/src/GF/Data/Relation.hs
diff options
context:
space:
mode:
authorkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
committerkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
commitf85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch)
tree667b886a5e3a4b026a63d4e3597f32497d824761 /src/GF/Data/Relation.hs
parentd88a865faff59c98fc91556ff8700b10ee5f2df8 (diff)
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/GF/Data/Relation.hs')
-rw-r--r--src/GF/Data/Relation.hs193
1 files changed, 0 insertions, 193 deletions
diff --git a/src/GF/Data/Relation.hs b/src/GF/Data/Relation.hs
deleted file mode 100644
index 7024a482c..000000000
--- a/src/GF/Data/Relation.hs
+++ /dev/null
@@ -1,193 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Relation
--- Maintainer : BB
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/26 17:13:13 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.1 $
---
--- A simple module for relations.
------------------------------------------------------------------------------
-
-module GF.Data.Relation (Rel, mkRel, mkRel'
- , allRelated , isRelatedTo
- , transitiveClosure
- , reflexiveClosure, reflexiveClosure_
- , symmetricClosure
- , symmetricSubrelation, reflexiveSubrelation
- , reflexiveElements
- , equivalenceClasses
- , isTransitive, isReflexive, isSymmetric
- , isEquivalence
- , isSubRelationOf
- , topologicalSort) where
-
-import Data.Foldable (toList)
-import Data.List
-import Data.Maybe
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Sequence (Seq)
-import qualified Data.Sequence as Seq
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-import GF.Data.Utilities
-
-type Rel a = Map a (Set a)
-
--- | Creates a relation from a list of related pairs.
-mkRel :: Ord a => [(a,a)] -> Rel a
-mkRel ps = relates ps Map.empty
-
--- | Creates a relation from a list pairs of elements and the elements
--- related to them.
-mkRel' :: Ord a => [(a,[a])] -> Rel a
-mkRel' xs = Map.fromListWith Set.union [(x,Set.fromList ys) | (x,ys) <- xs]
-
-relToList :: Ord a => Rel a -> [(a,a)]
-relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ]
-
--- | Add a pair to the relation.
-relate :: Ord a => a -> a -> Rel a -> Rel a
-relate x y r = Map.insertWith Set.union x (Set.singleton y) r
-
--- | Add a list of pairs to the relation.
-relates :: Ord a => [(a,a)] -> Rel a -> Rel a
-relates ps r = foldl (\r' (x,y) -> relate x y r') r ps
-
--- | Checks if an element is related to another.
-isRelatedTo :: Ord a => Rel a -> a -> a -> Bool
-isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r)
-
--- | Get the set of elements to which a given element is related.
-allRelated :: Ord a => Rel a -> a -> Set a
-allRelated r x = fromMaybe Set.empty (Map.lookup x r)
-
--- | Get all elements in the relation.
-domain :: Ord a => Rel a -> Set a
-domain r = foldl Set.union (Map.keysSet r) (Map.elems r)
-
-reverseRel :: Ord a => Rel a -> Rel a
-reverseRel r = mkRel [(y,x) | (x,y) <- relToList r]
-
--- | Keep only pairs for which both elements are in the given set.
-intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
-intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s)
-
-transitiveClosure :: Ord a => Rel a -> Rel a
-transitiveClosure r = fix (Map.map growSet) r
- where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
-
-reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
- -> Rel a -> Rel a
-reflexiveClosure_ u r = relates [(x,x) | x <- u] r
-
--- | Uses 'domain'
-reflexiveClosure :: Ord a => Rel a -> Rel a
-reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r
-
-symmetricClosure :: Ord a => Rel a -> Rel a
-symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r
-
-symmetricSubrelation :: Ord a => Rel a -> Rel a
-symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r
-
-reflexiveSubrelation :: Ord a => Rel a -> Rel a
-reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r
-
--- | Get the set of elements which are related to themselves.
-reflexiveElements :: Ord a => Rel a -> Set a
-reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
-
--- | Keep the related pairs for which the predicate is true.
-filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
-filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
-
--- | Remove keys that map to no elements.
-purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
-purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
- in (r', Map.keysSet r'')
-
--- | Get the equivalence classes from an equivalence relation.
-equivalenceClasses :: Ord a => Rel a -> [Set a]
-equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
- where equivalenceClasses_ [] _ = []
- equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
- where ys = allRelated r x
- zs = [x' | x' <- xs, not (x' `Set.member` ys)]
-
-isTransitive :: Ord a => Rel a -> Bool
-isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
- y <- Set.toList ys, z <- Set.toList (allRelated r y)]
-
-isReflexive :: Ord a => Rel a -> Bool
-isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r)
-
-isSymmetric :: Ord a => Rel a -> Bool
-isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r]
-
-isEquivalence :: Ord a => Rel a -> Bool
-isEquivalence r = isReflexive r && isSymmetric r && isTransitive r
-
-isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
-isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1)
-
--- | Returns 'Left' if there are cycles, and 'Right' if there are cycles.
-topologicalSort :: Ord a => Rel a -> Either [a] [[a]]
-topologicalSort r = tsort r' noIncoming Seq.empty
- where r' = relToRel' r
- noIncoming = Seq.fromList [x | (x,(is,_)) <- Map.toList r', Set.null is]
-
-tsort :: Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
-tsort r xs l = case Seq.viewl xs of
- Seq.EmptyL | isEmpty' r -> Left (toList l)
- | otherwise -> Right (findCycles (rel'ToRel r))
- x Seq.:< xs -> tsort r' (xs Seq.>< Seq.fromList new) (l Seq.|> x)
- where (r',_,os) = remove x r
- new = [o | o <- Set.toList os, Set.null (incoming o r')]
-
-findCycles :: Ord a => Rel a -> [[a]]
-findCycles = map Set.toList . equivalenceClasses . reflexiveSubrelation . symmetricSubrelation . transitiveClosure
-
---
--- * Alternative representation that keeps both incoming and outgoing edges
---
-
--- | Keeps both incoming and outgoing edges.
-type Rel' a = Map a (Set a, Set a)
-
-isEmpty' :: Ord a => Rel' a -> Bool
-isEmpty' = Map.null
-
-relToRel' :: Ord a => Rel a -> Rel' a
-relToRel' r = Map.unionWith (\ (i,_) (_,o) -> (i,o)) ir or
- where ir = Map.map (\s -> (s,Set.empty)) $ reverseRel r
- or = Map.map (\s -> (Set.empty,s)) $ r
-
-rel'ToRel :: Ord a => Rel' a -> Rel a
-rel'ToRel = Map.map snd
-
--- | Removes an element from a relation.
--- Returns the new relation, and the set of incoming and outgoing edges
--- of the removed element.
-remove :: Ord a => a -> Rel' a -> (Rel' a, Set a, Set a)
-remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
- in case mss of
- -- element was not in the relation
- Nothing -> (r', Set.empty, Set.empty)
- -- remove element from all incoming and outgoing sets
- -- of other elements
- Just (is,os) ->
- let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is
- r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
- in (r''', is, os)
-
-incoming :: Ord a => a -> Rel' a -> Set a
-incoming x r = maybe Set.empty fst $ Map.lookup x r
-
-outgoing :: Ord a => a -> Rel' a -> Set a
-outgoing x r = maybe Set.empty snd $ Map.lookup x r \ No newline at end of file