From 66652c490389a6fcb59e22879df91991b19d2a4b Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 2 Apr 2019 17:31:41 -0700
Subject: [PATCH] geohash: adding first version of Geohash geocoding vocab.

---
 extra/geohash/authors.txt          |  1 +
 extra/geohash/geohash-tests.factor | 10 +++++
 extra/geohash/geohash.factor       | 60 ++++++++++++++++++++++++++++++
 extra/geohash/summary.txt          |  1 +
 4 files changed, 72 insertions(+)
 create mode 100644 extra/geohash/authors.txt
 create mode 100644 extra/geohash/geohash-tests.factor
 create mode 100644 extra/geohash/geohash.factor
 create mode 100644 extra/geohash/summary.txt

diff --git a/extra/geohash/authors.txt b/extra/geohash/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /dev/null
+++ b/extra/geohash/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/extra/geohash/geohash-tests.factor b/extra/geohash/geohash-tests.factor
new file mode 100644
index 0000000000..ef177f9de4
--- /dev/null
+++ b/extra/geohash/geohash-tests.factor
@@ -0,0 +1,10 @@
+
+USING: geohash tools.test ;
+
+{ "tuvz4p141zc1" } [ 27.988056 86.925278 >geohash ] unit-test
+
+{ 27.9880559630692 86.92527785897255 } [ "tuvz4p141zc1" geohash> ] unit-test
+
+{ "u4pruydqqvj8" } [ 57.64911 10.40744 >geohash ] unit-test
+
+{ 57.48046875 10.1953125 } [ "u4pr" geohash> ] unit-test
diff --git a/extra/geohash/geohash.factor b/extra/geohash/geohash.factor
new file mode 100644
index 0000000000..993e62e9c5
--- /dev/null
+++ b/extra/geohash/geohash.factor
@@ -0,0 +1,60 @@
+! Copyright (C) 2019 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: byte-arrays fry kernel literals math math.bitwise
+sequences ;
+
+IN: geohash
+
+<PRIVATE
+
+: quantize ( lat lon -- lat' lon' )
+    [ 90.0 + 180.0 / ] [ 180.0 + 360.0 / ] bi*
+    [ 32 2^ * >integer 32 bits ] bi@ ;
+
+: spread-bits ( m -- n )
+    dup 16 shift bitor 0x0000ffff0000ffff bitand
+    dup 8 shift bitor 0x00ff00ff00ff00ff bitand
+    dup 4 shift bitor 0x0f0f0f0f0f0f0f0f bitand
+    dup 2 shift bitor 0x3333333333333333 bitand
+    dup 1 shift bitor 0x5555555555555555 bitand ;
+
+: interleave-bits ( x y -- z )
+    [ spread-bits ] bi@ 1 shift bitor ;
+
+: dequantize ( lat lon -- lat' lon' )
+    [ 32 2^ /f ] bi@ [ 180.0 * 90 - ] [ 360.0 * 180.0 - ] bi* ;
+
+: squash-bits ( m -- n )
+    0x5555555555555555 bitand
+    dup -1 shift bitor 0x3333333333333333 bitand
+    dup -2 shift bitor 0x0f0f0f0f0f0f0f0f bitand
+    dup -4 shift bitor 0x00ff00ff00ff00ff bitand
+    dup -8 shift bitor 0x0000ffff0000ffff bitand
+    dup -16 shift bitor 0x00000000ffffffff bitand ;
+
+: deinterleave-bits ( z -- x y )
+    dup -1 shift [ squash-bits ] bi@ ;
+
+<<
+CONSTANT: base32-alphabet $[ "0123456789bcdefghjkmnpqrstuvwxyz" >byte-array ]
+>>
+CONSTANT: base32-inverse $[ 256 [ base32-alphabet index 0xff or ] B{ } map-integers ]
+
+: base32-encode ( x -- str )
+    -59 12 [
+        dupd [ shift 5 bits base32-alphabet nth ] keep 5 + swap
+    ] "" replicate-as 2nip ;
+
+: base32-decode ( str -- x )
+    [ 0 59 ] dip [
+        base32-inverse nth swap [ shift bitor ] keep 5 -
+    ] each drop ;
+
+PRIVATE>
+
+: >geohash ( lat lon -- geohash )
+    quantize interleave-bits base32-encode ;
+
+: geohash> ( geohash -- lat lon )
+    base32-decode deinterleave-bits dequantize ;
diff --git a/extra/geohash/summary.txt b/extra/geohash/summary.txt
new file mode 100644
index 0000000000..e6fde5ca6b
--- /dev/null
+++ b/extra/geohash/summary.txt
@@ -0,0 +1 @@
+Geohash geocoding system.