X-Git-Url: https://gerrit.simantics.org/r/gitweb?p=simantics%2Fplatform.git;a=blobdiff_plain;f=tests%2Forg.simantics.scl.compiler.tests%2Fsrc%2Forg%2Fsimantics%2Fscl%2Fcompiler%2Ftests%2Fscl%2FRedBlackTrees.scl;h=ceb68ad014ba466831e4e96c6a9463516b18f37e;hp=6f47bd0134ced3394f3da278460d86cc11a3db18;hb=172abed5dbf73c1304a7a95bb8504ea293556948;hpb=0580ea8b675c868685993b0780c9ecc31010f681 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 index 6f47bd013..ceb68ad01 100644 --- 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 @@ -1,101 +1,101 @@ -import "Prelude" - -// Version 1, 'untyped' -data Color = R | B - -deriving instance Show Color - -data RB a = E | T Color (RB a) a (RB a) - -rbToList :: RB a -> [a] -rbToList E = [] -rbToList (T _ l a r) = rbToList l + [a] + rbToList r - -deriving instance (Show a) => Show (RB a) - -// Insertion and membership test as by Okasaki -insert :: Ord a => a -> RB a -> RB a -insert x s = (match ins s with T _ a z b -> T B a z b) - where - ins E = T R E x E - ins s = match s with - T B a y b -> - if xy - then balance a y (ins b) - else s - T R a y b -> - if xy - then T R a y (ins b) - else s - -member :: Ord a => a -> RB a -> Boolean -member x E = False -member x (T _ a y b) - | xy = member x b - | otherwise = True - -// balance: first equation is new, to make it work with a weaker invariant -balance :: RB a -> a -> RB a -> RB a -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) -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) -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) -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) -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) -balance a x b = T B a x b - -// deletion a la SMK -delete :: Ord a => a -> RB a -> RB a -delete x t = (match del t with - T _ a y b -> T B a y b - _ -> E) - where - del E = E - del (T _ a y b) - | xy = delformRight a y b - | otherwise = app a b - delformLeft a y b= match a with - T B _ _ _ -> balleft (del a) y b - _ -> T R (del a) y b - delformRight a y b = match b with - T B _ _ _ -> balright a y (del b) - _ -> T R a y (del b) - -balleft :: RB a -> a -> RB a -> RB a -balleft (T R a x b) y c = T R (T B a x b) y c -balleft bl x (T B a y b) = balance bl x (T R a y b) -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)) - -balright :: RB a -> a -> RB a -> RB a -balright a x (T R b y c) = T R a x (T B b y c) -balright (T B a x b) y bl = balance (T R a x b) y bl -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) - -sub1 :: RB a -> RB a -sub1 (T B a x b) = T R a x b -sub1 _ = fail "invariance violation" - -app :: RB a -> RB a -> RB a -app E x = x -app x E = x -app (T R a x b) (T R c y d) = - match app b c with - T R b' z c' -> T R(T R a x b') z (T R c' y d) - bc -> T R a x (T R bc y d) -app (T B a x b) (T B c y d) = - match app b c with - T R b' z c' -> T R(T B a x b') z (T B c' y d) - bc -> balleft a x (T B bc y d) -app a (T R b x c) = T R (app a b) x c -app (T R a x b) c = T R a x (app b c) - -testList = [4,6,2,7,4,7,2,5] - -main = rbToList (foldl (flip insert) E testList) --- +import "Prelude" + +// Version 1, 'untyped' +data Color = R | B + +deriving instance Show Color + +data RB a = E | T Color (RB a) a (RB a) + +rbToList :: RB a -> [a] +rbToList E = [] +rbToList (T _ l a r) = rbToList l + [a] + rbToList r + +deriving instance (Show a) => Show (RB a) + +// Insertion and membership test as by Okasaki +insert :: Ord a => a -> RB a -> RB a +insert x s = (match ins s with T _ a z b -> T B a z b) + where + ins E = T R E x E + ins s = match s with + T B a y b -> + if xy + then balance a y (ins b) + else s + T R a y b -> + if xy + then T R a y (ins b) + else s + +member :: Ord a => a -> RB a -> Boolean +member x E = False +member x (T _ a y b) + | xy = member x b + | otherwise = True + +// balance: first equation is new, to make it work with a weaker invariant +balance :: RB a -> a -> RB a -> RB a +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) +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) +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) +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) +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) +balance a x b = T B a x b + +// deletion a la SMK +delete :: Ord a => a -> RB a -> RB a +delete x t = (match del t with + T _ a y b -> T B a y b + _ -> E) + where + del E = E + del (T _ a y b) + | xy = delformRight a y b + | otherwise = app a b + delformLeft a y b= match a with + T B _ _ _ -> balleft (del a) y b + _ -> T R (del a) y b + delformRight a y b = match b with + T B _ _ _ -> balright a y (del b) + _ -> T R a y (del b) + +balleft :: RB a -> a -> RB a -> RB a +balleft (T R a x b) y c = T R (T B a x b) y c +balleft bl x (T B a y b) = balance bl x (T R a y b) +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)) + +balright :: RB a -> a -> RB a -> RB a +balright a x (T R b y c) = T R a x (T B b y c) +balright (T B a x b) y bl = balance (T R a x b) y bl +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) + +sub1 :: RB a -> RB a +sub1 (T B a x b) = T R a x b +sub1 _ = fail "invariance violation" + +app :: RB a -> RB a -> RB a +app E x = x +app x E = x +app (T R a x b) (T R c y d) = + match app b c with + T R b' z c' -> T R(T R a x b') z (T R c' y d) + bc -> T R a x (T R bc y d) +app (T B a x b) (T B c y d) = + match app b c with + T R b' z c' -> T R(T B a x b') z (T B c' y d) + bc -> balleft a x (T B bc y d) +app a (T R b x c) = T R (app a b) x c +app (T R a x b) c = T R a x (app b c) + +testList = [4,6,2,7,4,7,2,5] + +main = rbToList (foldl (flip insert) E testList) +-- [2, 4, 5, 6, 7] \ No newline at end of file