math.hashcodes: consistent number hashing.

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

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 ;