[MLton-commit] r5371
Vesa Karvonen
vesak at mlton.org
Thu Mar 1 03:50:58 PST 2007
Switched to an easier to understand Node design.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/node.sml 2007-03-01 02:10:46 UTC (rev 5370)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/node.sml 2007-03-01 11:50:48 UTC (rev 5371)
@@ -4,193 +4,95 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(*
- * Imperative singly linked list node. This is useful and often more
- * convenient than a functional list when implementing imperative data
- * structures.
+(**
+ * Imperative singly linked list node. This is useful and possibly more
+ * convenient and efficient than a functional list when implementing
+ * imperative data structures (e.g. imperative hast tables).
*
* Note that imperative lists may form cycles and, unless otherwise
* specified, procedures specified in this module are not specifically
* designed to work with cyclic lists.
*)
-
structure Node :> sig
- eqtype 'a t
+ type 'a t
+ type 'a p = 'a t Option.t Ref.t
- val new : 'a t Thunk.t
- (** Allocates a new empty node. *)
+ val new : 'a -> 'a t
+ val ptr : 'a p Thunk.t
- val get : 'a t -> ('a * 'a t) Option.t
- (** Returns the contents of the node. *)
+ val next : 'a t -> 'a p
+ val value : 'a t -> 'a
- val <- : ('a t * ('a * 'a t) Option.t) Effect.t
- (** Sets the contents of the node. *)
+ val isEmpty : 'a p UnPr.t
- val isEmpty : 'a t UnPr.t
- (** Returns true iff the imperative list is empty. *)
+ val length : 'a p -> Int.t
- val hd : 'a t -> 'a
- (**
- * Returns the first element of the imperative list. Raises {Empty} if
- * the list is empty.
- *)
+ val hd : 'a p -> 'a
+ val tl : 'a p UnOp.t
- val tl : 'a t -> 'a t
- (**
- * Returns the next node of the imperative list. Raises {Empty} if the
- * list is empty.
- *)
+ val push : 'a p -> 'a Effect.t
+ val pop : 'a p -> 'a Option.t
- val push : 'a t -> 'a Effect.t
- (**
- * Inserts the given element into the imperative list after the given
- * node.
- *)
+ val drop : 'a p Effect.t
- val take : 'a t -> 'a Option.t
- (**
- * If the imperative list is non-empty, removes the first element {v}
- * of the list and returns {SOME v}. Otherwise returns {NONE}.
- *)
+ val find : 'a UnPr.t -> 'a p -> ('a p, 'a p) Sum.t
+ val fold : ('a * 's -> 's) -> 's -> 'a p -> 's
- val drop : 'a t Effect.t
- (**
- * If the imperative list is non-empty, removes the first element of
- * the list. Otherwise does nothing.
- *)
+ val toList : 'a p -> 'a List.t
- val appClear : 'a Effect.t -> 'a t UnOp.t
- (**
- * Takes all elements of the imperative list of nodes one-by-one and
- * performs the given effect on the removed elements. Returns the
- * last, and always empty, node of the remaining list.
- *)
+ val filter : 'a UnPr.t -> 'a p UnOp.t
- val fromList : 'a List.t -> 'a t
- (** Constructs an imperative list from a functional list. *)
+ val appClear : 'a Effect.t -> 'a p UnOp.t
+end = struct
+ datatype 'a t = T of 'a * 'a p
+ withtype 'a p = 'a t Option.t Ref.t
- val toList : 'a t -> 'a List.t
- (**
- * Returns a functional list containing the same elements as the imperative
- * list.
- *)
+ fun ptr () = ref NONE
+ fun new v = T (v, ptr ())
- val app : 'a Effect.t -> 'a t Effect.t
- (**
- * Applies the given effect to all elements of the imperative list.
- * {app} is to be implemented tail recursively.
- *)
+ fun next (T (_, p)) = p
+ fun value (T (v, _)) = v
- val find : 'a UnPr.t -> 'a t -> ('a t, 'a t) Sum.t
- (**
- * Returns {INR n} where {n} is first node containing an element
- * satisfying the given predicate or {INL n} where {n} is the last node
- * in the imperative list. {find} is to be implemented tail
- * recursively.
- *)
+ fun isEmpty p = isNone (!p)
- val length : 'a t -> Int.t
- (** Returns the length of the given imperative list. *)
+ fun nonEmpty f p = case !p of NONE => raise Empty | SOME n => f n
+ fun hd p = nonEmpty value p
+ fun tl p = nonEmpty next p
- val filter : 'a UnPr.t -> 'a t UnOp.t
- (**
- * Drops all nodes from the imperative list whose elements do not
- * satisfy the given predicate. Returns the last, and always empty,
- * node of the remaining list.
- *)
+ fun drop p = p := !(tl p)
- val filterOut : 'a UnPr.t -> 'a t UnOp.t
- (**
- * Drops all nodes from the imperative list whose elements satisfy the
- * given predicate. Returns the last, and always empty, node of the
- * remaining list.
- *)
-
- val foldl : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
- (**
- * Folds the imperative lists with the given function and starting
- * value. {foldl} is to be implemented tail recursively.
- *)
-end = struct
- datatype 'a t = IN of ('a * 'a t) Option.t Ref.t
- fun new () = IN (ref NONE)
- fun get (IN t) = !t
- fun (IN r) <- t = r := t
-
- (* The following only use the operations {new}, {get}, and {<-}. *)
-
- fun fromList l = let
- val h = new ()
- fun lp ([], _) = ()
- | lp (x::xs, t) = let
- val t' = new ()
- in
- t <- SOME (x, t')
- ; lp (xs, t')
- end
+ fun push p v = let
+ val n = new v
in
- lp (l, h)
- ; h
+ next n := !p ; p := SOME n
end
- fun isEmpty t =
- not (isSome (get t))
-
- local
- fun eat t =
- case get t of
- NONE => raise Empty
- | SOME x => x
- in
- fun hd t = #1 (eat t)
- fun tl t = #2 (eat t)
- end
-
- fun push t x = let
- val n = new ()
- in
- n <- get t
- ; t <- SOME (x, n)
- end
-
- fun take t =
- case get t of
+ fun pop p =
+ case !p of
NONE => NONE
- | SOME (x, t') => (t <- get t' ; SOME x)
+ | SOME (T (v, p')) => (p := !p' ; SOME v)
- fun drop t =
- ignore (take t)
+ fun find c p =
+ case !p of
+ NONE => INL p
+ | SOME (T (v, p')) => if c v then INR p else find c p'
- fun appClear e t =
- case get t of
- NONE => t
- | SOME (x, t') => (e x : unit ; t <- get t' ; appClear e t)
+ fun fold f s p =
+ case !p of
+ NONE => s
+ | SOME (T (v, p)) => fold f (f (v, s)) p
- fun foldl f x t =
- case get t of
- NONE => x
- | SOME (y, t) =>
- foldl f (f (y, x)) t
+ fun toList p = rev (fold op :: [] p)
- fun toList n =
- rev (foldl op :: [] n)
+ fun length p = fold (1 <\ op + o #2) 0 p
- fun app e =
- foldl (e o #1) ()
+ fun filter c p =
+ case !p of
+ NONE => p
+ | SOME (T (v, n)) => if c v then filter c n else (p := !n ; filter c p)
- fun find p t =
- case get t of
- NONE => INL t
- | SOME (x, t') =>
- if p x then INR t else find p t'
-
- fun length n = foldl (1 <\ op + o #2) 0 n
-
- fun filter p t =
- case get t of
- NONE => t
- | SOME (x, t') =>
- if p x then filter p t' else (t <- get t' ; filter p t)
-
- fun filterOut p = filter (negate p)
+ fun appClear ef p =
+ case !p of
+ NONE => p
+ | SOME (T (v, n)) => (ef v : unit ; p := !n ; appClear ef p)
end
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml 2007-03-01 02:10:46 UTC (rev 5370)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml 2007-03-01 11:50:48 UTC (rev 5371)
@@ -17,43 +17,39 @@
val filterOut : 'a UnPr.t -> 'a t Effect.t
val appClear : 'a Effect.t -> 'a t Effect.t
end = struct
- structure N = Node
+ datatype 'a t = T of {back : 'a Node.p Ref.t, front : 'a Node.p Ref.t}
- datatype 'a t = IN of {back : 'a N.t Ref.t,
- front : 'a N.t Ref.t}
-
fun new () = let
- val n = N.new ()
+ val p = Node.ptr ()
in
- IN {back = ref n, front = ref n}
+ T {back = ref p, front = ref p}
end
- fun isEmpty (IN {front, ...}) =
- not (isSome (N.get (!front)))
+ fun isEmpty (T {front, ...}) =
+ Node.isEmpty (!front)
- fun length (IN {front, ...}) =
- N.length (!front)
+ fun length (T {front, ...}) =
+ Node.length (!front)
- fun enque (IN {back, ...}) =
- fn a => let
+ fun enque (T {back, ...}) =
+ fn v => let
val r = !back
- val n = N.new ()
+ val n = Node.new v
in
- N.<- (r, SOME (a, n))
- ; back := n
+ r := SOME n
+ ; back := Node.next n
end
- fun deque (IN {front, ...}) =
- case N.get (!front) of
+ fun deque (T {front, ...}) =
+ case !(!front) of
NONE => NONE
- | SOME (a, n) => (front := n ; SOME a)
+ | SOME n => (front := Node.next n ; SOME (Node.value n))
- fun filter p (IN {back, front}) =
- back := N.filter p (!front)
+ fun filter c (T {back, front}) =
+ back := Node.filter c (!front)
- fun filterOut p =
- filter (negate p)
+ fun filterOut c = filter (negate c)
- fun appClear ef (IN {back, front}) =
- back := N.appClear ef (!front)
+ fun appClear ef (T {back, front}) =
+ back := Node.appClear ef (!front)
end
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml 2007-03-01 02:10:46 UTC (rev 5370)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml 2007-03-01 11:50:48 UTC (rev 5371)
@@ -16,7 +16,7 @@
structure WordTable :> WORD_TABLE where type Key.t = Word32.t = struct
structure Key = Word32 and W = Word32 and N = Node and V = Vector
- datatype 'a t = IN of {table : (W.t * 'a) N.t Vector.t Ref.t,
+ datatype 'a t = IN of {table : (W.t * 'a) N.p Vector.t Ref.t,
size : Int.t Ref.t}
val caps = V.fromList
@@ -32,7 +32,7 @@
fun keyToIdx t key = W.toIntX (key mod W.fromInt (V.length (table t)))
fun putAt t idx entry = N.push (V.sub (table t, idx)) entry
- fun newTable cap = V.tabulate (cap, N.new o ignore)
+ fun newTable cap = V.tabulate (cap, N.ptr o ignore)
fun findKey t idx key = N.find (key <\ op = o #1) (V.sub (table t, idx))
fun maybeRealloc (t as IN {table, ...}) = let
@@ -60,14 +60,13 @@
()
end
- fun new () = IN {table = ref (newTable minCap),
- size = ref 0}
+ fun new () = IN {table = ref (newTable minCap), size = ref 0}
- fun == (IN {table = l, ...}, IN {table = r, ...}) = l = r
+ fun == (IN l, IN r) = #table l = #table r
structure Action = struct
- type ('v, 'r) t = ((W.t * 'v) N.t,
- (W.t * 'v) N.t) Sum.t * W.t * 'v t -> 'r
+ type ('v, 'r) t = ((W.t * 'v) N.p,
+ (W.t * 'v) N.p) Sum.t * W.t * 'v t -> 'r
type ('v, 'r, 's) m = ('v, 'r) t
type none = unit
type some = unit
@@ -93,7 +92,8 @@
fn (INL _, _, _) =>
undefined ()
| (INR n, key, _) =>
- (N.<- (n, SOME ((key, value), N.tl n))
+ (N.drop n
+ ; N.push n (key, value)
; result)
fun remove result =
More information about the MLton-commit
mailing list