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
118
119
120
121
|
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Filename: OrdMap2.hs
Author: Peter Ljunglöf
Time-stamp: <2004-05-07 14:16:03 peb>
Description: The class of finite maps, as described in
"Pure Functional Parsing", section 2.2.2
and an example implementation,
derived from appendix A.2
OBSOLETE! this is only used in cf/ChartParser.hs
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
module OrdMap2 (OrdMap(..), Map) where
import List (intersperse)
--------------------------------------------------
-- the class of ordered finite maps
class OrdMap m where
emptyMap :: Ord s => m s a
(|->) :: Ord s => s -> a -> m s a
isEmptyMap :: Ord s => m s a -> Bool
(?) :: Ord s => m s a -> s -> Maybe a
lookupWith :: Ord s => a -> m s a -> s -> a
mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a
unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a
makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a
assocs :: Ord s => m s a -> [(s,a)]
ordMap :: Ord s => [(s,a)] -> m s a
mapMap :: Ord s => (a -> b) -> m s a -> m s b
lookupWith z m s = case m ? s of
Just a -> a
Nothing -> z
unionMapWith join = union
where union [] = emptyMap
union [xs] = xs
union xyss = mergeWith join (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, [])
--------------------------------------------------
-- finite maps as ordered associaiton lists,
-- paired with binary search trees
data Map s a = Map [(s,a)] (TreeMap s a)
instance (Eq s, Eq a) => Eq (Map s a) where
Map xs _ == Map ys _ = xs == ys
instance (Show s, Show a) => Show (Map s a) where
show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}"
where show' (s,a) = show s ++ "|->" ++ show a
instance OrdMap Map where
emptyMap = Map [] (makeTree [])
s |-> a = Map [(s,a)] (makeTree [(s,a)])
isEmptyMap (Map ass _) = null ass
Map _ tree ? s = lookupTree s tree
mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss)
where xyss = merge xss yss
merge [] yss = yss
merge xss [] = xss
merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss')
= case compare s t of
LT -> x : merge xss' yss
GT -> y : merge xss yss'
EQ -> (s, join x' y') : merge xss' yss'
makeMapWith join [] = emptyMap
makeMapWith join [(s,a)] = s |-> a
makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss)
where (xss, yss) = split xyss
split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys)
split xs = (xs, [])
assocs (Map xss _) = xss
ordMap xss = Map xss (makeTree xss)
mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree)
--------------------------------------------------
-- binary search trees
-- for logarithmic lookup time
data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a)
makeTree ass = tree
where
(tree,[]) = sl2bst (length ass) ass
sl2bst 0 ass = (Nil, ass)
sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass)
sl2bst n ass = (Node ltree s a rtree, css)
where llen = (n-1) `div` 2
rlen = n - 1 - llen
(ltree, (s,a):bss) = sl2bst llen ass
(rtree, css) = sl2bst rlen bss
lookupTree s Nil = Nothing
lookupTree s (Node left s' a right)
= case compare s s' of
LT -> lookupTree s left
GT -> lookupTree s right
EQ -> Just a
mapTree f Nil = Nil
mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right)
|
