[MLton-commit] r5631
Vesa Karvonen
vesak at mlton.org
Sat Jun 16 07:51:37 PDT 2007
An ugly implementation of a generic hash function.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-06-16 11:19:19 UTC (rev 5630)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-06-16 14:51:36 UTC (rev 5631)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(* XXX UNFINISHED! NOTE THE USES OF `undefined` BELOW. *)
+(* XXX Devise a better hash function. This is not pretty. *)
functor WithHash (Arg : WITH_HASH_DOM) : HASH_GENERIC = struct
(* <-- SML/NJ workaround *)
@@ -22,11 +22,17 @@
structure W = Word
- fun mac word hash =
- hash * 0w19 + word
+ type 'a t = 'a -> {maxWidth : Int.t, maxDepth : Int.t} -> Word.t UnOp.t
- datatype 'a t =
- IN of 'a -> {maxWidth : Int.t, maxDepth : Int.t} -> Word.t UnOp.t
+ structure HC : sig
+ val map : ('b -> 'a) -> 'a t -> 'b t
+ val withConst : Word.t -> 'a t UnOp.t
+ val lift : ('a -> Word.t) -> 'a t
+ end = struct
+ fun map b2a hA = hA o b2a
+ fun withConst w hA a p r = hA a p (W.+ (w, r))
+ fun lift toWord a _ r = r * 0w19 + toWord a
+ end
structure Rep =
JoinGenericReps
@@ -37,10 +43,9 @@
structure Hash = Rep
fun hash t v =
- case Pair.fst (Arg.Rep.getT t) of
- IN h => h v {maxWidth = 200, maxDepth = 10} 0wx2CA4B13
+ Pair.fst (Arg.Rep.getT t) v {maxWidth = 200, maxDepth = 10} 0wx2CA4B13
- fun iso' (IN bH) (a2b, _) = IN (bH o a2b)
+ fun iso' bH (a2b, _) = bH o a2b
fun morph outer f = outer (fn (a, x) => fn i => (iso' a i, f x i))
fun nullary outer t x = outer (t, x)
@@ -53,58 +58,81 @@
fun op *` xy2z (aT, bT) =
bop Arg.*`
- (fn (IN aH, IN bH) =>
- IN (fn a & b => fn {maxWidth, maxDepth} => let
- val aN = Arg.numElems aT
- val bN = Arg.numElems bT
- val aW = Int.quot (maxWidth * aN, aN + bN)
- val bW = maxWidth - aW
- in
- bH b {maxWidth = bW, maxDepth = maxDepth} o
- aH a {maxWidth = aW, maxDepth = maxDepth}
- end))
+ (fn (aH, bH) =>
+ fn a & b => fn {maxWidth, maxDepth} => let
+ val aN = Arg.numElems aT
+ val bN = Arg.numElems bT
+ val aW = Int.quot (maxWidth * aN, aN + bN)
+ val bW = maxWidth - aW
+ in
+ bH b {maxWidth = bW, maxDepth = maxDepth} o
+ aH a {maxWidth = aW, maxDepth = maxDepth}
+ end)
xy2z (aT, bT)
fun op +` ? =
bop Arg.+`
- (fn (IN aH, IN bH) =>
- IN (Sum.sum (aH, bH))) ?
+ (Sum.sum o
+ Pair.map (HC.withConst 0wx96BA232,
+ HC.withConst 0wxCF2465)) ?
- fun Y y = Arg.Y (let open Tie in iso (function *` y) end
- (fn (IN a, b) => a & b,
- fn a & b => (IN a, b)))
+ fun Y y = Arg.Y (Tie.tuple2 (Tie.function, y))
- fun op --> ? = bop Arg.--> (fn _ => IN (failing "Hash.--> unsupported")) ?
+ fun op --> ? = bop Arg.--> (fn _ => failing "Hash.--> unsupported") ?
- fun exn ? = let
- val e = Fail "Hash.exn unsupported"
- in
- nullary Arg.exn (IN (raising e))
- end ?
+ fun exn ? = nullary Arg.exn (failing "Hash.exn unsupported") ?
fun regExn ef = Arg.regExn (ef o Pair.snd)
- fun refc ? =
- uop Arg.refc
- (fn IN aH => IN (fn a => fn p => mac 0w87 o aH (!a) p)) ?
+ fun refc ? = uop Arg.refc (HC.withConst 0wx178A2346 o HC.map !) ?
- fun list ? = uop Arg.list (fn _ => IN undefined) ?
+ fun list ? =
+ uop Arg.list
+ (fn hX => fn xs => fn {maxWidth, maxDepth} => fn h => let
+ val m = Int.quot (maxWidth, 2)
+ fun len n [] = n
+ | len n (_::xs) = if m <= n then n else len (n+1) xs
+ val n = len 0 xs
+ val p = {maxWidth = Int.quot (maxWidth, n),
+ maxDepth = maxDepth - 1}
+ fun lp h _ [] = h
+ | lp h n (x::xs) = if n = 0 then h else lp (hX x p h) (n-1) xs
+ in
+ lp h n xs
+ end) ?
- fun array ? = uop Arg.array (fn _ => IN undefined) ?
- fun vector ? = uop Arg.vector (fn _ => IN undefined) ?
+ fun hashSeq length sub hashElem s {maxWidth, maxDepth} h = let
+ val n = length s
+ in
+ case Int.min (Int.quot (maxWidth+3, 4), Int.quot (n+1, 2)) of
+ 0 => h
+ | numSamples => let
+ val p = {maxWidth = Int.quot (maxWidth, numSamples),
+ maxDepth = maxDepth - 1}
+ fun lp h 0 = h
+ | lp h n = lp (hashElem (sub (s, n-1)) p h) (n-1)
+ in
+ lp h (Int.max (numSamples, Int.min (10, n)))
+ end
+ end
- fun string ? = nullary Arg.string (IN undefined) ?
+ fun array ? = uop Arg.array (hashSeq Array.length Array.sub) ?
+ fun vector ? = uop Arg.vector (hashSeq Vector.length Vector.sub) ?
- val unit' = IN (fn () => fn _ => mac 0w75)
+ val char' = HC.lift (Word.fromInt o ord)
+ fun char ? = nullary Arg.char char' ?
+
+ val string' = hashSeq String.length String.sub char'
+ fun string ? = nullary Arg.string string' ?
+
+ val unit' = HC.lift (Thunk.mk 0wx2F785)
fun unit ? = nullary Arg.unit unit' ?
local
- fun mk outer toWord ? =
- nullary outer (IN (fn x => fn _ => mac (toWord x))) ?
+ fun mk outer toWord ? = nullary outer (HC.lift toWord) ?
in
fun largeInt ? =
mk Arg.largeInt
(W.fromLargeInt o LargeInt.rem /> W.toLargeInt W.maxValue) ?
- fun largeReal ? = mk Arg.largeReal undefined ?
fun largeWord ? =
mk Arg.largeWord
(W.fromLarge o LargeWord.mod /> W.toLarge W.maxValue) ?
@@ -114,20 +142,22 @@
fun word32 ? = mk Arg.word32 (Word.fromLarge o Word32.toLarge) ?
fun word64 ? = mk Arg.word64 (Word.fromLarge o Word64.toLarge) ?
fun bool ? = mk Arg.bool (fn true => 0wx2DA745 | false => 0wx3C24A62) ?
- fun char ? = mk Arg.char (Word.fromInt o ord) ?
fun int ? = mk Arg.int Word.fromInt ?
- fun real ? = mk Arg.real undefined ?
fun word ? = mk Arg.word id ?
end
+ (* XXX SML/NJ does not provide a function to convert a real to bits *)
+ fun largeReal ? = nullary Arg.largeReal (HC.map LargeReal.toString string') ?
+ fun real ? = nullary Arg.real (HC.map Real.toString string') ?
+
(* Trivialities *)
fun T ? = uop Arg.T id ?
fun R f = Arg.R (fn l => Pair.map (id, f l))
local
- fun width (IN h) =
- IN (fn a => fn p => if #maxWidth p = 0 then id else h a p)
+ fun width h : 'a t =
+ fn a => fn p => if #maxWidth p = 0 then id else h a p
in
fun tuple ? = uop Arg.tuple width ?
fun record ? = uop Arg.record width ?
@@ -137,8 +167,8 @@
fun C1 f = Arg.C1 (fn l => Pair.map (id, f l))
fun data ? =
uop Arg.data
- (fn IN h => IN (fn a => fn {maxDepth, maxWidth} =>
+ (fn h => fn a => fn {maxDepth, maxWidth} =>
if maxDepth = 0 then id
- else h a {maxDepth = maxDepth-1,
- maxWidth = Int.quot (maxWidth, 2)})) ?
+ else h a {maxDepth = maxDepth - 1,
+ maxWidth = Int.quot (maxWidth, 2)}) ?
end
More information about the MLton-commit
mailing list