1 2 3 4 module Utilities( 5 Assn, assLookup, 6 NameSupply, initialNameSupply, newName, 7 Set, setFromList, setEmpty, setSingleton, setToList, 8 setUnion, setIntersect, setDifference, setUnionList, 9 Bag, bagFromList, bagEmpty, bagSingleton, bagToList, 10 bagInsert, bagUnion, 11 mapAccuml 12 ) where 13 14 15 16 17 18 19 20 type Assn key value = [(key, value)] 21 22 assLookup :: Eq key => Assn key value -> key -> value 23 assLookup alist key = head [value | (key',value) <- alist, key == key'] 24 25 26 27 data NameSupply = MkNS Int 28 29 initialNameSupply :: NameSupply 30 initialNameSupply = MkNS 0 31 32 newName :: NameSupply -> String -> (NameSupply, String) 33 newName (MkNS n) prefix = (MkNS (n+1), prefix ++ show n) 34 35 36 37 38 39 40 data Set a = MkSet [a] 41 42 43 44 45 46 47 48 setFromList xs = MkSet (sortNoDups xs) 49 setEmpty = MkSet [] 50 setSingleton x = MkSet [x] 51 setToList (MkSet xs) = xs 52 53 54 55 setUnion (MkSet xs) (MkSet ys) = 56 MkSet (merge xs ys) where 57 merge xs [] = xs 58 merge [] ys = ys 59 merge xs@(x:xs') ys@(y:ys') | x<y = x : merge xs' ys 60 | x==y = x : merge xs' ys' 61 | x>y = y : merge xs ys' 62 63 setIntersect (MkSet xs) (MkSet ys) = 64 MkSet (intersect xs ys) where 65 intersect [] ys = [] 66 intersect xs [] = [] 67 intersect xs@(x:xs') ys@(y:ys') | x<y = intersect xs' ys 68 | x==y = x : intersect xs' ys' 69 | x>y = intersect xs ys' 70 71 setDifference (MkSet xs) (MkSet ys) = 72 MkSet (difference xs ys) where 73 difference [] ys = [] 74 difference xs [] = xs 75 difference xs@(x:xs') ys@(y:ys') | x<y = x : difference xs' ys 76 | x==y = difference xs' ys' 77 | x>y = difference xs ys' 78 79 setUnionList ss = foldr setUnion setEmpty ss 80 81 82 83 84 85 data Bag a = MkBag [a] 86 bagEmpty = MkBag [] 87 bagSingleton x = MkBag [x] 88 bagFromList xs = MkBag xs 89 bagToList (MkBag xs) = xs 90 bagInsert x (MkBag xs) = MkBag (x:xs) 91 bagUnion (MkBag xs) (MkBag ys) = MkBag (xs ++ ys) 92 93 94 95 96 mapAccuml :: (b -> a -> (b, c)) -- Function of elt of input list 97 -- and accumulator, returning new 98 -- accumulator and elt of result list 99 -> b -- Initial accumulator 100 -> [a] -- Input list 101 -> (b, [c]) -- Final accumulator and result list 102 103 mapAccuml f b [] = (b, []) 104 mapAccuml f b (x:xs) = (b'', x':xs') where 105 (b', x') = f b x 106 (b'', xs') = mapAccuml f b' xs 107 108 109 110 sortNoDups :: Ord a => [a] -> [a] 111 sortNoDups [] = [] 112 sortNoDups (x:xs) = sortNoDups [y | y <- xs, y < x] 113 ++ [x] ++ 114 sortNoDups [y | y <- xs, y > x] 115 116