]> gerrit.simantics Code Review - simantics/platform.git/blob - bundles/org.simantics.scl.runtime/scl/ISet.scl
New parametrisation of OpenDiagramFromConfigurationAdapter.openEditor
[simantics/platform.git] / bundles / org.simantics.scl.runtime / scl / ISet.scl
1 import "Prelude"
2
3 data Set a = Empty
4            | Cons Integer (Set a) a (Set a)
5
6 @private
7 cons :: Set a -> a -> Set a -> Set a
8 cons l x r = Cons (size l + size r + 1) l x r
9
10 @private
11 rotateSingleL l x (Cons _ m y r) = cons (cons l x m) y r
12
13 @private
14 rotateSingleR (Cons _ l x m) y r = cons l x (cons m y r)
15
16 @private
17 rotateDoubleL l x (Cons _ (Cons _ m1 y m2) z r) = cons (cons l x m1) y (cons m2 z r)
18
19 @private
20 rotateDoubleR (Cons _ l x (Cons _ m1 y m2)) z r = cons (cons l x m1) y (cons m2 z r)
21
22 @private
23 balance :: Set a -> a -> Set a -> Set a
24 balance l x r =
25     let ln = size l
26         rn = size r
27     in  if ln + rn < 2 then cons l x r
28         else if rn > 4*ln then
29             let (Cons _ rl _ rr) = r
30             in  if size rl < 2 * size rr
31                 then rotateSingleL l x r
32                 else rotateDoubleL l x r
33         else if ln > 4*rn then
34             let (Cons _ ll _ lr) = l
35             in  if size lr < 2 * size ll
36                 then rotateSingleR l x r
37                 else rotateDoubleR l x r
38         else cons l x r
39
40 isEmpty :: Set a -> Boolean
41 isEmpty Empty = True
42 isEmpty _ = False
43
44 size :: Set a -> Integer
45 size Empty = 0
46 size (Cons s _ _ _) = s
47
48 member :: Ord a => a -> Set a -> Boolean
49 member _ Empty = False
50 member x (Cons _ l y r) =
51     let cmp = compare x y in
52     if cmp < 0
53     then member x l
54     else if cmp > 0
55     then member x r
56     else True
57
58 empty :: Set a
59 empty = Empty
60
61 singleton :: a -> Set a
62 singleton x = Cons 1 Empty x Empty
63
64 insert :: Ord a => Set a -> a -> Set a
65 insert Empty x = singleton x
66 insert c@(Cons i l y r) x = 
67     let cmp = compare x y in
68     if cmp < 0
69     then balance (insert l x) y r
70     else if cmp > 0
71     then balance l y (insert r x)
72     else c
73
74 delete :: Ord a => Set a -> a -> Set a
75 delete Empty _ = Empty
76 delete (Cons _ l y r) x = 
77     let cmp = compare x y in
78     if cmp < 0
79     then balance (delete l x) y r
80     else if cmp > 0
81     then balance l y (delete r x)
82     else aux l r
83   where
84     aux Empty r = r
85     aux l Empty = l
86     aux l r = let (x, rr) = delmin r
87               in balance l x rr
88
89 delmin :: Ord a => Set a -> (a, Set a)
90 delmin (Cons _ Empty x r) = (x, r)
91 delmin (Cons _ l x r) = let (y, ll) = delmin l
92                         in (y, balance ll x r)
93 delmin _ = fail "Empty set given to delmin."
94
95 union :: Ord a => Set a -> Set a -> Set a
96 union Empty b = b
97 union a Empty = a
98 union a (Cons _ l x r) =
99     let l' = splitL a x
100         r' = splitR a x
101     in concat3 (union l' l) x (union r' r)
102
103 splitL :: Ord a => Set a -> a -> Set a
104 splitL Empty _ = Empty
105 splitL (Cons _ l x r) y =   
106     let cmp = compare x y in
107     if cmp < 0
108     then concat3 l x (splitL r y)
109     else if cmp > 0
110     then splitL l y
111     else l
112
113 splitR :: Ord a => Set a -> a -> Set a
114 splitR Empty _ = Empty
115 splitR (Cons _ l x r) y =   
116     let cmp = compare x y in
117     if cmp < 0
118     then splitR r y
119     else if cmp > 0
120     then concat3 (splitR l y) x r
121     else r
122
123 concat3 :: Ord a => Set a -> a -> Set a -> Set a
124 concat3 Empty x r = insert r x
125 concat3 l x Empty = insert l x
126 concat3 l@(Cons n1 l1 v1 r1) x r@(Cons n2 l2 v2 r2) =
127     if 4*n1 < n2
128     then balance (concat3 l x l2) v2 r2
129     else if 4*n2 < n1
130     then balance l1 v1 (concat3 r1 x r)
131     else cons l x r
132
133 fold :: (a -> b -> a) -> a -> Set b -> a
134 fold f init Empty = init
135 fold f init (Cons _ l x r) = fold f (f (fold f init l) x) r
136
137 instance (Show a) => Show (Set a) where
138     sb <+ t = p True True t
139       where
140         p lm rm Empty = sb <<  
141             if lm 
142             then (if rm then "empty" else "set [")
143             else (if rm then "]" else ", ") 
144         p lm rm (Cons _ l x r) = do
145             p lm False l
146             sb <+ x
147             p False rm r
148
149 set :: Ord a => [a] -> Set a
150 set = foldl insert empty