From 7162bfed5778699e3365c13f3fbe93fe03efbb72 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sat, 16 Mar 2013 13:53:58 -0700
Subject: [PATCH] math.hashcodes: consistent number hashing.
---
extra/math/hashcodes/hashcodes-tests.factor | 16 +++++++
extra/math/hashcodes/hashcodes.factor | 50 +++++++++++++++++++++
2 files changed, 66 insertions(+)
create mode 100644 extra/math/hashcodes/hashcodes-tests.factor
create mode 100644 extra/math/hashcodes/hashcodes.factor
diff --git a/extra/math/hashcodes/hashcodes-tests.factor b/extra/math/hashcodes/hashcodes-tests.factor
new file mode 100644
index 0000000000..dee079617e
--- /dev/null
+++ b/extra/math/hashcodes/hashcodes-tests.factor
@@ -0,0 +1,16 @@
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel sequences tools.test ;
+
+IN: math.hashcodes
+
+{ t } [
+ { 12 12.0 C{ 12 0 } }
+ [ number-hashcode 12 = ] all?
+] unit-test
+
+{ t } [
+ { 1.5 3/2 C{ 1.5 0 } C{ 3/2 0 } }
+ [ number-hashcode 3458764513820540928 = ] all?
+] unit-test
diff --git a/extra/math/hashcodes/hashcodes.factor b/extra/math/hashcodes/hashcodes.factor
new file mode 100644
index 0000000000..42abe8cf85
--- /dev/null
+++ b/extra/math/hashcodes/hashcodes.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: combinators kernel layouts math math.bitwise
+math.floating-point math.functions ;
+
+IN: math.hashcodes
+
+GENERIC: number-hashcode ( x -- h )
+
+<PRIVATE
+
+: P ( -- x )
+ cell-bits 64 = 61 31 ? 2^ 1 - ; inline foldable
+
+: M ( -- x )
+ cell-bits 1 - 2^ ; inline foldable
+
+: hash-fraction ( m n -- h )
+
+ [ 2dup [ P mod zero? ] bi@ and ] [
+ [ P /i ] bi@
+ ] while
+
+ dup P mod zero? [
+ 2drop 1/0.
+ ] [
+ over [
+ [ abs P mod ] [ P 2 - P ^mod P mod ] bi* *
+ ] dip 0 < [ neg ] when
+ dup -1 = [ drop -2 ] when
+ ] if ; inline
+
+PRIVATE>
+
+M: integer number-hashcode 1 hash-fraction ;
+
+M: ratio number-hashcode >fraction hash-fraction ;
+
+M: float number-hashcode ( x -- h )
+ {
+ { [ dup fp-nan? ] [ drop 0 ] }
+ { [ dup fp-infinity? ] [ 0 > 314159 -314159 ? ] }
+ [ double>ratio number-hashcode ]
+ } cond ;
+
+M: complex number-hashcode ( x -- h )
+ >rect [ number-hashcode ] bi@ 1000003 * +
+ [ M 1 - bitand ] [ M bitand ] bi -
+ dup -1 = [ drop -2 ] when ;