Automatic execution of SCL tests in Maven

[simantics/platform.git] / tests / org.simantics.scl.compiler.tests / src / org / simantics / scl / compiler / tests / scl / RedBlackTrees.scl

diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/RedBlackTrees.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/RedBlackTrees.scl
new file mode 100644 (file)
index 0000000..6f47bd0
--- /dev/null
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/RedBlackTrees.scl
@@ -0,0 +1,101 @@
+import "Prelude"\r
+\r
+// Version 1, 'untyped'\r
+data Color = R | B \r
+\r
+deriving instance Show Color\r
+\r
+data RB a = E | T Color (RB a) a (RB a)\r
+\r
+rbToList :: RB a -> [a]\r
+rbToList E = []\r
+rbToList (T _ l a r) = rbToList l + [a] + rbToList r\r
+\r
+deriving instance (Show a) => Show (RB a)\r
+\r
+// Insertion and membership test as by Okasaki\r
+insert :: Ord a => a -> RB a -> RB a\r
+insert x s = (match ins s with T _ a z b -> T B a z b) \r
+    where\r
+        ins E = T R E x E\r
+        ins s = match s with\r
+          T B a y b ->\r
+              if x<y \r
+              then balance (ins a) y b\r
+              else if x>y \r
+              then balance a y (ins b)\r
+              else s\r
+          T R a y b ->\r
+              if x<y\r
+              then T R (ins a) y b\r
+              else if x>y \r
+              then T R a y (ins b)\r
+              else s\r
+\r
+member :: Ord a => a -> RB a -> Boolean\r
+member x E = False\r
+member x (T _ a y b)\r
+    | x<y = member x a\r
+    | x>y = member x b\r
+    | otherwise = True\r
+\r
+// balance: first equation is new, to make it work with a weaker invariant\r
+balance :: RB a -> a -> RB a -> RB a\r
+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
+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
+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
+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
+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
+balance a x b = T B a x b\r
+\r
+// deletion a la SMK \r
+delete :: Ord a => a -> RB a -> RB a\r
+delete x t = (match del t with \r
+               T _ a y b -> T B a y b\r
+               _ -> E)\r
+      where\r
+        del E = E\r
+        del (T _ a y b)\r
+            | x<y = delformLeft a y b\r
+            | x>y = delformRight a y b\r
+            | otherwise = app a b\r
+        delformLeft a y b= match a with\r
+            T B _ _ _ -> balleft (del a) y b\r
+            _         -> T R (del a) y b\r
+        delformRight a y b = match b with\r
+            T B _ _ _ -> balright a y (del b)\r
+            _         -> T R a y (del b)\r
+\r
+balleft :: RB a -> a -> RB a -> RB a\r
+balleft (T R a x b) y c = T R (T B a x b) y c\r
+balleft bl x (T B a y b) = balance bl x (T R a y b)\r
+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
+\r
+balright :: RB a -> a -> RB a -> RB a\r
+balright a x (T R b y c) = T R a x (T B b y c)\r
+balright (T B a x b) y bl = balance (T R a x b) y bl\r
+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
+\r
+sub1 :: RB a -> RB a\r
+sub1 (T B a x b) = T R a x b\r
+sub1 _ = fail "invariance violation"\r
+\r
+app :: RB a -> RB a -> RB a\r
+app E x = x\r
+app x E = x\r
+app (T R a x b) (T R c y d) =\r
+    match app b c with\r
+        T R b' z c' -> T R(T R a x b') z (T R c' y d)\r
+        bc -> T R a x (T R bc y d)\r
+app (T B a x b) (T B c y d) = \r
+    match app b c with\r
+        T R b' z c' -> T R(T B a x b') z (T B c' y d)\r
+        bc -> balleft a x (T B bc y d)\r
+app a (T R b x c) = T R (app a b) x c\r
+app (T R a x b) c = T R a x (app b c)\r
+\r
+testList = [4,6,2,7,4,7,2,5]\r
+\r
+main = rbToList (foldl (flip insert) E testList)\r
+--\r
+[2, 4, 5, 6, 7]
\ No newline at end of file