[MLton-commit] r6296

[Vesa Karvonen]

A simple generic memoization example.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/generic/unstable/example/
A   mltonlib/trunk/com/ssh/generic/unstable/example/memoize.mlb
A   mltonlib/trunk/com/ssh/generic/unstable/example/memoize.ok
A   mltonlib/trunk/com/ssh/generic/unstable/example/memoize.sml

----------------------------------------------------------------------

Added: mltonlib/trunk/com/ssh/generic/unstable/example/memoize.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/example/memoize.mlb	2008-01-02 14:25:10 UTC (rev 6295)
+++ mltonlib/trunk/com/ssh/generic/unstable/example/memoize.mlb	2008-01-02 18:09:32 UTC (rev 6296)
@@ -0,0 +1,29 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+   (* Libraries *)
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   $(MLTON_LIB)/org/mlton/vesak/ds/unstable/lib.mlb
+   $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+
+   (* Composition of generics *)
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/generic.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/eq.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/type-hash.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/type-info.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/hash.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/pretty.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
+
+   ann
+      "sequenceNonUnit warn"
+      "warnUnused true"
+   in
+      memoize.sml
+   end
+in
+end


Property changes on: mltonlib/trunk/com/ssh/generic/unstable/example/memoize.mlb
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/com/ssh/generic/unstable/example/memoize.ok
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/example/memoize.ok	2008-01-02 14:25:10 UTC (rev 6295)
+++ mltonlib/trunk/com/ssh/generic/unstable/example/memoize.ok	2008-01-02 18:09:32 UTC (rev 6296)
@@ -0,0 +1,5 @@
+concatV #["a", "bcd"] = "abcd"
+(memo) concatV #["a", "bcd"] = "abcd"
+concatV #["Ab", "C", "d"] = "AbCd"
+(memo) concatV #["Ab", "C", "d"] = "AbCd"
+(memo) concatV #["a", "bcd"] = "abcd"

Added: mltonlib/trunk/com/ssh/generic/unstable/example/memoize.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/example/memoize.sml	2008-01-02 14:25:10 UTC (rev 6295)
+++ mltonlib/trunk/com/ssh/generic/unstable/example/memoize.sml	2008-01-02 18:09:32 UTC (rev 6296)
@@ -0,0 +1,63 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * This example shows a simple way to implement memoization using the
+ * generics library.
+ *
+ * The {memo} function is given a type representation for the type of the
+ * domain of a function to memoize and a function.  It then returns a
+ * memoized function.  The memoized function uses a hash table to map
+ * values of the domain to values of the codomain.
+ *
+ * The {loud} function is given the type representations of both the
+ * domain and codomain of a function (and a name and a function) and it
+ * then returns a function that prints calls to the function.  This is
+ * used to show that the memo function works.
+ *
+ * The {test} function is similar.  It fails with a pretty printed
+ * function call with the actual and expected results in case the actual
+ * and expected results disagree.
+ *)
+
+open Generic
+
+fun memo dom f =
+    case HashMap.new {eq = eq dom, hash = hash dom}
+     of x2y =>
+        fn x =>
+           case HashMap.find x2y x
+            of SOME y => y
+             | NONE => case f x of y => (HashMap.insert x2y (x, y) ; y)
+
+fun loud dom cod name f x =
+    try (fn () => f x,
+         fn y => (printlns [name, " ", show dom x, " = ", show cod y]
+                ; y),
+         fn e => (printlns [name, " ", show dom x, " = raise ", show exn e]
+                ; raise e))
+
+fun test dom cod name f x y =
+    case f x
+     of y' => if eq cod (y', y) then ()
+              else fails [name, " ", show dom x, " = ", show cod y',
+                          ", expected ", show cod y]
+
+val concatV = concat o Vector.toList
+
+val concatV = let
+   val dom = vector string
+   val cod = string
+in
+   loud dom cod "(memo) concatV" |< memo dom |< loud dom cod "concatV" concatV
+end
+
+val testConcatV = test (vector string) string "concatV" concatV
+
+val () =
+    (testConcatV (Vector.fromList ["a", "bcd"])     "abcd"
+   ; testConcatV (Vector.fromList ["Ab", "C", "d"]) "AbCd"
+   ; testConcatV (Vector.fromList ["a", "bcd"])     "abcd")


Property changes on: mltonlib/trunk/com/ssh/generic/unstable/example/memoize.sml
___________________________________________________________________
Name: svn:eol-style
   + native