Skip to content
Browse files

Add a util directory for code that we want but that really doesn't be…

…long in smackage, since I think having binary releases is a little bit optimistic for now. We can't always live in the beautiful new world we're creating :-).
  • Loading branch information...
1 parent 43ebb97 commit ce93594b3f223e2ba5ca0610cd12478b08be1ed9 @robsimmons robsimmons committed
Showing with 211 additions and 2 deletions.
  1. +4 −2 AUTHORS
  2. +5 −0 util/README
  3. +140 −0 util/dict-list.sml
  4. +32 −0 util/dict.sig
  5. +25 −0 util/sort.sml
  6. +5 −0 util/sources.cm
View
6 AUTHORS
@@ -1,4 +1,6 @@
+Gian Perrone
Joakim Ahnfelt-R�nne
-Gian Perrone <gdpe at itu dot dk>
-Robert J. Simmons <robsimmons at gmail dot com>
+Karl Crary - Code from CMlib in the util directory
Michael Sullivan
+Robert J. Simmons
+
View
5 util/README
@@ -0,0 +1,5 @@
+Smackage would eventually like to enjoy the bounty of smackage itself - being
+able to rely on other sources of library code! But unless we're distributing
+binaries, this leads to a problematic bootstrapping problem. This directory is
+where we put code that we should be able to get via smackage someday, mostly
+taken from CMlib.
View
140 util/dict-list.sml
@@ -0,0 +1,140 @@
+
+functor ListDict (structure Key : sig type t val compare: t * t -> order end)
+ :> DICT where type key = Key.t
+ =
+ struct
+
+ type key = Key.t
+ type 'a dict = (key * 'a) list
+
+ exception Absent
+
+ val empty = []
+
+ val isEmpty = null
+
+ fun singleton key x = [(key, x)]
+
+ fun insert l key x =
+ (case l of
+ [] => [(key, x)]
+ | (key', y) :: rest =>
+ (case Key.compare (key, key') of
+ LESS =>
+ (key, x) :: l
+ | EQUAL =>
+ (key, x) :: rest
+ | GREATER =>
+ (key', y) :: insert rest key x))
+
+ fun remove l key =
+ (case l of
+ [] => []
+ | (key', y) :: rest =>
+ (case Key.compare (key, key') of
+ LESS => l
+ | EQUAL => rest
+ | GREATER =>
+ (key', y) :: remove rest key))
+
+ fun operate l key absentf presentf =
+ (case l of
+ [] =>
+ let
+ val x = absentf ()
+ in
+ (NONE, x, [(key, x)])
+ end
+ | (key', y) :: rest =>
+ (case Key.compare (key, key') of
+ LESS =>
+ let
+ val x = absentf ()
+ in
+ (NONE, x, (key, x) :: l)
+ end
+ | EQUAL =>
+ let
+ val x = presentf y
+ in
+ (SOME y, x, (key, x) :: rest)
+ end
+ | GREATER =>
+ let
+ val (ante, post, rest') = operate rest key absentf presentf
+ in
+ (ante, post, (key', y) :: rest')
+ end))
+
+ fun insertMerge dict key x f =
+ #3 (operate dict key (fn () => x) f)
+
+ fun find l key =
+ (case l of
+ [] =>
+ NONE
+ | (key', x) :: rest =>
+ (case Key.compare (key, key') of
+ LESS =>
+ NONE
+ | EQUAL =>
+ SOME x
+ | GREATER =>
+ find rest key))
+
+ fun lookup l key =
+ (case l of
+ [] =>
+ raise Absent
+ | (key', x) :: rest =>
+ (case Key.compare (key, key') of
+ LESS =>
+ raise Absent
+ | EQUAL =>
+ x
+ | GREATER =>
+ lookup rest key))
+
+ fun member l key =
+ (case l of
+ [] =>
+ false
+ | (key', _) :: rest =>
+ (case Key.compare (key, key') of
+ LESS =>
+ false
+ | EQUAL =>
+ true
+ | GREATER =>
+ member rest key))
+
+ val size = length
+
+ fun union l1 l2 f =
+ (case (l1, l2) of
+ ([], _) =>
+ l2
+ | (_, []) =>
+ l1
+ | ((entry1 as (key1, x1)) :: rest1, (entry2 as (key2, x2)) :: rest2) =>
+ (case Key.compare (key1, key2) of
+ LESS =>
+ entry1 :: union rest1 l2 f
+ | GREATER =>
+ entry2 :: union l1 rest2 f
+ | EQUAL =>
+ (key1, f (key1, x1, x2)) :: union rest1 rest2 f))
+
+ fun toList l = l
+
+ fun domain l = List.map (fn (key, _) => key) l
+
+ fun map f l = List.map (fn (key, x) => (key, f x)) l
+
+ fun foldl f base l = List.foldl (fn ((key, x), y) => f (key, x, y)) base l
+
+ fun foldr f base l = List.foldr (fn ((key, x), y) => f (key, x, y)) base l
+
+ val app = List.app
+
+ end
View
32 util/dict.sig
@@ -0,0 +1,32 @@
+
+signature DICT =
+ sig
+
+ type key
+ type 'a dict
+
+ exception Absent
+
+ val empty : 'a dict
+ val singleton : key -> 'a -> 'a dict
+ val insert : 'a dict -> key -> 'a -> 'a dict
+ val remove : 'a dict -> key -> 'a dict
+ val find : 'a dict -> key -> 'a option
+ val lookup : 'a dict -> key -> 'a
+ val union : 'a dict -> 'a dict -> (key * 'a * 'a -> 'a) -> 'a dict
+
+ val operate : 'a dict -> key -> (unit -> 'a) -> ('a -> 'a) -> 'a option * 'a * 'a dict
+ val insertMerge : 'a dict -> key -> 'a -> ('a -> 'a) -> 'a dict
+
+ val isEmpty : 'a dict -> bool
+ val member : 'a dict -> key -> bool
+ val size : 'a dict -> int
+
+ val toList : 'a dict -> (key * 'a) list
+ val domain : 'a dict -> key list
+ val map : ('a -> 'b) -> 'a dict -> 'b dict
+ val foldl : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b
+ val foldr : (key * 'a * 'b -> 'b) -> 'b -> 'a dict -> 'b
+ val app : (key * 'a -> unit) -> 'a dict -> unit
+
+ end
View
25 util/sort.sml
@@ -0,0 +1,25 @@
+
+signature SORT =
+sig
+ val sort: ('a * 'a -> order) -> 'a list -> 'a list
+end
+
+(* Not totally stupid. We're mostly re-sorting mostly sorted lists, and this
+ * implementation should be O(n) in that case. *)
+structure InsertionSort:> SORT =
+struct
+ fun sort compare =
+ let
+ (* Insert takes a reverse-sorted list and inserts x into it. *)
+ fun insert x [] = [ x ]
+ | insert x (y :: ys) =
+ (case compare (x, y) of
+ LESS => y :: insert x ys
+ | _ => x :: y :: ys)
+
+ fun loop sorted [] = rev sorted
+ | loop sorted (x :: unsorted) = loop (insert x sorted) unsorted
+ in
+ loop []
+ end
+end
View
5 util/sources.cm
@@ -0,0 +1,5 @@
+Group is
+ $/basis.cm
+ sort.sml
+ dict.sig
+ dict-list.sml

0 comments on commit ce93594

Please sign in to comment.
Something went wrong with that request. Please try again.