bundles/org.simantics.scl.compiler/tests/org/simantics/scl/compiler/tests/scl/RedBlackTrees.scl

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