]> gerrit.simantics Code Review - simantics/platform.git/blob - tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/RedBlackTrees.scl
Supply SVG text editor with element measurement context
[simantics/platform.git] / tests / org.simantics.scl.compiler.tests / src / org / simantics / scl / compiler / tests / scl / RedBlackTrees.scl
1 import "Prelude"
2
3 // Version 1, 'untyped'
4 data Color = R | B 
5
6 deriving instance Show Color
7
8 data RB a = E | T Color (RB a) a (RB a)
9
10 rbToList :: RB a -> [a]
11 rbToList E = []
12 rbToList (T _ l a r) = rbToList l + [a] + rbToList r
13
14 deriving instance (Show a) => Show (RB a)
15
16 // Insertion and membership test as by Okasaki
17 insert :: Ord a => a -> RB a -> RB a
18 insert x s = (match ins s with T _ a z b -> T B a z b) 
19     where
20         ins E = T R E x E
21         ins s = match s with
22           T B a y b ->
23               if x<y 
24               then balance (ins a) y b
25               else if x>y 
26               then balance a y (ins b)
27               else s
28           T R a y b ->
29               if x<y
30               then T R (ins a) y b
31               else if x>y 
32               then T R a y (ins b)
33               else s
34
35 member :: Ord a => a -> RB a -> Boolean
36 member x E = False
37 member x (T _ a y b)
38     | x<y = member x a
39     | x>y = member x b
40     | otherwise = True
41
42 // balance: first equation is new, to make it work with a weaker invariant
43 balance :: RB a -> a -> RB a -> RB a
44 balance (T R a x b) y (T R c z d) = T R (T B a x b) y (T B c z d)
45 balance (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
46 balance (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
47 balance a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
48 balance a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
49 balance a x b = T B a x b
50
51 // deletion a la SMK 
52 delete :: Ord a => a -> RB a -> RB a
53 delete x t = (match del t with 
54                T _ a y b -> T B a y b
55                _ -> E)
56       where
57         del E = E
58         del (T _ a y b)
59             | x<y = delformLeft a y b
60             | x>y = delformRight a y b
61             | otherwise = app a b
62         delformLeft a y b= match a with
63             T B _ _ _ -> balleft (del a) y b
64             _         -> T R (del a) y b
65         delformRight a y b = match b with
66             T B _ _ _ -> balright a y (del b)
67             _         -> T R a y (del b)
68
69 balleft :: RB a -> a -> RB a -> RB a
70 balleft (T R a x b) y c = T R (T B a x b) y c
71 balleft bl x (T B a y b) = balance bl x (T R a y b)
72 balleft bl x (T R (T B a y b) z c) = T R (T B bl x a) y (balance b z (sub1 c))
73
74 balright :: RB a -> a -> RB a -> RB a
75 balright a x (T R b y c) = T R a x (T B b y c)
76 balright (T B a x b) y bl = balance (T R a x b) y bl
77 balright (T R a x (T B b y c)) z bl = T R (balance (sub1 a) x b) y (T B c z bl)
78
79 sub1 :: RB a -> RB a
80 sub1 (T B a x b) = T R a x b
81 sub1 _ = fail "invariance violation"
82
83 app :: RB a -> RB a -> RB a
84 app E x = x
85 app x E = x
86 app (T R a x b) (T R c y d) =
87     match app b c with
88         T R b' z c' -> T R(T R a x b') z (T R c' y d)
89         bc -> T R a x (T R bc y d)
90 app (T B a x b) (T B c y d) = 
91     match app b c with
92         T R b' z c' -> T R(T B a x b') z (T B c' y d)
93         bc -> balleft a x (T B bc y d)
94 app a (T R b x c) = T R (app a b) x c
95 app (T R a x b) c = T R a x (app b c)
96
97 testList = [4,6,2,7,4,7,2,5]
98
99 main = rbToList (foldl (flip insert) E testList)
100 --
101 [2, 4, 5, 6, 7]