1 ! Copyright (C) 2019 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: byte-arrays fry kernel literals math math.bitwise
11 : quantize ( lat lon -- lat' lon' )
12 [ 90.0 + 180.0 / ] [ 180.0 + 360.0 / ] bi*
13 [ 32 2^ * >integer 32 bits ] bi@ ;
15 : spread-bits ( m -- n )
16 dup 16 shift bitor 0x0000ffff0000ffff bitand
17 dup 8 shift bitor 0x00ff00ff00ff00ff bitand
18 dup 4 shift bitor 0x0f0f0f0f0f0f0f0f bitand
19 dup 2 shift bitor 0x3333333333333333 bitand
20 dup 1 shift bitor 0x5555555555555555 bitand ;
22 : interleave-bits ( x y -- z )
23 [ spread-bits ] bi@ 1 shift bitor ;
25 : dequantize ( lat lon -- lat' lon' )
26 [ 32 2^ /f ] bi@ [ 180.0 * 90 - ] [ 360.0 * 180.0 - ] bi* ;
28 : squash-bits ( m -- n )
29 0x5555555555555555 bitand
30 dup -1 shift bitor 0x3333333333333333 bitand
31 dup -2 shift bitor 0x0f0f0f0f0f0f0f0f bitand
32 dup -4 shift bitor 0x00ff00ff00ff00ff bitand
33 dup -8 shift bitor 0x0000ffff0000ffff bitand
34 dup -16 shift bitor 0x00000000ffffffff bitand ;
36 : deinterleave-bits ( z -- x y )
37 dup -1 shift [ squash-bits ] bi@ ;
40 CONSTANT: base32-alphabet $[ "0123456789bcdefghjkmnpqrstuvwxyz" >byte-array ]
42 CONSTANT: base32-inverse $[ 256 [ base32-alphabet index 0xff or ] B{ } map-integers-as ]
44 : base32-encode ( x -- str )
46 dupd [ shift 5 bits base32-alphabet nth ] keep 5 + swap
47 ] "" replicate-as 2nip ;
49 : base32-decode ( str -- x )
51 base32-inverse nth swap [ shift bitor ] keep 5 -
56 : >geohash ( lat lon -- geohash )
57 quantize interleave-bits base32-encode ;
59 : geohash> ( geohash -- lat lon )
60 base32-decode deinterleave-bits dequantize ;