-- -------------------------------------------------------------------------- -- $Revision: 262 $ $Date: 2007-04-12 12:19:50 +0200 (Thu, 12 Apr 2007) $ -- -------------------------------------------------------------------------- -- | -- -- Module : PureFP.OrdSet -- Copyright : Peter Ljunglof 2002 -- License : GPL -- -- Maintainer : otakar.smrz mff.cuni.cz -- Stability : provisional -- Portability : portable -- -- Chapter 1 and Appendix A of /Pure Functional Parsing – an advanced -- tutorial/ by Peter Ljunglöf -- -- <http://www.ling.gu.se/~peb/pubs/p02-lic-thesis.pdf> -------------------------------------------------- -- The class of ordered sets -- as described in section 2.2.1 -- and an example implementation, -- derived from the implementation in appendix A.1 module PureFP.OrdSet (OrdSet(..), Set) where import Data.List (intersperse) -------------------------------------------------- -- the class of ordered sets class OrdSet m where emptySet :: Ord a => m a unitSet :: Ord a => a -> m a isEmpty :: Ord a => m a -> Bool elemSet :: Ord a => a -> m a -> Bool (<++>) :: Ord a => m a -> m a -> m a (<\\>) :: Ord a => m a -> m a -> m a plusMinus :: Ord a => m a -> m a -> (m a, m a) union :: Ord a => [m a] -> m a makeSet :: Ord a => [a] -> m a elems :: Ord a => m a -> [a] ordSet :: Ord a => [a] -> m a limit :: Ord a => (a -> m a) -> m a -> m a xs <++> ys = fst (plusMinus xs ys) xs <\\> ys = snd (plusMinus xs ys) plusMinus xs ys = (xs <++> ys, xs <\\> ys) union [] = emptySet union [xs] = xs union xyss = union xss <++> union yss where (xss, yss) = split xyss split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) split xs = (xs, []) makeSet xs = union (map unitSet xs) limit more start = limit' (start, start) where limit' (old, new) | isEmpty new' = old | otherwise = limit' (plusMinus new' old) where new' = union (map more (elems new)) -------------------------------------------------- -- sets as ordered lists, -- paired with a binary tree data Set a = Set [a] (TreeSet a) instance Eq a => Eq (Set a) where Set xs _ == Set ys _ = xs == ys instance Ord a => Ord (Set a) where compare (Set xs _) (Set ys _) = compare xs ys instance Show a => Show (Set a) where show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}" instance OrdSet Set where emptySet = Set [] (makeTree []) unitSet a = Set [a] (makeTree [a]) isEmpty (Set xs _) = null xs elemSet a (Set _ xt) = elemTree a xt plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms)) where (ps, ms) = plm xs ys plm [] ys = (ys, []) plm xs [] = (xs, xs) plm xs@(x:xs') ys@(y:ys') = case compare x y of LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms) GT -> let (ps, ms) = plm xs ys' in (y:ps, ms) EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms) elems (Set xs _) = xs ordSet xs = Set xs (makeTree xs) -------------------------------------------------- -- binary search trees -- for logarithmic lookup time data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a) makeTree xs = tree where (tree,[]) = sl2bst (length xs) xs sl2bst 0 xs = (Nil, xs) sl2bst 1 (a:xs) = (Node Nil a Nil, xs) sl2bst n xs = (Node ltree a rtree, zs) where llen = (n-1) `div` 2 rlen = n - 1 - llen (ltree, a:ys) = sl2bst llen xs (rtree, zs) = sl2bst rlen ys elemTree a Nil = False elemTree a (Node ltree x rtree) = case compare a x of LT -> elemTree a ltree GT -> elemTree a rtree EQ -> True