Bad sort functions tested

1 files changed, 51 insertions, 4 deletions

diff --git a/demo/more/dlist.ur b/demo/more/dlist.ur
index 244c54a7..a8c464a6 100644
--- a/demo/more/dlist.ur
+++ b/demo/more/dlist.ur
@@ -79,11 +79,57 @@ fun renderDyn [ctx] [ctx ~ body] [t] (f : t -> position -> xml (ctx ++ body) []
 fun renderFlat [ctx] [ctx ~ body] [t] (f : t -> position -> xml (ctx ++ body) [] []) filter ls =
     List.mapX (fn p => f p.1 p.2) ls
 
-fun render [ctx] [ctx ~ body] [t] f r dl = <xml>
-    <dyn signal={sort <- r.Sort;
-                 case sort of
+val split [t] =
+    let
+        fun split' acc (ls : list t) =
+            case ls of
+                [] => acc
+              | x1 :: [] => (x1 :: acc.1, acc.2)
+              | x1 :: x2 :: ls => split' (x1 :: acc.1, x2 :: acc.2) ls
+    in
+        split' ([], [])
+    end
+
+fun merge [t] (cmp : t -> t -> signal bool) =
+    let
+        fun merge' acc (ls1 : list t) (ls2 : list t) =
+            case (ls1, ls2) of
+                ([], _) => return (List.revAppend acc ls2)
+              | (_, []) => return (List.revAppend acc ls1)
+              | (x1 :: ls1', x2 :: ls2') =>
+                b <- cmp x1 x2;
+                if b then
+                    merge' (x1 :: acc) ls1' ls2
+                else
+                    merge' (x2 :: acc) ls1 ls2'
+    in
+        merge' []
+    end
+
+fun sort [t] (cmp : t -> t -> signal bool) =
+    let
+        fun sort' (ls : list t) =
+            case ls of
+                [] => return ls
+              | _ :: [] => return ls
+              | _ =>
+                let
+                    val (ls1, ls2) = split ls
+                in
+                    ls1' <- sort' ls1;
+                    ls2' <- sort' ls2;
+                    merge cmp ls1' ls2'
+                end
+    in
+        sort'
+    end
+
+fun render [ctx] [ctx ~ body] [t] f (r : {Filter : t -> signal bool,
+                                          Sort : signal (option (t -> t -> signal bool))}) dl = <xml>
+    <dyn signal={cmp <- r.Sort;
+                 case cmp of
                      None => return (renderDyn f r.Filter dl)
-                   | Some sort =>
+                   | Some cmp =>
                      dl' <- signal dl;
                      elems <- (case dl' of
                                    Empty => return []
@@ -104,6 +150,7 @@ fun render [ctx] [ctx ~ body] [t] f r dl = <xml>
                                    in
                                        listOut None hd []
                                    end);
+                     elems <- sort (fn v1 v2 => cmp v1.1 v2.1) elems;
                      return (renderFlat f r.Filter elems)}/>
 </xml>