From 7c045f4dd298b8cc1cbe5895b4fc30280e23abbf Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 17 Sep 2009 14:57:38 -0400
Subject: Bad sort functions tested

---
 demo/more/dlist.ur | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++----
 demo/more/grid.ur  |  2 +-
 2 files changed, 52 insertions(+), 5 deletions(-)

(limited to 'demo')

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>
                              
diff --git a/demo/more/grid.ur b/demo/more/grid.ur
index a59e1082..2b451456 100644
--- a/demo/more/grid.ur
+++ b/demo/more/grid.ur
@@ -213,7 +213,7 @@ functor Make(M : sig
                                               return (previous && this))
                                           (fn _ => return True)
                                           [_] M.folder M.cols grid.Cols grid.Filters row,
-                       Sort = return None}
+                       Sort = return (Some (fn _ _ => return False))}
                       grid.Rows}
 
             <dyn signal={rows <- Dlist.foldl (fn row => Monad.mapR2 [aggregateMeta M.row] [id] [id]
-- 
cgit v1.2.3