extra/geohash/geohash.factor

   1 ! Copyright (C) 2019 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: byte-arrays fry kernel literals math math.bitwise
   5 sequences ;
   6
   7 IN: geohash
   8
   9 <PRIVATE
  10
  11 : quantize ( lat lon -- lat' lon' )
  12     [ 90.0 + 180.0 / ] [ 180.0 + 360.0 / ] bi*
  13     [ 32 2^ * >integer 32 bits ] bi@ ;
  14
  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 ;
  21
  22 : interleave-bits ( x y -- z )
  23     [ spread-bits ] bi@ 1 shift bitor ;
  24
  25 : dequantize ( lat lon -- lat' lon' )
  26     [ 32 2^ /f ] bi@ [ 180.0 * 90 - ] [ 360.0 * 180.0 - ] bi* ;
  27
  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 ;
  35
  36 : deinterleave-bits ( z -- x y )
  37     dup -1 shift [ squash-bits ] bi@ ;
  38
  39 <<
  40 CONSTANT: base32-alphabet $[ "0123456789bcdefghjkmnpqrstuvwxyz" >byte-array ]
  41 >>
  42 CONSTANT: base32-inverse $[ 256 [ base32-alphabet index 0xff or ] B{ } map-integers-as ]
  43
  44 : base32-encode ( x -- str )
  45     -59 12 [
  46         dupd [ shift 5 bits base32-alphabet nth ] keep 5 + swap
  47     ] "" replicate-as 2nip ;
  48
  49 : base32-decode ( str -- x )
  50     [ 0 59 ] dip [
  51         base32-inverse nth swap [ shift bitor ] keep 5 -
  52     ] each drop ;
  53
  54 PRIVATE>
  55
  56 : >geohash ( lat lon -- geohash )
  57     quantize interleave-bits base32-encode ;
  58
  59 : geohash> ( geohash -- lat lon )
  60     base32-decode deinterleave-bits dequantize ;