A new example with negation and the basics of toposort

git-svn-id: https://svn.concert.cs.cmu.edu/lollibot/trunk@116 88e30042-7354-0410-bf5e-e4d69759226d

src/algo/toposort-sig.sml

@@ -1,37 +1,21 @@
-
-(* Topological sort algorithm. 
-
-   Given a list of nodes and constraints between them,
-   produce a list that satisfies the constaints, if
-   one exists. The constraints are all of the form,
-   "item a must appear somewhere before item b in
-   the list." If a topological sorting doesn't exist,
-   raise the exception TopoSort.
-   
-   To use this algorithm, map 'node' over your items
-   to create nodes. Then, create a list of constraints
-   (pairs of nodes that must be ordered), and call
-   solve. Finally, use 'get' to retrieve the original
-   elements from the node list returned.
-
-*)
-
 signature TOPOSORT =
 sig
-
-    exception TopoSort of string
-
-    type 'a node
 
-    type 'a constraint
+    type member
+    type constraint
+    type result
+
+    exception TopoSort of member * member
 
-    (* constraint a b => "a must appear before b" *)
-    val constraint : 'a node * 'a node -> 'a constraint
+    (* constraint_lt a b => "a must appear before b" *)
+    val constraint_lt : member * member -> constraint
 
-    val node : 'a -> 'a node
+    (* constraint_leq a b => "a must appear no later than b" *)
+    val constraint_leq : member * member -> constraint
 
-    val sort : 'a node list -> 'a constraint list -> 'a node list
+    val sort : constraint list -> result
 
-    val get : 'a node -> 'a
+    val get_all : result -> (member * int) list
+    val get : result * member -> int
 
 end

src/algo/toposort.cm

@@ -0,0 +1,4 @@
+Group is
+  $/smlnj-lib.cm
+  toposort-sig.sml
+  toposort.sml

src/algo/toposort.sml

@@ -1,44 +1,25 @@
-
-(* Topological sort algorithm. Naive
-   list version.
-*)
-
-structure TopoSort :> TOPOSORT =
+functor TopoSort (Key : ORD_KEY) :> TOPOSORT where type member = Key.ord_key =
 struct
-
-    exception TopoSort of string
-
-    type stamp = unit ref
-
-    type 'a node = 'a * unit ref
 
-    (* (a, b) => "a must appear before b" *)
-    type 'a constraint = unit ref * unit ref
+    structure Map = SplayMapFn(Key)
 
-    fun constraint ((_,a), (_,b)) = (a, b)
+    type member = Key.ord_key
+    datatype constraint = 
+         HARD of member * member
+       | SOFT of member * member    
+    type result = int Map.map
 
-    fun node a = (a, ref())
+    exception TopoSort of member * member
 
-    (* XXX PERF this could be a lot more efficient with better
-       data structures *)
+    val constraint_lt = HARD
+    val constraint_leq = SOFT
 
-    fun sort nil nil = nil
-      | sort nil _ = raise TopoSort "constraints on non-members"
-      | sort nl cl =
-        case List.partition 
-              (fn (_,x) =>
-               (* must something come before it? *)
-               List.exists (fn (a, b : 'a ref) => b = x) cl) nl of
-              (_, nil) => raise TopoSort "sort impossible"
-            | (wait, ready) =>
-                  ready @ sort wait 
-                  (List.filter
-                   (fn (a, b) =>
-                    not 
-                    (List.exists 
-                     (fn (_, x) => x = a) 
-                     ready)) cl)
+    val sort = 
+        foldr (fn (HARD (a,b), map) => Map.insert(Map.insert(map,a,1),b,1)
+                | (SOFT (a,b), map) => Map.insert(Map.insert(map,a,1),b,1))
+              Map.empty
 
-    fun get (a, _) = a
+    val get_all = Map.listItemsi
+    val get = Map.lookup
 
 end

src/sources.cm

@@ -5,6 +5,7 @@ Group is
   util/utf8.cm
   util/util.cm
   util/stream.cm
+  algo/toposort.cm
   parse/parse.cm
 
   global-sig.sml

src/term.sml

@@ -20,6 +20,7 @@ sig
   val to_string_parens : term -> string
   val to_string_env : string list -> term -> string
   val eq : term * term -> bool
+  val compare : term * term -> order
 end
 
 structure Term :> TERM = 
@@ -140,5 +141,29 @@ struct
         i1 = i2 andalso ListPair.all eq (trms1,trms2)
       | _ => false
 
+  fun compares ([],[]) = EQUAL
+    | compares (trm1 :: trms1, trm2 :: trms2) = 
+      (case compare (trm1, trm2) of
+         EQUAL => compares (trms1, trms2)
+       | ord => ord)
+    | compares _ = raise Err "Typing invariant in comparision function"
+
+  and compare (trm1,trm2) = 
+      case (trm1,trm2) of
+        (Lambda(_,trm1), Lambda(_,trm2)) => compare (trm1, trm2)
+      | (Const(s1,trms1), Const(s2,trms2)) => 
+        (case String.compare(s1,s2) of
+           EQUAL => compares (trms1,trms2)
+         | ord => ord)
+      | (Var(i1,trms1), Var(i2,trms2)) =>
+        (case Int.compare(i1,i2) of
+           EQUAL => compares (trms1,trms2) 
+         | ord => ord)
+      | (Const _, Var _) => LESS
+      | (Var _, Const _) => GREATER
+      | _ => raise Err "Typing invariant in comparison function" 
+             (* Probably shouldn't compare terms at different types... *)
+
+
 end