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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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)
|
