-
Notifications
You must be signed in to change notification settings - Fork 11
/
Utils.hs
117 lines (117 loc) · 5.06 KB
/
Utils.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
module Utils where
-- The following definitions are used to make some synonyms for routines
-- in the Gofer prelude to be more Miranda compatible
shownum n = show n
hd :: [a] -> a
hd = head -- in Gofer standard prelude
tl :: [a] -> [a]
tl = tail -- in Gofer standard prelude
zip2 :: [a] -> [b] -> [(a,b)]
zip2 = zip -- in Gofer standard prelude
-- can't do anything about # = length, since # not binary.
hInitial :: Heap a
hAlloc :: Heap a -> a -> (Heap a, Addr)
hUpdate :: Heap a -> Addr -> a -> Heap a
hFree :: Heap a -> Addr -> Heap a
hLookup :: Heap a -> Addr -> a
hAddresses :: Heap a -> [Addr]
hSize :: Heap a -> Int
hNull :: Addr
hIsnull :: Addr -> Bool
showaddr :: Addr -> [Char]
type Heap a = (Int, [Int], [(Int, a)])
type Addr = Int
hInitial = (0, [1..], [])
hAlloc (size, (next:free), cts) n = ((size+1, free, (next,n) : cts),next)
hUpdate (size, free, cts) a n = (size, free, (a,n) : remove cts a)
hFree (size, free, cts) a = (size-1, a:free, remove cts a)
hLookup (size,free,cts) a
= aLookup cts a (error ("can't find node " ++ showaddr a ++ " in heap"))
hAddresses (size, free, cts) = [addr | (addr, node) <- cts]
hSize (size, free, cts) = size
hNull = 0
hIsnull a = a == 0
showaddr a = "#" ++ shownum a -- Print # to identify addresses
remove :: [(Int,a)] -> Int -> [(Int,a)]
remove [] a = error ("Attempt to update or free nonexistent address #" ++
shownum a)
remove ((a',n):cts) a | a == a' = cts
| a /= a' = (a',n) : remove cts a
type ASSOC a b = [(a,b)]
aLookup [] k' def = def
aLookup ((k,v):bs) k' def | k == k' = v
| k /= k' = aLookup bs k' def
aDomain :: ASSOC a b -> [a]
aDomain alist = [key | (key,val) <- alist]
aRange :: ASSOC a b -> [b]
aRange alist = [val | (key,val) <- alist]
aEmpty = []
getName :: NameSupply -> [Char] -> (NameSupply, [Char])
getNames :: NameSupply -> [[Char]] -> (NameSupply, [[Char]])
initialNameSupply :: NameSupply
type NameSupply = Int
initialNameSupply = 0
getName name_supply prefix = (name_supply+1, makeName prefix name_supply)
getNames name_supply prefixes
= (name_supply + length prefixes, zipWith makeName prefixes [name_supply..])
makeName prefix ns = prefix ++ "_" ++ shownum ns
setFromList :: (Ord a) => [a] -> Set a
setToList :: (Ord a) => Set a -> [a]
setUnion :: (Ord a) => Set a -> Set a -> Set a
setIntersection :: (Ord a) => Set a -> Set a -> Set a
setSubtraction :: (Ord a) => Set a -> Set a -> Set a
setElementOf :: (Ord a) => a -> Set a -> Bool
setEmpty :: (Ord a) => Set a
setIsEmpty :: (Ord a) => Set a -> Bool
setSingleton :: (Ord a) => a -> Set a
setUnionList :: (Ord a) => [Set a] -> Set a
type Set a = [a] -- Ordered by the sort function
setEmpty = []
setIsEmpty s = null s
setSingleton x = [x]
setFromList = rmdup . sort
where rmdup [] = []
rmdup [x] = [x]
rmdup (x:y:xs) | x == y = rmdup (y:xs)
| x /= y = x: rmdup (y:xs)
setToList xs = xs
setUnion [] [] = []
setUnion [] (b:bs) = (b:bs)
setUnion (a:as) [] = (a:as)
setUnion (a:as) (b:bs) | a < b = a: setUnion as (b:bs)
| a == b = a: setUnion as bs
| a > b = b: setUnion (a:as) bs
setIntersection [] [] = []
setIntersection [] (b:bs) = []
setIntersection (a:as) [] = []
setIntersection (a:as) (b:bs) | a < b = setIntersection as (b:bs)
| a == b = a: setIntersection as bs
| a > b = setIntersection (a:as) bs
setSubtraction [] [] = []
setSubtraction [] (b:bs) = []
setSubtraction (a:as) [] = (a:as)
setSubtraction (a:as) (b:bs) | a < b = a: setSubtraction as (b:bs)
| a == b = setSubtraction as bs
| a > b = setSubtraction (a:as) bs
setElementOf x [] = False
setElementOf x (y:ys) = x==y || (x>y && setElementOf x ys)
setUnionList = foldll setUnion setEmpty
first (a,b) = a
second (a,b) = b
-- zipWith is defined in standard prelude
foldll :: (a -> b -> a) -> a -> [b] -> a
foldll = foldl -- in Gofer standard prelude.
mapAccuml :: (a -> b -> (a, c)) -- Function of accumulator and element
-- input list, returning new
-- accumulator and element of result list
-> a -- Initial accumulator
-> [b] -- Input list
-> (a, [c]) -- Final accumulator and result list
mapAccuml f acc [] = (acc, [])
mapAccuml f acc (x:xs) = (acc2, x':xs')
where (acc1, x') = f acc x
(acc2, xs') = mapAccuml f acc1 xs
sort [] = []
sort [x] = [x]
sort (x:xs) = [ y | y <- xs, y < x] ++ x : [ y | y <- xs, y >= x ]
space n = take n (repeat ' ')