Initial version

.gitignore

@@ -0,0 +1,2 @@
+*.fasl
+

fileformat.lisp

@@ -0,0 +1,34 @@
+(cl:eval-when (:execute :compile-toplevel :load-toplevel)
+  (cl:unless (cl:find-package "OSMPBF")
+    (cl:defpackage OSMPBF (:use))))
+(cl:in-package "OSMPBF")
+(cl:export '(BLOB
+             RAW
+             RAW-SIZE
+             ZLIB-DATA
+             LZMA-DATA
+             OBSOLETE-BZIP2-DATA
+             BLOB-HEADER
+             TYPE
+             INDEXDATA
+             DATASIZE))
+
+(proto:define-schema fileformat
+    (:package "OSMPBF"
+     :lisp-package "OSMPBF"
+     :options (:java_package "crosby.binary"))
+  (proto:define-message blob
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/fileformat.proto" 923 927))
+    ((raw 1) :type (common-lisp:or common-lisp:null protobufs:byte-vector))
+    ((raw-size 2) :type (common-lisp:or common-lisp:null protobufs:int32))
+    ((zlib-data 3) :type (common-lisp:or common-lisp:null protobufs:byte-vector))
+    ((lzma-data 4) :type (common-lisp:or common-lisp:null protobufs:byte-vector))
+    ((obsolete-bzip2-data 5) :type (common-lisp:or common-lisp:null
+                                                   protobufs:byte-vector) :options (:deprecated TRUE)))
+  (proto:define-message blob-header
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/fileformat.proto" 1606 1616))
+    ((type 1) :type common-lisp:string)
+    ((indexdata 2) :type (common-lisp:or common-lisp:null protobufs:byte-vector))
+    ((datasize 3) :type protobufs:int32)))

fileformat.proto

@@ -0,0 +1,54 @@
+/** Copyright (c) 2010 Scott A. Crosby. <scott@sacrosby.com>
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU Lesser General Public License as 
+   published by the Free Software Foundation, either version 3 of the 
+   License, or (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+*/
+
+option optimize_for = LITE_RUNTIME;
+option java_package = "crosby.binary";
+package OSMPBF;
+
+//protoc --java_out=../.. fileformat.proto
+
+
+//
+//  STORAGE LAYER: Storing primitives.
+//
+
+message Blob {
+  optional bytes raw = 1; // No compression
+  optional int32 raw_size = 2; // When compressed, the uncompressed size
+
+  // Possible compressed versions of the data.
+  optional bytes zlib_data = 3;
+
+  // PROPOSED feature for LZMA compressed data. SUPPORT IS NOT REQUIRED.
+  optional bytes lzma_data = 4;
+
+  // Formerly used for bzip2 compressed data. Depreciated in 2010.
+  optional bytes OBSOLETE_bzip2_data = 5 [deprecated=true]; // Don't reuse this tag number.
+}
+
+/* A file contains an sequence of fileblock headers, each prefixed by
+their length in network byte order, followed by a data block
+containing the actual data. types staring with a "_" are reserved.
+*/
+
+message BlobHeader {
+  required string type = 1;
+  optional bytes indexdata = 2;
+  required int32 datasize = 3;
+}
+
+

nvg.lisp

@@ -0,0 +1,249 @@
+(cl:defpackage :ocm.nvg
+  (:use :cl :cffi-c-ref :alexandria)
+  (:export run))
+(cl:in-package :ocm.nvg)
+
+(defun aget (alist key)
+  (cdr (assoc key alist :test #'equal)))
+
+(defun agets (alist &rest keys)
+  (reduce #'aget keys :initial-value alist))
+
+(defun agetter (&rest keys)
+  (lambda (alist)
+    (apply 'agets alist keys)))
+
+(defun tags (obj)
+  (let ((tags (ocm.osm::obj-tags obj)))
+    (when (functionp tags)
+      (setf tags (funcall tags)
+            (ocm.osm::obj-tags obj) tags))
+    tags))
+
+(defun merge-tags (obj parent)
+  (append obj parent))
+
+
+(defvar *context* nil "NanoVG Context")
+(defvar *window-width* 640.0)
+(defvar *window-height* 480.0)
+(defvar *frame-width* 640.0)
+(defvar *frame-height* 480.0)
+(defvar *pixel-ratio* 1.0)
+(defvar *scale* 3f0)
+(defvar *pos-x* 0f0)
+(defvar *pos-y* 0f0)
+
+(defparameter +granularity+ (expt 10 8))
+(defun node-x (node)
+  (float (/ (ocm.osm::node-lat node) +granularity+)))
+(defun node-y (node)
+  (float (/ (ocm.osm::node-lon node) +granularity+)))
+
+(defun render-path (nodes)
+  (%nvg:begin-path *context*)
+  (let ((start (car nodes)))
+    (%nvg:move-to *context* (node-x start) (node-y start))
+    (loop for node in (cdr nodes)
+       do (%nvg:line-to *context* (node-x node) (node-y node)))))
+
+(defparameter +highway-color+ '(250 0 0 255))
+(defparameter +strokes+
+  `(
+    (((:way "highway")) :color ,+highway-color+ :width 10)))
+
+(defun apply-stroke (tags)
+  (when-let (options (find-match +strokes+ tags :way))
+    (destructuring-bind (&key color width) options
+      (when color
+        (c-with ((n-color %nvg:color))
+          (%nvg:stroke-color *context* (apply '%nvg:rgba (n-color &) color))))
+      (when width (%nvg:stroke-width *context* width)))))
+
+
+(defun render-line (nodes tags)
+  (render-path nodes)
+  (apply-stroke tags)
+  (%nvg:stroke *context*))
+
+(defparameter +water-color+ '(0 0 250 255))
+(defparameter +wood-color+ '(0 250 0 255))
+(defparameter +fills+
+  `(
+    (((nil "natural" "water")) :color ,+water-color+)
+    (((nil "natural" "scrub")
+      (nil "natural" "wood")) :color ,+wood-color+)
+    ))
+
+(defun find-match (query-value tags type)
+  (loop for (query . value) in query-value
+     when (ocm.osm::query-match2 query type tags)
+     do (return value)))
+
+(defun apply-fill (tags)
+  (when-let (fill (find-match +fills+ tags :way))
+    (destructuring-bind (&key color paint) fill
+      (when color
+        (c-with ((n-color %nvg:color))
+          (%nvg:fill-color *context* (apply '%nvg:rgba (n-color &) color))))
+      (when paint))))
+
+
+(defun render-poly (nodes tags &optional hole)
+  (render-path nodes)
+  (%nvg:close-path *context*)
+  (when hole
+    (%nvg:path-winding *context* (cffi:foreign-bitfield-value '%nvg:solidity :hole)))
+  (apply-fill tags)
+  (%nvg:fill *context*))
+
+(defparameter +closed-lines+
+  '((:way "highway")))
+
+(defun is-area (nodes tags)
+  (let ((first (first nodes))
+        (last (car (last nodes))))
+    (and first last
+         (= (if (ocm.osm::obj-p first) (ocm.osm::obj-id first) first)
+            (if (ocm.osm::obj-p last) (ocm.osm::obj-id last) last))
+         (not (ocm.osm::query-match2 +closed-lines+ :way tags)))))
+
+(defun render-way (nodes tags)
+  (if (is-area nodes tags)
+      (render-poly nodes tags)
+      (render-path nodes)))
+
+(defun render-multipoly (rel)
+  (loop for mem in (ocm.osm::rel-memids rel)
+     for mem-role in (ocm.osm::rel-roles rel)
+     for mem-type in (ocm.osm::rel-types rel)
+     when (ocm.osm::way-p mem) ;; skip non-ways
+     do (render-poly (ocm.osm::way-refs mem)
+                     (merge-tags (tags mem) (tags rel))
+                     (equal "inner" mem-role))))
+
+(defun render-objects (objects)
+  (loop for obj in objects
+     do (typecase obj
+          (ocm.osm::way
+           (render-way (ocm.osm::way-refs obj) (tags obj)))
+          (ocm.osm::rel
+           (when (equal (aget (tags obj) "type")
+                        "multipolygon")
+             (render-multipoly obj))))))
+
+(defun render ()
+  (%nvg:begin-frame *context* *window-width* *window-height* *pixel-ratio*)
+
+  (%nvg:transform *context* *scale* 0f0 0f0 *scale* *pos-x* *pos-y*)
+
+  (render-objects ocm.osm::+water+)
+
+  (%nvg:begin-path *context*)
+  (%nvg:rect *context* 0f0 0f0 120f0 30f0)
+  (c-with ((color %nvg:color))
+    (%nvg:fill-color *context* (%nvg:rgba (color &)
+                                          (round (* 127.5 (+ 1 (sin (* 2 (%glfw:get-time))))))
+                                          192 192 255)))
+  (%nvg:fill *context*)
+
+  (%nvg:end-frame *context*)
+  )
+
+(defparameter +translate-step+ 10f0)
+(defparameter +scale-step+ 0.1)
+(glfw:define-key-callback on-keys (window key scancode action mod-keys)
+  (declare (ignorable window key scancode action mod-keys))
+  (format t "KEY: ~{~A ~}~%" (list key scancode action mod-keys))
+  (when (eql action %glfw:+press+)
+    (cond
+      ((or
+        (eql key %glfw:+key-escape+)
+        (eql key %glfw:+key-q+))
+       (%glfw:set-window-should-close window %glfw:+true+))
+      ((eql key %glfw:+key-left+) (decf *pos-x* +translate-step+))
+      ((eql key %glfw:+key-right+) (incf *pos-x* +translate-step+))
+      ((eql key %glfw:+key-up+) (decf *pos-y* +translate-step+))
+      ((eql key %glfw:+key-down+) (incf *pos-y* +translate-step+))
+      ((eql key %glfw:+key-minus+) (decf *scale* +scale-step+))
+      ((eql key %glfw:+key-equal+) (incf *scale* +scale-step+))))
+  (print (list *scale* *pos-x* *pos-y*)))
+
+(glfw:define-framebuffer-size-callback on-fb-size (window width height)
+  (declare (ignorable window))
+  (setf *frame-width* (float width)
+        *frame-height* (float height)
+        *pixel-ratio* (/ *frame-width* *window-width*)))
+
+(glfw:define-window-size-callback on-win-size (window width height)
+  (declare (ignorable window))
+  (setf *window-width* (float width)
+        *window-height* (float height)
+        *pixel-ratio* (/ *frame-width* *window-width*)))
+
+(Defun create-window ()
+  (if (uiop:featurep :bodge-gl2)
+      (glfw:with-window-hints ((%glfw:+context-version-major+ 2)
+                               (%glfw:+context-version-minor+ 1)
+                               (%glfw:+depth-bits+ 24)
+                               (%glfw:+stencil-bits+ 8))
+        (%glfw:create-window 640 480 "Hello NanoVG 2" nil nil))
+      (glfw:with-window-hints ((%glfw:+context-version-major+ 3)
+                               (%glfw:+context-version-minor+ 3)
+                               (%glfw:+opengl-profile+ %glfw:+opengl-core-profile+)
+                               (%glfw:+opengl-forward-compat+ %glfw:+true+)
+                               (%glfw:+depth-bits+ 24)
+                               (%glfw:+stencil-bits+ 8))
+        (%glfw:create-window 640 480 "Hello NanoVG 3" nil nil))))
+
+(defun main ()
+  ;; Initializing window and OpenGL context
+  (glfw:with-init ()
+    (c-let ((window %glfw:window :from (create-window))
+            (width :int :alloc t)
+            (height :int :alloc t))
+      (when (cffi:null-pointer-p (window &))
+        (%glfw:terminate)
+        (error "Failed to create GLFW window"))
+      (%glfw:make-context-current (window &))
+      ;; Mangling GL function pointers
+      (glad:init)
+      ;; Set event callbacks
+      (%glfw:set-key-callback (window &) (cffi:callback on-keys))
+      (%glfw:set-framebuffer-size-callback (window &) (cffi:callback on-fb-size))
+      (%glfw:set-window-size-callback (window &) (cffi:callback on-win-size))
+      ;; Get initial values
+      (%glfw:get-framebuffer-size (window &) (width &) (height &))
+      (setf *frame-width* (float width)
+            *frame-height* (float height))
+      (%glfw:get-window-size (window &) (width &) (height &))
+      (setf *window-width* (float width)
+            *window-height* (float height)
+            *pixel-ratio* (/ *frame-width* *window-width*))
+
+      ;; reset
+      (setf *scale* 1f0
+            *pos-x* 0f0
+            *pos-y* 0f0)
+
+      ;; Creating NanoVG context
+      (let ((*context* (nvg:make-context)))
+        (unwind-protect
+             (loop while (= (%glfw:window-should-close (window &)) 0) do
+                  (gl:clear-color 1f0 1f0 1f0 1f0)
+                  (gl:clear :color-buffer-bit :depth-buffer-bit :stencil-buffer-bit)
+
+                ;; Actually drawing into nanovg context and onto display
+                  (render)
+
+                  (%glfw:swap-buffers (window &))
+                  (%glfw:poll-events))
+          ;; Cleaning up NanoVG context
+          (nvg:destroy-context *context*))))))
+
+(defun run ()
+  (main)
+  ;; (trivial-main-thread:with-body-in-main-thread (:blocking t)
+  ;;   (float-features:with-float-traps-masked t
+  ;;     (main)))
+  )

ocm.asd

@@ -0,0 +1,41 @@
+(asdf:defsystem ocm
+  :version "0.1"
+  :author "Innokenty Enikeev"
+  :license "MIT"
+  :depends-on (:ironclad
+               :alexandria
+               :local-time
+               :log4cl
+               :yason
+               :trivial-utf-8)
+  :serial t
+  :components ((:file "s2"))
+  :description "open chad map")
+
+(asdf:defsystem ocm/osm
+  :version "0.1"
+  :author "Innokenty Enikeev"
+  :license "MIT"
+  :depends-on (:ironclad
+               :alexandria
+               :chipz
+               :cl-protobufs
+               :local-time
+               :trivial-utf-8)
+  :serial t
+  :components ((:file "fileformat")
+               (:file "osmformat")
+               (:file "osm"))
+  :description "open chad map, OpenStreetMap handling")
+
+(asdf:defsystem ocm/nvg
+  :description "NanoVG ocm implementation"
+  :version "0.1"
+  :author "Innokenty Enikeev"
+  :license "MIT"
+  :depends-on (:alexandria
+               :glfw-blob :bodge-glfw :glad-blob :bodge-glad :nanovg-blob :bodge-nanovg
+               :cl-opengl :claw :cffi :cffi-c-ref :trivial-main-thread
+               :float-features)
+  :serial t
+  :components ((:file "nvg")))

osm.lisp

@@ -0,0 +1,487 @@
+b(in-package :cl-user)
+(defpackage #:ocm.osm
+  (:use :cl :alexandria))
+(in-package :ocm.osm)
+
+(defun next-power-of-two (number)
+  (ash 1 (ceiling (log number 2))))
+
+(defvar *read-buffer* (proto:make-byte-vector 4096))
+(defun ensure-buffer (size)
+  (when (> size (array-total-size *read-buffer*))
+    (setf *read-buffer* (proto:make-byte-vector (next-power-of-two size)))))
+
+(defmacro read-big-endian (stream &optional (sizeof 4))
+  (with-gensyms (i unsigned-value)
+    `(let ((,unsigned-value 0))
+       (dotimes (,i ,sizeof ,unsigned-value)
+         (setf ,unsigned-value (+ (* ,unsigned-value #x100)
+                                  (read-byte ,stream)))))))
+
+(defmacro read-little-endian (stream &optional (sizeof 4))
+  (with-gensyms (i unsigned-value)
+    `(let ((,unsigned-value 0))
+       (dotimes (,i ,sizeof ,unsigned-value)
+         (setf ,unsigned-value (+ ,unsigned-value
+                                  (ash (read-byte ,stream )
+                                       (* 8 ,i))))))))
+
+(defvar *stream* nil "PBF file stream")
+(defvar *blob-header-size*  nil "Current header size during file parsing")
+(defvar *blob-header* nil "Current header")
+(defvar *blob-size*  nil "Current blob size during file parsing")
+(defvar *blob-type*  nil "Current blob type")
+(defvar *blob* nil "Current blob")
+(defvar *block-size* nil "Current block size")
+(defvar *header-block* nil "File header block")
+(defvar *primitive-block* nil "Current primitive block")
+(defparameter +blob-type-osm-header+ "OSMHeader")
+(defparameter +blob-type-osm-data+ "OSMData")
+
+(defun read-proto (type size &optional no-read)
+  (unless no-read
+    (ensure-buffer size)
+    (read-sequence *read-buffer* *stream* :end size))
+  (proto:deserialize-object type *read-buffer* 0 size))
+
+(defmacro iterate-osm ((filespec) &body body)
+  `(with-open-file (*stream* ,filespec :element-type 'unsigned-byte)
+     (handler-case
+         (loop
+            (let* ((*blob-header* (read-proto 'osmpbf:blob-header (read-big-endian *stream* 4)))
+                   (*blob-type* (osmpbf:type *blob-header*))
+                   (*blob-size* (osmpbf:datasize *blob-header*)))
+              (if (or (equal *blob-type* +blob-type-osm-data+)
+                      (equal *blob-type* +blob-type-osm-header+))
+                  (let* ((*blob* (read-proto 'osmpbf:blob *blob-size*))
+                         (*block-size* (unpack-block *blob*)))
+                    (if (equal *blob-type* +blob-type-osm-header+)
+                        (ensure-features (read-proto 'osmpbf:header-block *block-size* t))
+                        (let ((*primitive-block* (read-proto 'osmpbf:primitive-block *block-size* t)))
+                          ,@body)))
+                  (file-position *stream* (+ (file-position *stream*) *blob-size*)))))
+       (end-of-file (e)
+         (declare (ignore e))))))
+
+(defun degran-lat (lat block)
+  (+ (osmpbf:lat-offset block)
+     (* lat (osmpbf:granularity block))))
+(defun degran-lon (lon block)
+  (+ (osmpbf:lon-offset block)
+     (* lon (osmpbf:granularity block))))
+
+(defun sid (indexes string-table)
+  (loop for i in indexes
+     collect (trivial-utf-8:utf-8-bytes-to-string (elt string-table i))))
+
+(defmacro string-table (block)
+  `(osmpbf:s (osmpbf:stringtable ,block)))
+
+(defmacro unsid (object accessor block)
+  `(setf (,accessor ,object)
+         (sid (,accessor ,object)
+              (string-table ,block))))
+
+(defun unsid2 (sids string-table)
+  (loop for i from 0
+     for sid in sids
+     do (setf (elt sids i)
+              (trivial-utf-8:utf-8-bytes-to-string (elt string-table sid)))))
+
+(defmacro iterate-nodes ((node block) &body body)
+  (with-gensyms (group info)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        do (loop for ,node in (osmpbf:nodes ,group)
+              do (progn
+                   (unsid ,node osmpbf:keys ,block)
+                   (unsid ,node osmpbf:vals ,block)
+                   (when-let (,info (osmpbf:info )))
+                   (setf (osmpbf:lat ,node) (degran-lat (osmpbf:lat ,node) ,block)
+                         (osmpbf:lon ,node) (degran-lon (osmpbf:lon ,node) ,block))
+                   ,@body)))))
+
+(defmacro iterate-dense-nodes ((node block) &body body)
+  (with-gensyms (group string-table dense dense-info id lat lon tag-start tag-end info ith key val)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        with ,string-table = (osmpbf:s (osmpbf:stringtable ,block))
+        do (when-let (,dense (osmpbf:dense ,group))
+             (undelta (osmpbf:id ,dense))
+             (undelta (osmpbf:lat ,dense))
+             (undelta (osmpbf:lon ,dense))
+             (when-let (,dense-info (osmpbf:denseinfo ,dense))
+               (undelta (osmpbf:timestamp ,dense-info))
+               (undelta (osmpbf:changeset ,dense-info))
+               (undelta (osmpbf:uid ,dense-info))
+               (undelta (osmpbf:user-sid ,dense-info)))
+             (loop
+                for ,id in (osmpbf:id ,dense)
+                for ,lat in (osmpbf:lat ,dense)
+                for ,lon in (osmpbf:lon ,dense)
+                for ,tag-start = 0 then ,tag-end
+                for ,tag-end = (position 0 (osmpbf:keys-vals ,dense) :start ,tag-start)
+                for ,ith from 0
+                do (let* ((,info (when-let (,dense-info (osmpbf:denseinfo ,dense))
+                                   (make-instance 'osmpbf:info
+                                                  :version (elt (osmpbf:version ,dense-info) ,ith)
+                                                  :timestamp (elt (osmpbf:timestamp ,dense-info) ,ith)
+                                                  :changeset (elt (osmpbf:changeset ,dense-info) ,ith)
+                                                  :uid (elt (osmpbf:uid ,dense-info) ,ith)
+                                                  :user-sid (car (sid (list (elt (osmpbf:user-sid ,dense-info) ,ith))
+                                                                      ,string-table)))))
+                          (,node (make-instance 'osmpbf:node
+                                                :id ,id
+                                                :keys (sid (loop for ,key
+                                                              in (subseq (osmpbf:keys-vals ,dense)
+                                                                         ,tag-start ,tag-end)
+                                                              by #'cddr
+                                                              collect ,key)
+                                                           ,string-table)
+                                                :vals (sid (loop for ,val
+                                                              in (subseq (osmpbf:keys-vals ,dense)
+                                                                         (1+ ,tag-start) ,tag-end)
+                                                              by #'cddr
+                                                              collect ,val)
+                                                           ,string-table)
+                                                :lat (degran-lat ,lat ,block)
+                                                :lon (degran-lon ,lon ,block)
+                                                :info ,info)))
+                     ,@body))))))
+
+(defmacro iterate-dense ((id lat lon keys vals block) &body body)
+  (with-gensyms (group string-table dense tag-start tag-end key val id-cur lat-cur lon-cur id-prev lat-prev lon-prev lat-acc lon-acc)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        with ,string-table = (string-table ,block)
+        do (when-let (,dense (osmpbf:dense ,group))
+             (loop
+                for ,id-cur in (osmpbf:id ,dense)
+                for ,lat-cur in (osmpbf:lat ,dense)
+                for ,lon-cur in (osmpbf:lon ,dense)
+                for ,id-prev = 0 then ,id
+                for ,lat-prev = 0 then ,lat-acc
+                for ,lon-prev = 0 then ,lon-acc
+                for ,tag-start = 0 then ,tag-end
+                for ,tag-end = (position 0 (osmpbf:keys-vals ,dense) :start ,tag-start)
+                for ,id = (+ ,id-cur ,id-prev)
+                for ,lat-acc = (+ ,lat-cur ,lat-prev)
+                for ,lon-acc = (+ ,lon-cur ,lon-prev)
+                for ,lat = (degran-lat ,lat-acc ,block)
+                for ,lon = (degran-lon ,lon-acc ,block)
+                do (multiple-value-bind (,keys ,vals)
+                       (loop for (,key ,val) on (subseq (osmpbf:keys-vals ,dense) ,tag-start ,tag-end) by #'cddr
+                          collecting ,key into ,keys
+                          collecting ,val into ,vals
+                          finally (return (values ,keys ,vals)))
+                     (let ((,keys (sid ,keys ,string-table))
+                           (,vals (sid ,vals ,string-table)))
+                       ,@body)))))))
+
+(defmacro iterate-ways ((way block) &body body)
+  (with-gensyms (group)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        do (loop for ,way in (osmpbf:ways ,group)
+              do (progn
+                   (unsid ,way osmpbf:keys ,block)
+                   (unsid ,way osmpbf:vals ,block)
+                   (undelta (osmpbf:refs ,way))
+                   ,@body)))))
+
+(defmacro iterate-rels ((rel block) &body body)
+  (with-gensyms (group string-table)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        with ,string-table = (string-table ,block)
+        do (loop for ,rel in (osmpbf:relations ,group)
+              do (progn
+                   (unsid2 (osmpbf:keys ,rel) ,string-table)
+                   (unsid2 (osmpbf:vals ,rel) ,string-table)
+                   (unsid2 (osmpbf:roles-sid ,rel) ,string-table)
+                   (undelta (osmpbf:memids ,rel))
+                   ,@body)))))
+
+(defun get-tags (object string-table)
+  (loop for key in (osmpbf:keys object)
+     for val in (osmpbf:vals object)
+     collect  (cons (trivial-utf-8:utf-8-bytes-to-string (elt string-table key))
+                    (trivial-utf-8:utf-8-bytes-to-string (elt string-table val)))))
+
+(defun delta-decode (seq)
+  (loop for elt in seq
+     for prev = 0 then cur
+     for cur = (+ elt prev)
+     collect cur))
+
+(defmacro iterate-dense2 ((id tags lat lon block) &body body)
+  (with-gensyms (group string-table dense tag-start tag-end key val id-cur lat-cur lon-cur id-prev lat-prev lon-prev lat-acc lon-acc key-vals clo-start clo-end)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        with ,string-table = (string-table ,block)
+        do (when-let (,dense (osmpbf:dense ,group))
+             (loop
+                with ,key-vals = (osmpbf:keys-vals ,dense)
+                for ,id-cur in (osmpbf:id ,dense)
+                for ,lat-cur in (osmpbf:lat ,dense)
+                for ,lon-cur in (osmpbf:lon ,dense)
+                for ,id-prev = 0 then ,id
+                for ,lat-prev = 0 then ,lat-acc
+                for ,lon-prev = 0 then ,lon-acc
+                for ,tag-start = 0 then ,tag-end
+                for ,tag-end = (position 0 ,key-vals :start ,tag-start)
+                for ,id = (+ ,id-cur ,id-prev)
+                for ,lat-acc = (+ ,lat-cur ,lat-prev)
+                for ,lon-acc = (+ ,lon-cur ,lon-prev)
+                for ,lat = (degran-lat ,lat-acc ,block)
+                for ,lon = (degran-lon ,lon-acc ,block)
+                for ,tags = (unless (= ,tag-start ,tag-end)
+                              (let ((,clo-start ,tag-start)
+                                    (,clo-end ,tag-end))
+                                (lambda ()
+                                  (loop for (,key ,val) on (subseq ,key-vals ,clo-start ,clo-end) by #'cddr
+                                     collect (cons (trivial-utf-8:utf-8-bytes-to-string
+                                                    (elt ,string-table ,key))
+                                                   (trivial-utf-8:utf-8-bytes-to-string
+                                                    (elt ,string-table ,val)))))))
+                do (progn ,@body))))))
+
+(defmacro iterate-ways2 ((id tags refs block) &body body)
+  (with-gensyms (group string-table object o-string-table)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        with ,string-table = (string-table ,block)
+        do (loop for ,object in (osmpbf:ways ,group)
+              for ,id = (osmpbf:id ,object)
+              for ,o-string-table = ,string-table
+              for ,tags = (lambda () (get-tags ,object ,o-string-table))
+              for ,refs = (lambda () (delta-decode (osmpbf:refs ,object)))
+              do (progn ,@body)))))
+
+(defmacro iterate-rels2 ((id tags roles memids types block) &body body)
+  (with-gensyms (group string-table relation)
+    `(loop for ,group in (osmpbf:primitivegroup ,block)
+        with ,string-table = (string-table ,block)
+        do (loop for ,relation in (osmpbf:relations ,group)
+              for ,id = (osmpbf:id ,relation)
+              for ,tags = (lambda () (get-tags ,relation ,string-table))
+              for ,roles = (lambda () (sid (osmpbf:roles-sid ,relation) ,string-table))
+              for ,memids = (lambda () (delta-decode (osmpbf:memids ,relation)))
+              for ,types = (lambda () (osmpbf:types ,relation))
+              do (progn ,@body)))))
+
+(defun undelta (seq)
+  (when (> (length seq) 1)
+    (loop for i from 1 below (length seq)
+       do (incf (elt seq i)
+                (elt seq (1- i)))))
+  seq)
+
+(defparameter +supported-features+ '("OsmSchema-V0.6" "DenseNodes"))
+(defun ensure-features (header)
+  (when-let (missing-features (set-difference (osmpbf:required-features header)
+                                              +supported-features+
+                                              :test 'equal))
+    (error "Features ~A not supported" missing-features))
+  (setf *header-block* header))
+
+(defun unpack-block (blob)
+  (if-let (uncompressed (osmpbf:raw blob))
+    (let ((size (array-total-size uncompressed)))
+      (ensure-buffer size)
+      (dotimes (i (array-total-size uncompressed))
+        (setf (row-major-aref *read-buffer* i)
+              (row-major-aref uncompressed i)))
+      size)
+    (if-let (zlib-data (osmpbf:zlib-data blob))
+      (let ((size (osmpbf:raw-size blob)))
+        (ensure-buffer size)
+        (chipz:decompress *read-buffer* (chipz:make-dstate :zlib) zlib-data)
+        size)
+      (error "Unsupported block compression"))))
+
+(defun type-match (type-expr type)
+  (etypecase type-expr
+    (null t)
+    (symbol (eql type-expr type))
+    (list (member type type-expr))))
+
+(defun expr-match (template value)
+  (etypecase template
+    (null t)
+    (string (equal template value))
+    (list (destructuring-bind (type expr) template
+            (let ((pos (search expr value)))
+              (ecase type
+                (:pre (eql pos 0))
+                (:suf (eql pos (max 0 (- (length value)
+                                         (length expr)))))
+                (:inf (not (null pos)))
+                (:eql (and (eql pos 0)
+                           (= (length value)
+                              (length expr))))))))))
+
+(defun query-match (query type keys vals)
+  (or (null query)
+      (loop for expr in query
+         when (destructuring-bind (tp &optional keyp valp) expr
+                (and
+                 (type-match tp type)
+                 (or (and (null keyp) (null valp))
+                     (loop for key in keys
+                        for val in vals
+                        when (and (expr-match keyp key)
+                                  (expr-match valp val))
+                        return t))))
+         return t)))
+
+(defun query-match2 (query type tags-thunk)
+  (or (null query)
+      (loop for expr in query
+         when (destructuring-bind (tp &optional keyp valp) expr
+                (and
+                 (type-match tp type)
+                 (or (and (null keyp) (null valp))
+                     (and tags-thunk
+                          (loop for (key . val) in (if (functionp tags-thunk) (funcall tags-thunk) tags-thunk)
+                             when (and (expr-match keyp key)
+                                       (expr-match valp val))
+                             return t)))))
+         return t)))
+
+(defun query-has-type (query type)
+  (or (null query)
+      (loop for expr in query
+         when (type-match (car expr) type)
+         return t)))
+
+(defmacro iterate ((object filespec tags-query) &body body)
+  (let ((has-rels (query-has-type (cadr tags-query) :rel))
+        (has-ways (query-has-type (cadr tags-query) :way))
+        (has-nodes (query-has-type (cadr tags-query) :node)))
+    (with-gensyms (id lat lon keys vals query)
+      `(let ((,query ,tags-query))
+         (iterate-osm (,filespec)
+           ,@(when has-rels `((iterate-rels (,object *primitive-block*)
+                                (when (query-match ,query :rel (osmpbf:keys ,object) (osmpbf:vals ,object))
+                                  ,@body))))
+           ,@(when has-ways `((iterate-ways (,object *primitive-block*)
+                                (when (query-match ,query :way (osmpbf:keys ,object) (osmpbf:vals ,object))
+                                  ,@body))))
+           ,@(when has-nodes
+               `((iterate-nodes (,object *primitive-block*)
+                   (when (query-match ,query :node (osmpbf:keys ,object) (osmpbf:vals ,object))
+                     ,@body))
+                 (iterate-dense (,id ,lat ,lon ,keys ,vals *primitive-block*)
+                   (when (query-match ,query :node ,keys ,vals)
+                     (let ((,object (make-instance 'osmpbf:node :id ,id :lat ,lat :lon ,lon
+                                                   :keys ,keys :vals ,vals)))
+                       ,@body))))))))))
+
+(defstruct obj id tags)
+(defstruct (node (:include obj)) lat lon)
+(defstruct (way (:include obj)) refs)
+(defstruct (rel (:include obj)) roles memids types)
+
+(defmacro iterate2 ((object filespec query) &body body)
+  (let ((has-rels (query-has-type (cadr query) :rel))
+        (has-ways (query-has-type (cadr query) :way))
+        (has-nodes (query-has-type (cadr query) :node)))
+    (with-gensyms (g-query g-id g-tags g-roles g-memids g-types g-refs g-lat g-lon)
+      `(let ((,g-query ,query))
+         (iterate-osm (,filespec)
+           ,@(when has-rels `((iterate-rels2 (,g-id ,g-tags ,g-roles ,g-memids ,g-types *primitive-block*)
+                                (when (query-match2 ,g-query :rel ,g-tags)
+                                  (let ((,object (make-rel :id ,g-id :tags ,g-tags
+                                                           :roles ,g-roles :memids ,g-memids :types ,g-types)))
+                                    ,@body)))))
+           ,@(when has-ways `((iterate-ways2 (,g-id ,g-tags ,g-refs *primitive-block*)
+                                (when (query-match2 ,g-query :way ,g-tags)
+                                  (let ((,object (make-way :id ,g-id :tags ,g-tags
+                                                           :refs ,g-refs)))
+                                    ,@body)))))
+           ,@(when has-nodes `((iterate-dense2 (,g-id ,g-tags ,g-lat ,g-lon *primitive-block*)
+                                 (when (query-match2 ,g-query :node ,g-tags)
+                                   (let ((,object (make-node :id ,g-id :tags ,g-tags
+                                                             :lat ,g-lat :lon ,g-lon)))
+                                     ,@body))))))))))
+
+(defparameter +max-rel-pass+ 5 "max rel-2-rel passes")
+(defmacro with-related ((object filespec query) &body body)
+  (with-gensyms (g-object g-filespec g-objects g-idx-rels g-idx-ways g-idx-nodes g-rel g-type g-memid g-indexed
+                          g-dirty g-try g-indexed-list)
+    `(let ((,g-filespec ,filespec)
+           ,g-objects
+           (,g-idx-rels (make-hash-table))
+           (,g-idx-ways (make-hash-table))
+           (,g-idx-nodes (make-hash-table)))
+       (print "iterate queried")
+       (iterate2 (,g-object ,g-filespec ,query)
+         (typecase ,g-object
+           (node (let ((,object ,g-object)) ,@body))
+           (way (push ,g-object ,g-objects)
+                (setf (obj-tags ,g-object) (funcall (obj-tags ,g-object))
+                      (way-refs ,g-object) (funcall (way-refs ,g-object)))
+                (loop for ,g-rel in (way-refs ,g-object)
+                   do (push ,g-object (gethash ,g-rel ,g-idx-nodes))))
+           (rel (push ,g-object ,g-objects)
+                (setf (obj-tags ,g-object) (funcall (obj-tags ,g-object))
+                      (rel-roles ,g-object) (funcall (rel-roles ,g-object))
+                      (rel-memids ,g-object) (funcall (rel-memids ,g-object))
+                      (rel-types ,g-object) (funcall (rel-types ,g-object)))
+                (loop for ,g-memid in (rel-memids ,g-object)
+                   for ,g-type in (rel-types ,g-object)
+                   do (push ,g-object (gethash ,g-memid (ecase ,g-type
+                                                          (:node ,g-idx-nodes)
+                                                          (:way ,g-idx-ways)
+                                                          (:relation ,g-idx-rels))))))))
+       (when (plusp (hash-table-count ,g-idx-rels))
+         (loop
+            for ,g-dirty = nil
+            for ,g-try from 1 upto +max-rel-pass+
+            do (format t "iterate rels pass ~a~%" ,g-try)
+            do (iterate2 (,g-object ,g-filespec '((:rel)))
+                 (when-let ((,g-indexed-list (gethash (obj-id ,g-object) ,g-idx-rels)))
+                   (setf (rel-memids ,g-object) (funcall (rel-memids ,g-object))
+                         (rel-types ,g-object) (funcall (rel-types ,g-object)))
+                   (loop for ,g-indexed in ,g-indexed-list
+                      do (loop
+                            for ,g-memid on (rel-memids ,g-indexed)
+                            for ,g-type in (rel-types ,g-indexed)
+                            when (and (eql ,g-type :relation)
+                                      (equal (car ,g-memid) (obj-id ,g-object)))
+                            do (setf (car ,g-memid) ,g-object) and ;; replace memid ref with current rel
+                            do (loop for ,g-memid in (rel-memids ,g-object) ;; add it's references to index
+                                  for ,g-type in (rel-types ,g-object)
+                                  do (push ,g-object
+                                           (gethash ,g-memid (ecase ,g-type
+                                                               (:node ,g-idx-nodes)
+                                                               (:way ,g-idx-ways)
+                                                               (:relation (prog1 ,g-idx-rels
+                                                                            (setf ,g-dirty t)))))))))
+                   (remhash (obj-id ,g-object) ,g-idx-rels))) ;; remove processed rel from index
+            while ,g-dirty))
+       (when (plusp (hash-table-count ,g-idx-ways))
+         (print "iterate ways")
+         (iterate2 (,g-object ,g-filespec '((:way)))
+           (when-let ((,g-indexed-list (gethash (obj-id ,g-object) ,g-idx-ways)))
+             (setf (way-refs ,g-object) (funcall (way-refs ,g-object)))
+             (loop for ,g-indexed in ,g-indexed-list
+                do (loop
+                      for ,g-memid on (rel-memids ,g-indexed)
+                      for ,g-type in (rel-types ,g-indexed)
+                      when (and (eql ,g-type :way)
+                                (equal (car ,g-memid) (obj-id ,g-object)))
+                      do (setf (car ,g-memid) ,g-object) and ;; replace memid ref with current way
+                      do (loop for ,g-rel in (way-refs ,g-object) ;; add it's refs to index
+                            do (push ,g-object (gethash ,g-rel ,g-idx-nodes)))))
+             (remhash (obj-id ,g-object) ,g-idx-ways)))) ;; remove processed way from index
+       (when (plusp (hash-table-count ,g-idx-nodes))
+         (print "iterate nodes")
+         (iterate2 (,g-object ,g-filespec '((:node)))
+           (when-let ((,g-indexed-list (gethash (obj-id ,g-object) ,g-idx-nodes)))
+             (loop for ,g-indexed in ,g-indexed-list
+                  do (etypecase ,g-indexed
+                       (rel (loop
+                               for ,g-memid on (rel-memids ,g-indexed)
+                               for ,g-type in (rel-types ,g-indexed)
+                               when (and (eql ,g-type :node)
+                                         (equal (car ,g-memid) (obj-id ,g-object)))
+                               do (setf (car ,g-memid) ,g-object))) ;; replace rel's memid  with current node
+                       (way (nsubstitute ,g-object (obj-id ,g-object) (way-refs ,g-indexed))))) ;; replace way's ref with current node
+             (remhash (obj-id ,g-object) ,g-idx-nodes))))
+       (loop for ,object in (nreverse ,g-objects) ;; Iterate original matched objects
+          do (progn ,@body)))))

osmformat.lisp

@@ -0,0 +1,169 @@
+(cl:eval-when (:execute :compile-toplevel :load-toplevel)
+  (cl:unless (cl:find-package "OSMPBF")
+    (cl:defpackage OSMPBF (:use))))
+(cl:in-package "OSMPBF")
+(cl:export '(HEADER-BLOCK
+             BBOX
+             REQUIRED-FEATURES
+             OPTIONAL-FEATURES
+             WRITINGPROGRAM
+             SOURCE
+             OSMOSIS-REPLICATION-TIMESTAMP
+             OSMOSIS-REPLICATION-SEQUENCE-NUMBER
+             OSMOSIS-REPLICATION-BASE-URL
+             HEADER-B-BOX
+             LEFT
+             RIGHT
+             TOP
+             BOTTOM
+             PRIMITIVE-BLOCK
+             STRINGTABLE
+             PRIMITIVEGROUP
+             GRANULARITY
+             LAT-OFFSET
+             LON-OFFSET
+             DATE-GRANULARITY
+             PRIMITIVE-GROUP
+             NODES
+             DENSE
+             WAYS
+             RELATIONS
+             CHANGESETS
+             STRING-TABLE
+             S
+             INFO
+             VERSION
+             TIMESTAMP
+             CHANGESET
+             UID
+             USER-SID
+             VISIBLE
+             DENSE-INFO
+             CHANGE-SET
+             ID
+             NODE
+             KEYS
+             VALS
+             LAT
+             LON
+             DENSE-NODES
+             DENSEINFO
+             KEYS-VALS
+             WAY
+             REFS
+             RELATION
+             ROLES-SID
+             MEMIDS
+             TYPES))
+
+(proto:define-schema osmformat
+    (:package "OSMPBF"
+     :lisp-package "OSMPBF"
+     :options (:java_package "crosby.binary"))
+  (proto:define-message header-block
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 2255 2266))
+    ((bbox 1) :type (common-lisp:or common-lisp:null header-b-box))
+    ((required-features 4) :type (protobufs:list-of common-lisp:string))
+    ((optional-features 5) :type (protobufs:list-of common-lisp:string))
+    ((writingprogram 16) :type (common-lisp:or common-lisp:null
+                                               common-lisp:string))
+    ((source 17) :type (common-lisp:or common-lisp:null common-lisp:string))
+    ((osmosis-replication-timestamp 32) :type (common-lisp:or common-lisp:null
+                                                              protobufs:int64))
+    ((osmosis-replication-sequence-number 33) :type (common-lisp:or
+                                                     common-lisp:null
+                                                     protobufs:int64))
+    ((osmosis-replication-base-url 34) :type (common-lisp:or common-lisp:null
+                                                             common-lisp:string)))
+  (proto:define-message header-b-box
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 3227 3237))
+    ((left 1) :type protobufs:sint64)
+    ((right 2) :type protobufs:sint64)
+    ((top 3) :type protobufs:sint64)
+    ((bottom 4) :type protobufs:sint64))
+  (proto:define-message primitive-block
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 3516 3530))
+    ((stringtable 1) :type string-table)
+    ((primitivegroup 2) :type (protobufs:list-of primitive-group))
+    ((granularity 17) :type (common-lisp:or common-lisp:null protobufs:int32) :default 100)
+    ((lat-offset 19) :type (common-lisp:or common-lisp:null protobufs:int64) :default 0)
+    ((lon-offset 20) :type (common-lisp:or common-lisp:null protobufs:int64) :default 0)
+    ((date-granularity 18) :type (common-lisp:or common-lisp:null
+                                                 protobufs:int32) :default 1000))
+  (proto:define-message primitive-group
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 4248 4262))
+    ((nodes 1) :type (protobufs:list-of node))
+    ((dense 2) :type (common-lisp:or common-lisp:null dense-nodes))
+    ((ways 3) :type (protobufs:list-of way))
+    ((relations 4) :type (protobufs:list-of relation))
+    ((changesets 5) :type (protobufs:list-of change-set)))
+  (proto:define-message string-table
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 4627 4638))
+    ((s 1) :type (protobufs:list-of protobufs:byte-vector)))
+  (proto:define-message info
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 4743 4747))
+    ((version 1) :type (common-lisp:or common-lisp:null protobufs:int32) :default -1)
+    ((timestamp 2) :type (common-lisp:or common-lisp:null protobufs:int64))
+    ((changeset 3) :type (common-lisp:or common-lisp:null protobufs:int64))
+    ((uid 4) :type (common-lisp:or common-lisp:null protobufs:int32))
+    ((user-sid 5) :type (common-lisp:or common-lisp:null protobufs:uint32))
+    ((visible 6) :type (common-lisp:or common-lisp:null common-lisp:boolean)))
+  (proto:define-message dense-info
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 5557 5566))
+    ((version 1) :type (protobufs:list-of protobufs:int32) :packed common-lisp:t)
+    ((timestamp 2) :type (protobufs:list-of protobufs:sint64) :packed common-lisp:t)
+    ((changeset 3) :type (protobufs:list-of protobufs:sint64) :packed common-lisp:t)
+    ((uid 4) :type (protobufs:list-of protobufs:sint32) :packed common-lisp:t)
+    ((user-sid 5) :type (protobufs:list-of protobufs:sint32) :packed common-lisp:t)
+    ((visible 6) :type (protobufs:list-of common-lisp:boolean) :packed common-lisp:t))
+  (proto:define-message change-set
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 6510 6519))
+    ((id 1) :type protobufs:int64))
+  (proto:define-message node
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 6891 6895))
+    ((id 1) :type protobufs:sint64)
+    ((keys 2) :type (protobufs:list-of protobufs:uint32) :packed common-lisp:t)
+    ((vals 3) :type (protobufs:list-of protobufs:uint32) :packed common-lisp:t)
+    ((info 4) :type (common-lisp:or common-lisp:null info))
+    ((lat 8) :type protobufs:sint64)
+    ((lon 9) :type protobufs:sint64))
+  (proto:define-message dense-nodes
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 7591 7601))
+    ((id 1) :type (protobufs:list-of protobufs:sint64) :packed common-lisp:t)
+    ((denseinfo 5) :type (common-lisp:or common-lisp:null dense-info))
+    ((lat 8) :type (protobufs:list-of protobufs:sint64) :packed common-lisp:t)
+    ((lon 9) :type (protobufs:list-of protobufs:sint64) :packed common-lisp:t)
+    ((keys-vals 10) :type (protobufs:list-of protobufs:int32) :packed common-lisp:t))
+  (proto:define-message way
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 8020 8023))
+    ((id 1) :type protobufs:int64)
+    ((keys 2) :type (protobufs:list-of protobufs:uint32) :packed common-lisp:t)
+    ((vals 3) :type (protobufs:list-of protobufs:uint32) :packed common-lisp:t)
+    ((info 4) :type (common-lisp:or common-lisp:null info))
+    ((refs 8) :type (protobufs:list-of protobufs:sint64) :packed common-lisp:t))
+  (proto:define-message relation
+      (:conc-name ""
+       :source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 8266 8274))
+    (proto:define-enum member-type
+        (:source-location (#P"/home/enikesha-ssd/dev/lisp/ocm/osmformat.proto" 8284 8294))
+      (node 0)
+      (way 1)
+      (relation 2))
+    ((id 1) :type protobufs:int64)
+    ((keys 2) :type (protobufs:list-of protobufs:uint32) :packed common-lisp:t)
+    ((vals 3) :type (protobufs:list-of protobufs:uint32) :packed common-lisp:t)
+    ((info 4) :type (common-lisp:or common-lisp:null info))
+    ((roles-sid 8) :type (protobufs:list-of protobufs:int32) :packed common-lisp:t)
+    ((memids 9) :type (protobufs:list-of protobufs:sint64) :packed common-lisp:t)
+    ((types 10) :type (protobufs:list-of member-type) :packed common-lisp:t)))

osmformat.proto

@@ -0,0 +1,260 @@
+/** Copyright (c) 2010 Scott A. Crosby. <scott@sacrosby.com>
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU Lesser General Public License as 
+   published by the Free Software Foundation, either version 3 of the 
+   License, or (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+*/
+
+option optimize_for = LITE_RUNTIME;
+option java_package = "crosby.binary";
+package OSMPBF;
+
+/* OSM Binary file format 
+
+This is the master schema file of the OSM binary file format. This
+file is designed to support limited random-access and future
+extendability.
+
+A binary OSM file consists of a sequence of FileBlocks (please see
+fileformat.proto). The first fileblock contains a serialized instance
+of HeaderBlock, followed by a sequence of PrimitiveBlock blocks that
+contain the primitives.
+
+Each primitiveblock is designed to be independently parsable. It
+contains a string table storing all strings in that block (keys and
+values in tags, roles in relations, usernames, etc.) as well as
+metadata containing the precision of coordinates or timestamps in that
+block.
+
+A primitiveblock contains a sequence of primitive groups, each
+containing primitives of the same type (nodes, densenodes, ways,
+relations). Coordinates are stored in signed 64-bit integers. Lat&lon
+are measured in units <granularity> nanodegrees. The default of
+granularity of 100 nanodegrees corresponds to about 1cm on the ground,
+and a full lat or lon fits into 32 bits.
+
+Converting an integer to a lattitude or longitude uses the formula:
+$OUT = IN * granularity / 10**9$. Many encoding schemes use delta
+coding when representing nodes and relations.
+
+*/
+
+//////////////////////////////////////////////////////////////////////////
+//////////////////////////////////////////////////////////////////////////
+
+/* Contains the file header. */
+
+message HeaderBlock {
+  optional HeaderBBox bbox = 1;
+  /* Additional tags to aid in parsing this dataset */
+  repeated string required_features = 4;
+  repeated string optional_features = 5;
+
+  optional string writingprogram = 16; 
+  optional string source = 17; // From the bbox field.
+
+  /* Tags that allow continuing an Osmosis replication */
+
+  // replication timestamp, expressed in seconds since the epoch, 
+  // otherwise the same value as in the "timestamp=..." field
+  // in the state.txt file used by Osmosis
+  optional int64 osmosis_replication_timestamp = 32;
+
+  // replication sequence number (sequenceNumber in state.txt)
+  optional int64 osmosis_replication_sequence_number = 33;
+
+  // replication base URL (from Osmosis' configuration.txt file)
+  optional string osmosis_replication_base_url = 34;
+}
+
+
+/** The bounding box field in the OSM header. BBOX, as used in the OSM
+header. Units are always in nanodegrees -- they do not obey
+granularity rules. */
+
+message HeaderBBox {
+   required sint64 left = 1;
+   required sint64 right = 2;
+   required sint64 top = 3;
+   required sint64 bottom = 4;
+}
+
+
+///////////////////////////////////////////////////////////////////////
+///////////////////////////////////////////////////////////////////////
+
+
+message PrimitiveBlock {
+  required StringTable stringtable = 1;
+  repeated PrimitiveGroup primitivegroup = 2;
+
+  // Granularity, units of nanodegrees, used to store coordinates in this block
+  optional int32 granularity = 17 [default=100]; 
+  // Offset value between the output coordinates coordinates and the granularity grid in unites of nanodegrees.
+  optional int64 lat_offset = 19 [default=0];
+  optional int64 lon_offset = 20 [default=0]; 
+
+// Granularity of dates, normally represented in units of milliseconds since the 1970 epoch.
+  optional int32 date_granularity = 18 [default=1000]; 
+
+
+  // Proposed extension:
+  //optional BBox bbox = XX;
+}
+
+// Group of OSMPrimitives. All primitives in a group must be the same type.
+message PrimitiveGroup {
+  repeated Node     nodes = 1;
+  optional DenseNodes dense = 2;
+  repeated Way      ways = 3;
+  repeated Relation relations = 4;
+  repeated ChangeSet changesets = 5;
+}
+
+
+/** String table, contains the common strings in each block.
+
+ Note that we reserve index '0' as a delimiter, so the entry at that
+ index in the table is ALWAYS blank and unused.
+
+ */
+message StringTable {
+   repeated bytes s = 1;
+}
+
+/* Optional metadata that may be included into each primitive. */
+message Info {
+   optional int32 version = 1 [default = -1];
+   optional int64 timestamp = 2;
+   optional int64 changeset = 3;
+   optional int32 uid = 4;
+   optional uint32 user_sid = 5; // String IDs
+
+   // The visible flag is used to store history information. It indicates that
+   // the current object version has been created by a delete operation on the
+   // OSM API.
+   // When a writer sets this flag, it MUST add a required_features tag with
+   // value "HistoricalInformation" to the HeaderBlock.
+   // If this flag is not available for some object it MUST be assumed to be
+   // true if the file has the required_features tag "HistoricalInformation"
+   // set.
+   optional bool visible = 6;
+}
+
+/** Optional metadata that may be included into each primitive. Special dense format used in DenseNodes. */
+message DenseInfo {
+   repeated int32 version = 1 [packed = true]; 
+   repeated sint64 timestamp = 2 [packed = true]; // DELTA coded
+   repeated sint64 changeset = 3 [packed = true]; // DELTA coded
+   repeated sint32 uid = 4 [packed = true]; // DELTA coded
+   repeated sint32 user_sid = 5 [packed = true]; // String IDs for usernames. DELTA coded
+
+   // The visible flag is used to store history information. It indicates that
+   // the current object version has been created by a delete operation on the
+   // OSM API.
+   // When a writer sets this flag, it MUST add a required_features tag with
+   // value "HistoricalInformation" to the HeaderBlock.
+   // If this flag is not available for some object it MUST be assumed to be
+   // true if the file has the required_features tag "HistoricalInformation"
+   // set.
+   repeated bool visible = 6 [packed = true];
+}
+
+
+// THIS IS STUB DESIGN FOR CHANGESETS. NOT USED RIGHT NOW.
+// TODO:    REMOVE THIS?
+message ChangeSet {
+   required int64 id = 1;
+//   
+//   // Parallel arrays.
+//   repeated uint32 keys = 2 [packed = true]; // String IDs.
+//   repeated uint32 vals = 3 [packed = true]; // String IDs.
+//
+//   optional Info info = 4;
+
+//   optional int64 created_at = 8;
+//   optional int64 closetime_delta = 9;
+//   optional bool open = 10;
+//   optional HeaderBBox bbox = 11;
+}
+
+
+message Node {
+   required sint64 id = 1;
+   // Parallel arrays.
+   repeated uint32 keys = 2 [packed = true]; // String IDs.
+   repeated uint32 vals = 3 [packed = true]; // String IDs.
+
+   optional Info info = 4; // May be omitted in omitmeta
+
+   required sint64 lat = 8;
+   required sint64 lon = 9;
+}
+
+/* Used to densly represent a sequence of nodes that do not have any tags.
+
+We represent these nodes columnwise as five columns: ID's, lats, and
+lons, all delta coded. When metadata is not omitted, 
+
+We encode keys & vals for all nodes as a single array of integers
+containing key-stringid and val-stringid, using a stringid of 0 as a
+delimiter between nodes.
+
+   ( (<keyid> <valid>)* '0' )*
+ */
+
+message DenseNodes {
+   repeated sint64 id = 1 [packed = true]; // DELTA coded
+
+   //repeated Info info = 4;
+   optional DenseInfo denseinfo = 5;
+
+   repeated sint64 lat = 8 [packed = true]; // DELTA coded
+   repeated sint64 lon = 9 [packed = true]; // DELTA coded
+
+   // Special packing of keys and vals into one array. May be empty if all nodes in this block are tagless.
+   repeated int32 keys_vals = 10 [packed = true]; 
+}
+
+
+message Way {
+   required int64 id = 1;
+   // Parallel arrays.
+   repeated uint32 keys = 2 [packed = true];
+   repeated uint32 vals = 3 [packed = true];
+
+   optional Info info = 4;
+
+   repeated sint64 refs = 8 [packed = true];  // DELTA coded
+}
+
+message Relation {
+  enum MemberType {
+    NODE = 0;
+    WAY = 1;
+    RELATION = 2;
+  } 
+   required int64 id = 1;
+
+   // Parallel arrays.
+   repeated uint32 keys = 2 [packed = true];
+   repeated uint32 vals = 3 [packed = true];
+
+   optional Info info = 4;
+
+   // Parallel arrays
+   repeated int32 roles_sid = 8 [packed = true]; // This should have been defined as uint32 for consistency, but it is now too late to change it
+   repeated sint64 memids = 9 [packed = true]; // DELTA encoded
+   repeated MemberType types = 10 [packed = true];
+}
+

s2.lisp

@@ -0,0 +1,929 @@
+(in-package :cl-user)
+(defpackage #:ocm.s2
+  (:use :cl))
+(in-package :ocm.s2)
+
+;; In the process of converting a latitude-longitude pair to a 64-bit cell
+;; id, the following coordinate systems are used:
+;;
+;;  (id)
+;;    An S2CellId is a 64-bit encoding of a face and a Hilbert curve position
+;;    on that face.  The Hilbert curve position implicitly encodes both the
+;;    position of a cell and its subdivision level (see s2cell_id.h).
+;;
+;;  (face, i, j)
+;;    Leaf-cell coordinates.  "i" and "j" are integers in the range
+;;    [0,(2**30)-1] that identify a particular leaf cell on the given face.
+;;    The (i, j) coordinate system is right-handed on each face, and the
+;;    faces are oriented such that Hilbert curves connect continuously from
+;;    one face to the next.
+;;
+;;  (face, s, t)
+;;    Cell-space coordinates.  "s" and "t" are real numbers in the range
+;;    [0,1] that identify a point on the given face.  For example, the point
+;;    (s, t) = (0.5, 0.5) corresponds to the center of the top-level face
+;;    cell.  This point is also a vertex of exactly four cells at each
+;;    subdivision level greater than zero.
+;;
+;;  (face, si, ti)
+;;    Discrete cell-space coordinates.  These are obtained by multiplying
+;;    "s" and "t" by 2**31 and rounding to the nearest unsigned integer.
+;;    Discrete coordinates lie in the range [0,2**31].  This coordinate
+;;    system can represent the edge and center positions of all cells with
+;;    no loss of precision (including non-leaf cells).  In binary, each
+;;    coordinate of a level-k cell center ends with a 1 followed by
+;;    (30 - k) 0s.  The coordinates of its edges end with (at least)
+;;    (31 - k) 0s.
+;;
+;;  (face, u, v)
+;;    Cube-space coordinates in the range [-1,1].  To make the cells at each
+;;    level more uniform in size after they are projected onto the sphere,
+;;    we apply a nonlinear transformation of the form u=f(s), v=f(t).
+;;    The (u, v) coordinates after this transformation give the actual
+;;    coordinates on the cube face (modulo some 90 degree rotations) before
+;;    it is projected onto the unit sphere.
+;;
+;;  (face, u, v, w)
+;;    Per-face coordinate frame.  This is an extension of the (face, u, v)
+;;    cube-space coordinates that adds a third axis "w" in the direction of
+;;    the face normal.  It is always a right-handed 3D coordinate system.
+;;    Cube-space coordinates can be converted to this frame by setting w=1,
+;;    while (u,v,w) coordinates can be projected onto the cube face by
+;;    dividing by w, i.e. (face, u/w, v/w).
+;;
+;;  (x, y, z)
+;;    Direction vector (S2Point).  Direction vectors are not necessarily unit
+;;    length, and are often chosen to be points on the biunit cube
+;;    [-1,+1]x[-1,+1]x[-1,+1].  They can be be normalized to obtain the
+;;    corresponding point on the unit sphere.
+;;
+;;  (lat, lng)
+;;    Latitude and longitude (S2LatLng).  Latitudes must be between -90 and
+;;    90 degrees inclusive, and longitudes must be between -180 and 180
+;;    degrees inclusive.
+;;
+;; Note that the (i, j), (s, t), (si, ti), and (u, v) coordinate systems are
+;; right-handed on all six faces.
+
+(defparameter +swap-mask+ 1)
+(defparameter +invert-mask+ 2)
+(defparameter +max-cell-level+ 30 "This is the number of levels needed to specify a leaf cell.")
+(defparameter +limit-ij+ (ash 1 +max-cell-level+) "The maximum index of a valid leaf cell plus one. The range of valid leaf cell indices is [0..+limit-ij+-1].")
+(defparameter +max-si-ti+ (ash 1 (+ 1 +max-cell-level+)) "The maximum value of an si- or ti-coordinate.  The range of valid (si,ti) values is [0..+max-si-ti+].")
+
+;; An S2CellId is a 64-bit unsigned integer that uniquely identifies a
+;; cell in the S2 cell decomposition.  It has the following format:
+;;
+;;   id = [face][face_pos]
+;;
+;;   face:     a 3-bit number (range 0..5) encoding the cube face.
+;;
+;;   face_pos: a 61-bit number encoding the position of the center of this
+;;             cell along the Hilbert curve over this face (see the Wiki
+;;             pages for details).
+;;
+;; Sequentially increasing cell ids follow a continuous space-filling curve
+;; over the entire sphere.  They have the following properties:
+;;
+;;  - The id of a cell at level k consists of a 3-bit face number followed
+;;    by k bit pairs that recursively select one of the four children of
+;;    each cell.  The next bit is always 1, and all other bits are 0.
+;;    Therefore, the level of a cell is determined by the position of its
+;;    lowest-numbered bit that is turned on (for a cell at level k, this
+;;    position is 2 * (kMaxLevel - k).)
+;;
+;;  - The id of a parent cell is at the midpoint of the range of ids spanned
+;;    by its children (or by its descendants at any level).
+(defparameter +face-bits+ 3)
+(defparameter +num-faces+ 6)
+(defparameter +max-level+ +max-cell-level+)
+(defparameter +pos-bits+ (1+ (* 2 +max-level+)))
+(defparameter +max-size+ (ash 1 +max-level+))
+
+(defun st-to-ij (s)
+  (max 0 (min (- +limit-ij+ 1) (round (- (* s +limit-ij+) 0.5d0)))))
+
+;; Use quadratic (s,t) -> (u,v) projection. See S2 sources for explanation.
+(defun st-to-uv (s)
+  (* (/ 1 3)
+     (if (>= s 0.5d0)
+         (- (* 4 s s) 1)
+         (- 1 (* 4 (- s 1) (- s 1))))))
+(defun uv-to-st (u)
+  (if (>= u 0)
+      (* 0.5d0 (sqrt (+ 1 (* 3 u))))
+      (- 1 (* 0.5d0 (sqrt (- 1 (* 3 u)))))))
+
+(defstruct point
+  (x 0.0d0 :type double-float)
+  (y 0.0d0 :type double-float)
+  (z 0.0d0 :type double-float))
+
+(defstruct latlng
+  (lat 0d0 :type double-float)
+  (lng 0d0 :type double-float))
+
+(defun deg-to-rad (deg)
+  (* (/ pi 180d0) deg))
+(defun rad-to-deg (rad)
+  (* (/ 180d0 pi) rad))
+
+(defun from-radians (lat-rad lng-rad)
+  (make-latlng :lat lat-rad :lng lng-rad))
+(defun from-degrees (lat-deg lng-deg)
+  (make-latlng :lat (deg-to-rad lat-deg) :lng (deg-to-rad lng-deg)))
+(defun to-degrees (latlng)
+  (declare (type latlng latlng))
+  (with-slots (lat lng) latlng
+    (cons (rad-to-deg lat) (rad-to-deg lng))))
+(defun latlng-to-point (latlng)
+  (declare (type latlng latlng))
+  (with-slots (lat lng) latlng
+    (let* ((phi lat)
+           (theta lng)
+           (cos-phi (cos phi)))
+      (make-point :x (* (cos theta) cos-phi)
+                  :y (* (sin theta) cos-phi)
+                  :z (sin phi)))))
+(defun point-lat (p)
+  (declare (type point p))
+  (with-slots (x y z) p
+    (atan z (sqrt (+ (* x x) (* y y))))))
+(defun point-lng (p)
+  (declare (type point p))
+  (with-slots (x y z) p
+    (atan y x)))
+(defun point-to-lat-lng (p)
+  (declare (type point p))
+  (from-radians (point-lat p) (point-lng p)))
+
+(defun dot (p1 p2)
+  (declare (type point p1 p2))
+  (+ (* (point-x p1) (point-x p2))
+     (* (point-y p1) (point-y p2))
+     (* (point-z p1) (point-z p2))))
+
+(defparameter +face-uvw-axes+
+  (make-array '(6 3) :element-type 'point :initial-contents
+              (list
+               (list (make-point :y 1d0) (make-point :z 1d0) (make-point :x 1d0))
+               (list (make-point :x -1d0) (make-point :z 1d0) (make-point :y 1d0))
+               (list (make-point :x -1d0) (make-point :y -1d0) (make-point :z 1d0))
+               (list (make-point :z -1d0) (make-point :y -1d0) (make-point :x -1d0))
+               (list (make-point :z -1d0) (make-point :x 1d0) (make-point :y -1d0))
+               (list (make-point :y 1d0) (make-point :x 1d0) (make-point :z -1d0))))
+  "The U,V,W axes for each face.")
+
+(defun get-xyz-face (p)
+  (declare (type point p))
+  (with-slots (x y z) p
+    (cond
+      ((and (> (abs x) (abs y))
+            (> (abs x) (abs z)))
+       (if (>= x 0) 0 3))
+      ((and (> (abs y) (abs x))
+            (> (abs y) (abs z)))
+       (if (>= y 0) 1 4))
+      (t
+       (if (>= z 0) 2 5)))))
+
+(defun get-uvw-axis (face axis)
+  (aref +face-uvw-axes+ face axis))
+
+(defun get-norm (face)
+  (get-uvw-axis face 2))
+
+(defun valid-face-xyz-to-uv (face p)
+  (declare (type point p))
+  (assert (> (dot (get-norm face) p) 0))
+  (with-slots (x y z) p
+    (ecase face
+      (0 (values (/ y x) (/ z x)))
+      (1 (values (/ (- x) y) (/ z y)))
+      (2 (values (/ (- x) z) (/ (- y) z)))
+      (3 (values (/ z x) (/ y x)))
+      (4 (values (/ z y) (/ (- x) y)))
+      (5 (values (/ (- y) z) (/ (- x) z))))))
+
+(defun xyz-to-face-uv (p)
+  (declare (type point p))
+  (let ((face (get-xyz-face p)))
+    (multiple-value-bind (u v)
+        (valid-face-xyz-to-uv face p)
+      (values face u v))))
+
+(defparameter +lookup-bits+ 4)
+(defvar *lookup-pos* (make-array (ash 1 (+ 2 (* +lookup-bits+ 2))) :element-type '(unsigned-byte 16)))
+(defvar *lookup-ij* (make-array (ash 1 (+ 2 (* +lookup-bits+ 2))) :element-type '(unsigned-byte 16)))
+(defparameter +ij-to-pos+
+  #(#(0 1 3 2) ; canonical order
+    #(0 3 1 2) ; axes swapped
+    #(2 3 1 0) ; bits inverted
+    #(2 1 3 0)); swapped & inverted
+  "IJtoPos[orientation][ij] -> pos")
+(defparameter +pos-to-ij+
+  #(#(0 1 3 2) ; canonical order:    (0,0), (0,1), (1,1), (1,0)
+    #(0 2 3 1) ; axes swapped:       (0,0), (1,0), (1,1), (0,1)
+    #(3 2 0 1) ; bits inverted:      (1,1), (1,0), (0,0), (0,1)
+    #(3 1 0 2)); swapped & inverted: (1,1), (0,1), (0,0), (1,0)
+  "PosToIJ[orientation][pos] -> ij")
+(defparameter +pos-to-orient+
+  (make-array 4 :element-type '(unsigned-byte 8)
+              :initial-contents (list +swap-mask+ 0 0 (logior +swap-mask+ +invert-mask+)))
+  "PosToOrientation[pos] -> orientation_modifier")
+
+(defun init-lookup ()
+  (labels ((init-lookup-cell (level i j orig-orient pos orient)
+             (if (= level +lookup-bits+)
+                 (let ((ij (+ (ash i +lookup-bits+) j)))
+                   (setf (aref *lookup-pos* (+ (ash ij 2) orig-orient)) (+ (ash pos 2) orient))
+                   (setf (aref *lookup-ij* (+ (ash pos 2) orig-orient)) (+ (ash ij 2) orient)))
+                 (let ((level (1+ level))
+                       (i (ash i 1))
+                       (j (ash j 1))
+                       (pos (ash pos 2))
+                       (r (aref +pos-to-ij+ orient)))
+                   (init-lookup-cell level (+ i (ash (aref r 0) -1)) (+ j (logand (aref r 0) 1))
+                                     orig-orient pos (logxor orient (aref +pos-to-orient+ 0)))
+                   (init-lookup-cell level (+ i (ash (aref r 1) -1)) (+ j (logand (aref r 1) 1))
+                                     orig-orient (+ pos 1) (logxor orient (aref +pos-to-orient+ 1)))
+                   (init-lookup-cell level (+ i (ash (aref r 2) -1)) (+ j (logand (aref r 2) 1))
+                                     orig-orient (+ pos 2) (logxor orient (aref +pos-to-orient+ 2)))
+                   (init-lookup-cell level (+ i (ash (aref r 3) -1)) (+ j (logand (aref r 3) 1))
+                                     orig-orient (+ pos 3) (logxor orient (aref +pos-to-orient+ 3)))))))
+    (init-lookup-cell 0 0 0 0 0 0)
+    (init-lookup-cell 0 0 0 +swap-mask+ 0 +swap-mask+)
+    (init-lookup-cell 0 0 0 +invert-mask+ 0 +invert-mask+)
+    (init-lookup-cell 0 0 0 (logior +swap-mask+ +invert-mask+) 0 (logior +swap-mask+ +invert-mask+))))
+
+(eval-when (:execute :compile-toplevel :load-toplevel)
+  (init-lookup))
+
+(defun from-face-ij (face i j)
+  (let ((n (ash face (1- +pos-bits+)))
+        (bits (logand face +swap-mask+)))
+    (macrolet ((get-bits (k)
+                 `(let ((mask (1- (ash 1 +lookup-bits+))))
+                    (setf bits
+                          (aref *lookup-pos*
+                                (+ bits
+                                   (ash (logand mask (ash i (- (* ,k +lookup-bits+)))) (+ +lookup-bits+ 2))
+                                   (ash (logand mask (ash j (- (* ,k +lookup-bits+)))) 2))))
+                    (setf n (logior n (ash (ash bits -2)
+                                           (* ,k 2 +lookup-bits+)))
+                          bits (logand bits (logior +swap-mask+ +invert-mask+))))))
+      (get-bits 7)
+      (get-bits 6)
+      (get-bits 5)
+      (get-bits 4)
+      (get-bits 3)
+      (get-bits 2)
+      (get-bits 1)
+      (get-bits 0))
+    (1+ (* 2 n))))
+
+(defun point-to-cell (p)
+  (multiple-value-bind (face u v)
+      (xyz-to-face-uv p)
+    (from-face-ij face
+                  (st-to-ij (uv-to-st u))
+                  (st-to-ij (uv-to-st v)))))
+
+(defun cell-to-face-ij-orientation (id)
+  (let* ((i 0)
+         (j 0)
+         (face (cell-face id))
+         (bits (logand face +swap-mask+)))
+    (macrolet ((get-bits (k)
+                 `(let ((nbits (if (= ,k 7) (- +max-level+ (* 7 +lookup-bits+)) +lookup-bits+)))
+                    (setf bits (aref *lookup-ij*
+                                     (+ bits
+                                        (ash (logand (ash id (- (1+ (* ,k 2 +lookup-bits+))))
+                                                     (1- (ash 1 (* 2 nbits)))) 2))))
+                    (setf i (+ i (ash (ash bits (- (+ +lookup-bits+ 2)))
+                                      (* ,k +lookup-bits+)))
+                          j (+ j (ash (logand (ash bits -2)
+                                              (1- (ash 1 +lookup-bits+)))
+                                      (* ,k +lookup-bits+)))
+                          bits (logand bits (logior +swap-mask+ +invert-mask+))))))
+      (get-bits 7)
+      (get-bits 6)
+      (get-bits 5)
+      (get-bits 4)
+      (get-bits 3)
+      (get-bits 2)
+      (get-bits 1)
+      (get-bits 0)
+      (values face i j (logxor bits (if (zerop (logand (cell-lsb id) #x1111111111111110)) 0 +swap-mask+))))))
+
+(defun cell-get-center-face-si-ti (id)
+  (multiple-value-bind (face i j orient) (cell-to-face-ij-orientation id)
+    (declare (ignore orient))
+    (let ((delta (if (cell-is-leaf id) 1 (if (zerop (logand 1 (logxor i (ash id -2)))) 0 2))))
+      (values face (+ delta (* 2 i)) (+ delta (* 2 j))))))
+
+(defun face-si-ti-to-xyz (face si ti)
+  (face-uv-ti-xyz face
+                  (st-to-uv (si-ti-to-st si))
+                  (st-to-uv (si-ti-to-st ti))))
+
+(defun face-uv-ti-xyz (face u v)
+  (declare (type double-float u v))
+  (ecase face
+    (0 (make-point :x 1d0 :y u :z v))
+    (1 (make-point :x (- u) :y 1d0 :z v))
+    (2 (make-point :x (- u) :y (- v) :z 1d0))
+    (3 (make-point :x -1d0 :y (- v) :z (- u)))
+    (4 (make-point :x v :y -1d0 :z (- u)))
+    (5 (make-point :x v :y u :z -1d0))))
+
+(defun si-ti-to-st (si)
+  (assert (<= si +max-si-ti+))
+  (* si (/ 1d0 +max-si-ti+)))
+
+(defun cell-to-point-raw (id)
+  (apply #'face-si-ti-to-xyz (multiple-value-list (cell-get-center-face-si-ti id))))
+
+(defun find-lsb-set (num)
+  (loop for i upto 63 when (logbitp i num) return i))
+
+(defun find-msb-set (num)
+  (loop for i from 63 downto 0 when (logbitp i num) return i))
+
+(defun lsb-for-level (level)
+  (ash 1 (* 2 (- +max-level+ level))))
+
+(defun cell-face (id)
+  (ash id (- +pos-bits+)))
+
+(defun cell-lsb (id)
+  (logand id (1+ (lognot id))))
+
+(defun cell-level (id)
+  (assert (not (zerop id)))
+  (- +max-level+ (ash (find-lsb-set id) -1)))
+
+(defun cell-pos (id)
+  (logand id (lognot 0)))
+
+(defun cell-is-valid (id)
+  (and (< (cell-face id) +num-faces+)
+       (not (zerop (logand (cell-lsb id) #x1555555555555555)))))
+
+(defun cell-child-position (id &optional level)
+  (unless level (setf level (cell-level id)))
+  (assert (cell-is-valid id))
+  (assert (>= level 1))
+  (assert (<= level (cell-level id)))
+  (logand 3 (ash id (- (1+ (* 2 (- +max-level+ level)))))))
+
+(defun cell-range-min (id)
+  (- id (1- (cell-lsb id)) ))
+(defun cell-range-max (id)
+  (+ id (1- (cell-lsb id))))
+(defun cell-is-leaf (id)
+  (not (zerop (logand id 1))))
+(defun cell-is-face (id)
+  (zerop (logand id (1- (lsb-for-level 0)))))
+
+(defun cell-parent (id &optional level)
+  (assert (cell-is-valid id))
+  (if level (progn
+              (assert (>= level 0))
+              (assert (<= level (cell-level id))))
+      (progn (assert (not (cell-is-face id)))))
+  (let ((new-lsb (if level (lsb-for-level level) (ash (cell-lsb id) 2))))
+    (logior new-lsb (logand id (1+ (lognot new-lsb))))))
+
+(defun cell-child (id pos)
+  (assert (cell-is-valid id))
+  (assert (not (cell-is-leaf id)))
+  (+ id (* (+ (* 2 pos) 1 -4) (ash (cell-lsb id) -2))))
+
+(defun cell-to-string (id)
+  (format nil "~a/~{~a~}" (cell-face id)
+          (loop for level from 1 to (cell-level id)
+             collect (cell-child-position id level))))
+
+;;;;;;;;;
+;;;
+(defun make-span (vector offset &optional size)
+  (declare (type vector vector))
+  (let ((length (length vector)))
+    (assert (< offset length))
+    (when size (assert (< (+ offset size) length)))
+    (make-array (if size size (- length offset))
+                :element-type (or (cadr (type-of vector)) t)
+                :displaced-to vector
+                :displaced-index-offset offset)))
+
+(deftype byte-vector () `(vector (unsigned-byte 8)))
+
+(defun make-encoder (size)
+  (make-array size :element-type '(unsigned-byte 8) :fill-pointer 0 :adjustable t))
+
+(defun encoder-avail (encoder)
+  (declare (type byte-vector encoder))
+  (- (array-total-size encoder)
+     (fill-pointer encoder)))
+
+(defun encoder-ensure (encoder size)
+  (declare (type byte-vector encoder))
+  (when (< (encoder-avail encoder) size)
+    (adjust-array encoder (+ (fill-pointer encoder) size))))
+
+(defun encoder-put8 (encoder value)
+  (declare (type byte-vector encoder)
+           (type (unsigned-byte 8) value))
+  (assert (> (encoder-avail encoder) 1))
+  (vector-push value encoder)
+  encoder)
+
+(defun encoder-putn (encoder vector)
+  (declare (type byte-vector encoder)
+           (type byte-vector vector))
+  (loop for value across vector do (vector-push value encoder))
+  encoder)
+
+(defun encoder-length (encoder)
+  (declare (type byte-vector encoder))
+  (fill-pointer encoder))
+
+(defparameter +varint-max32+ 5 "Maximum varint encoding length for uint32")
+(defun encoder-put-varint32 (encoder v)
+  (declare (type byte-vector encoder)
+           (type (unsigned-byte 32) v))
+  (let ((b 128))
+    (cond
+      ((< v (ash 1 7)) (encoder-put8 encoder v))
+      ((< v (ash 1 14))
+       (encoder-put8 encoder (logand 255 (logior v b)))
+       (encoder-put8 encoder (logand 255 (ash v -7))))
+      ((< v (ash 1 21))
+       (encoder-put8 encoder (logand 255 (logior v b)))
+       (encoder-put8 encoder (logand 255 (logior (ash v -7) b)))
+       (encoder-put8 encoder (logand 255 (ash v -14))))
+      ((< v (ash 1 28))
+       (encoder-put8 encoder (logand 255 (logior v b)))
+       (encoder-put8 encoder (logand 255 (logior (ash v -7) b)))
+       (encoder-put8 encoder (logand 255 (logior (ash v -14) b)))
+       (encoder-put8 encoder (logand 255 (ash v -21))))
+      (t
+       (encoder-put8 encoder (logand 255 (logior v b)))
+       (encoder-put8 encoder (logand 255 (logior (ash v -7) b)))
+       (encoder-put8 encoder (logand 255 (logior (ash v -14) b)))
+       (encoder-put8 encoder (logand 255 (logior (ash v -21) b)))
+       (encoder-put8 encoder (logand 255 (ash v -28))))))
+  encoder)
+
+(defparameter +varint-max64+ 10 "Maximum varint encoding length for uint64")
+(defun encoder-put-varint64 (encoder v)
+  (declare (type byte-vector encoder)
+           (type (unsigned-byte 64) v))
+  (if (< v (ash 1 28))
+      (encoder-put-varint32 encoder v)
+      (let ((x32 (logand (1- (ash 1 32)) (logior v (ash 1 7) (ash 1 21))))
+            (y32 (logand (1- (ash 1 32)) (logior v (ash 1 14) (ash 1 28)))))
+        (encoder-put8 encoder (logand 255 x32))
+        (encoder-put8 encoder (logand 255 (ash y32 -7)))
+        (encoder-put8 encoder (logand 255 (ash x32 -14)))
+        (encoder-put8 encoder (logand 255 (ash y32 -21)))
+        (if (< v (ash 1 35))
+            (encoder-put8 encoder (logand 255 (ash v -28)))
+            (progn
+              (encoder-put8 encoder (logand 255 (logior (ash v -28) (ash 1 7))))
+              (encoder-put-varint32 encoder (ash v -35)))))))
+
+;;; decoder ;;;
+(defun make-decoder (size &key (fill-pointer 0) initial-contents initial-element displaced-to)
+  (apply #'make-array size
+         :element-type '(unsigned-byte 8)
+         :fill-pointer fill-pointer
+         (append
+          (when initial-contents `(:initial-contents ,initial-contents))
+          (when initial-element `(:initial-element ,initial-element))
+          (when displaced-to `(:displaced-to ,displaced-to :displaced-index-offset ,(fill-pointer displaced-to))))))
+
+(defun decoder-avail (decoder)
+  (declare (type byte-vector decoder))
+  (- (array-total-size decoder)
+     (fill-pointer decoder)))
+
+(defun decoder-skip (decoder &optional (count 1))
+  (declare (type byte-vector decoder)
+           (type (unsigned-byte 32) count))
+  (incf (fill-pointer decoder) count))
+
+(defun decoder-reset (decoder)
+  (declare (type byte-vector decoder))
+  (setf (fill-pointer decoder) 0)
+  decoder)
+
+(defun make-sub-decoder (decoder size &optional will-decode)
+  (when (>= (decoder-avail decoder) size)
+    (prog1 (make-decoder size :fill-pointer (if will-decode 0 size) :displaced-to decoder)
+      (decoder-skip decoder size))))
+
+(defmacro with-decoder-reset ((decoder &optional (offset 0)) &body body)
+  (let ((fp (gensym "FP"))
+        (dc (gensym "DC")))
+    `(let* ((,dc ,decoder)
+            (,fp (fill-pointer ,dc)))
+       (unwind-protect
+            (progn
+              (setf (fill-pointer ,dc) ,offset)
+              ,@body)
+         (setf (fill-pointer ,dc) ,fp)))))
+
+(defun decoder-get8 (decoder)
+  (declare (type byte-vector decoder))
+  (prog1 (aref decoder (fill-pointer decoder))
+    (decoder-skip decoder)))
+
+(defun decoder-peek (decoder &optional (offset 0))
+  (declare (type byte-vector decoder)
+           (type (unsigned-byte 32) offset))
+  (aref decoder (+ (fill-pointer decoder) offset)))
+
+(defun decoder-get-varint64 (decoder)
+  (declare (type byte-vector decoder))
+  (loop
+     for b = (decoder-get8 decoder) then (decoder-get8 decoder)
+     for i from 0
+     with result = 0
+     do (incf result (ash (if (zerop i) b (1- b)) (* i 7)))
+     until (< b 128)
+     finally (return result)))
+
+;;;
+;;; encoded-uint-vector ;;;
+;;;
+(defun encode-uint-with-length (value length encoder)
+  (declare (type integer value)
+           (type (integer 0 8) length)
+           (type byte-vector encoder))
+  (assert (>= (encoder-avail encoder) length))
+  (loop repeat length
+     do (encoder-put8 encoder (logand value 255))
+     do (setf value (ash value -8)))
+  (assert (zerop value))
+  (values))
+
+(defun get-uint-with-length (decoder length)
+  (declare (type byte-vector decoder)
+           (type (integer 0 8) length))
+  (let ((value 0))
+    (loop for i from (1- length) downto 0
+       do (setf value (+ (ash value 8)
+                         (decoder-peek decoder i))))
+    (decoder-skip decoder length)
+    value))
+
+(defun get-type-byte-size (v-type)
+  (values
+   (typecase v-type
+     (list (case (car v-type)
+             ((array simple-array vector) (get-type-byte-size (cadr v-type)))
+             ((unsigned-byte signed-byte) (ceiling (cadr v-type) 8))
+             (integer (when (cadr v-type) (ceiling (log (cadr v-type) 2) 8)))
+             (t nil)))
+     (symbol (when (eql v-type 'fixnum) 8))
+     (t nil))))
+
+(defun encode-uint-vector (v encoder)
+  (declare (type vector v)
+           (type byte-vector encoder))
+  (let ((length (1+ (ash (find-msb-set
+                          (loop
+                             for value across v
+                             with bits = 1
+                             do (setf bits (logior bits value))
+                             finally (return bits)))
+                         -3))))
+    (assert (<= 1 length 8))
+    (encoder-ensure encoder (+ (* (length v) length)
+                               +varint-max64+))
+    (encoder-put-varint64 encoder
+                          (logior (* (length v) (get-type-byte-size (type-of v)))
+                                  (1- length)))
+    (loop for value across v
+       do (encode-uint-with-length value length encoder))
+    encoder))
+
+(defstruct encoded-uint-vector
+  (size 0 :type (unsigned-byte 32))
+  (length 1 :type (integer 1 8))
+  (bytes 8 :type (member 1 2 4 8))
+  (data nil :type byte-vector))
+
+(defun encoded-uint-vector-init (decoder &optional (bytes 8))
+  (declare (type byte-vector decoder)
+           (type (member 1 2 4 8) bytes))
+  (let ((size-len (decoder-get-varint64 decoder)))
+    (when size-len
+      (let* ((size (floor size-len bytes))
+             (length (1+ (logand size-len (1- bytes))))
+             (bytes-length (* size length))
+             (data (make-sub-decoder decoder bytes-length)))
+        (when data
+          (make-encoded-uint-vector :size size :length length :bytes bytes
+                                    :data data))))))
+
+(defun encoded-uint-vector-get (euv pos)
+  (declare (type encoded-uint-vector euv)
+           (type (unsigned-byte 32) pos))
+  (with-slots (size data length) euv
+    (assert (< pos size))
+    (with-decoder-reset (data (* pos length))
+      (get-uint-with-length data length))))
+
+(defun encoded-uint-vector-decode (euv)
+  (declare (type encoded-uint-vector euv))
+  (let* ((size (encoded-uint-vector-size euv))
+         (result (make-array size :element-type '(unsigned-byte 64))))
+    (dotimes (i size result)
+      (setf (aref result i) (encoded-uint-vector-get euv i)))))
+
+;; encoded-string-vector
+(defstruct string-vector-encoder
+  (offsets (make-array 0 :element-type '(unsigned-byte 64) :adjustable t :fill-pointer 0)
+           :type (vector (unsigned-byte 64)))
+  (data (make-encoder 0) :type byte-vector))
+
+(defun string-vector-encoder-add-via-encoder (sve)
+  (declare (type string-vector-encoder sve))
+  (with-slots (offsets data) sve
+    (vector-push-extend (length data) offsets)
+    data))
+
+(defun string-vector-encoder-size (sve)
+  (declare (type string-vector-encoder sve))
+  (length (string-vector-encoder-offsets sve)))
+
+(defun string-vector-encoder-encode (sve encoder)
+  (declare (type string-vector-encoder sve)
+           (type byte-vector encoder))
+  (with-slots (offsets data) sve
+    (vector-push-extend (length data) offsets)
+    (encode-uint-vector (make-span offsets 1) encoder)
+    (encoder-ensure encoder (encoder-length data))
+    (encoder-putn encoder data)
+    encoder))
+
+(defstruct encoded-string-vector
+  (offsets nil :type encoded-uint-vector)
+  (data nil :type byte-vector))
+
+(defun encoded-string-vector-init (decoder)
+  (declare (type byte-vector decoder))
+  (let ((offsets (encoded-uint-vector-init decoder 8)))
+    (when offsets
+      (let* ((size (encoded-uint-vector-size offsets))
+             (length (if (zerop size) 0 (encoded-uint-vector-get offsets (1- size))))
+             (data (make-sub-decoder decoder length)))
+        (when data
+          (make-encoded-string-vector :offsets offsets :data data))))))
+
+(defun encoded-string-vector-size (esv)
+  (declare (type encoded-string-vector esv))
+  (encoded-uint-vector-size (encoded-string-vector-offsets esv)))
+
+(defun encoded-string-vector-get (esv index &optional fill-pointer)
+  (declare (type encoded-string-vector esv)
+           (type (unsigned-byte 32) index))
+  (with-slots (offsets data) esv
+      (let* ((start (if (zerop index) 0 (encoded-uint-vector-get offsets (1- index))))
+             (length (- (encoded-uint-vector-get offsets index) start)))
+        (with-decoder-reset (data start)
+          (make-decoder length :displaced-to data :fill-pointer fill-pointer)))))
+
+(defun encoded-string-vector-decode (esv)
+  (declare (type encoded-string-vector esv))
+  (let* ((size (encoded-string-vector-size esv))
+         (result (make-array size :element-type '(vector (unsigned-byte 8)))))
+    (dotimes (i size result)
+      (setf (aref result i) (encoded-string-vector-get esv i)))))
+
+;; encoded-cell-id-vector
+(defstruct encoded-cell-id-vector
+  (deltas nil :type encoded-uint-vector)
+  (base 0 :type (unsigned-byte 64))
+  (shift 0 :type (unsigned-byte 8)))
+
+(defun encoded-cell-id-vector-size (ecv)
+  (declare (type encoded-cell-id-vector ecv))
+  (with-slots (deltas) ecv
+    (when deltas
+      (encoded-uint-vector-size deltas))))
+
+(defun encoded-cell-id-vector-get (ecv i)
+  (declare (type encoded-cell-id-vector ecv)
+           (type (unsigned-byte 32) i))
+  (with-slots (deltas base shift) ecv
+    (+ base
+       (ash (encoded-uint-vector-get deltas i) shift))))
+
+(defun encoded-cell-id-vector-init (decoder)
+  (declare (type byte-vector decoder))
+  (when (>= (decoder-avail decoder) 2)
+    (let* ((code+len (decoder-get8 decoder))
+           (shift-code (ash code+len -3)))
+      (when (= shift-code 31)
+        (setf shift-code (+ 29 (decoder-get8 decoder))))
+      (let* ((base-len (logand code+len 7))
+             (base (get-uint-with-length decoder base-len))
+             shift)
+        (when base
+          (setf base (ash base (- 64 (* 8 (max 1 base-len)))))
+          (if (>= shift-code 29)
+              (setf shift (1+ (* 2 (- shift-code 29)))
+                    base (logior base (ash 1 (1- shift))))
+              (setf shift (* 2 shift-code)))
+          (make-encoded-cell-id-vector
+           :deltas (encoded-uint-vector-init decoder 8)
+           :base base
+           :shift shift))))))
+
+(defun encoded-cell-id-vector-decode (eciv)
+  (declare (type encoded-cell-id-vector eciv))
+  (let* ((size (encoded-cell-id-vector-size eciv))
+         (result (make-array size :element-type '(unsigned-byte 64))))
+    (dotimes (i size result)
+      (setf (aref result i) (encoded-cell-id-vector-get eciv i)))))
+
+(defun encode-cell-id-vector (v encoder)
+  (declare (type (vector (unsigned-byte 64)) v)
+           (type byte-vector encoder))
+  (destructuring-bind (v-or v-and v-min v-max)
+      (loop for cell-id across v
+         with v-or = 0
+         with v-and = -1
+         do (setf v-or (logior v-or cell-id)
+                  v-and (logand v-and cell-id))
+         maximizing cell-id into v-max
+         minimizing cell-id into v-min
+         finally (return (list v-or v-and v-min v-max)))
+    (let ((e-base 0)
+          (e-base-len 0)
+          (e-shift 0)
+          (e-max-delta-msb 0))
+      (when (> v-or 0)
+        (setf e-shift (min 56 (dpb 0 (byte 1 0) (find-lsb-set v-or))))
+        (unless (zerop (logand v-and (ash 1 e-shift)))
+          (incf e-shift))
+        (let ((e-bytes (1- (ash 1 65))))
+          (dotimes (len 8)
+            (let* ((t-base (mask-field (byte (* 8 len) (- 64 (* 8 len))) v-min))
+                   (t-max-delta-msb (max 0 (1- (integer-length (ash (- v-max t-base)
+                                                                    (- e-shift))))))
+                   (t-bytes (+ len (* (length v) (1+ (ash t-max-delta-msb -3))))))
+              (when (< t-bytes e-bytes)
+                (setf e-base t-base
+                      e-base-len len
+                      e-max-delta-msb t-max-delta-msb
+                      e-bytes t-bytes)))))
+        (when (and (logbitp 0 e-shift)
+                   (not (= (logand e-max-delta-msb 7) 7)))
+          (decf e-shift)))
+      (assert (<= e-base-len 7))
+      (assert (<= e-shift 56))
+      (encoder-ensure encoder (+ 2 e-base-len))
+
+      (let ((shift-code (ash e-shift -1)))
+        (when (logbitp 0 e-shift)
+          (setf shift-code (min 31 (+ shift-code 29))))
+        (encoder-put8 encoder (logior (ash shift-code 3)
+                                      e-base-len))
+        (when (= shift-code 31)
+          (encoder-put8 encoder (ash e-shift -1))))
+
+      (encode-uint-with-length
+       (ash e-base (- (- 64 (* 8 (max 1 e-base-len))))) e-base-len encoder)
+
+     (let ((deltas (make-array (length v) :element-type '(unsigned-byte 64))))
+        (loop for cell-id across v
+           for i from 0
+           do (setf (aref deltas i)
+                    (ash (- cell-id e-base) (- e-shift))))
+        (encode-uint-vector deltas encoder)))))
+
+;; encoded-point-vector
+(defstruct encoded-point-vector
+  (size 0 :type (unsigned-byte 32))
+  (blocks nil :type encoded-string-vector)
+  (base 0 :type (unsigned-byte 64))
+  (level 0 :type (unsigned-byte 8))
+  (have-exceptions nil :type boolean))
+
+(defstruct cell-point
+  (level 0 :type (unsigned-byte 8))
+  (face 0 :type (unsigned-byte 8))
+  (si 0 :type (unsigned-byte 32))
+  (ti 0 :type (unsigned-byte 32)))
+
+(defparameter +block-shift+ 4)
+(defparameter +block-size+ (ash 1 +block-shift+))
+
+(defparameter +exception+ -1)
+
+(defstruct block-code
+  (delta-bits 0 :type (signed-byte 32))
+  (offset-bits 0 :type (signed-byte 32))
+  (overlap-bits 0 :type (signed-byte 32)))
+
+(defun bit-mask (n)
+  (declare (type (integer 0 64) n))
+  (if (zerop n) 0
+      (dpb -1 (byte n 0) 0)))
+
+(defun max-bits-for-level (level)
+  (declare (type (integer 0 30) level))
+  (+ (* 2 level) 3))
+
+(defun base-shift (level base-bits)
+  (declare (type (integer 0 30) level)
+           (type (integer 0 64) base-bits))
+  (max 0 (- (max-bits-for-level level) base-bits)))
+
+(defun encode-point-vector-compact (points encoder)
+  (declare (type (vector point) points)
+           (type byte-vector encoder))
+  (multiple-value-bind (level cell-points)
+      (choose-best-level points)
+    (when (< level 0)
+      (return (encode-point-vector-fast points encoder)))
+    (multiple-value-bind (values have-exceptions) (convert-cells-to-values cell-points level)
+      (multiple-value-bind (base base-bits) (choose-base values level have-exceptions)
+        (let ((num-blocks (ash (+ (length values) +block-size+ -1) (- +block-shift+)))
+              (base-bytes (ash base-bits -3)))
+          (encoder-ensure encoder (+ 2 base-bytes))
+          (let ((last-block-count (- (length values) (* +block-size+ (1- num-blocks))))
+                (blocks (make-string-vector-encoder))
+                (exceptions (make-array 0 :element-type point :adjustable t)))
+            (assert (>= last-block-count 0))
+            (assert (<= last-block-count +block-size+))
+            (assert (<= base-bytes 7))
+            (assert (<= level 30))
+            (encoder-put8 (logior +encoded-point-vector-cell-ids+
+                                  (ash have-exceptions 3)
+                                  (ash (1- last-block-count) 4)))
+            (encoder-put8 (logior base-bytes
+                                  (ash level 3)))
+            (encode-uint-with-length (ash base (- (base-shift level base-bits))) base-bytes encoder)
+
+            (loop for i from 0 to (length values) step +block-size+
+               for block-size = (min +block-size+ (- (length values) i))
+               for code = (get-block-code values i block-size base have-exceptions)
+               do (let ((block (string-vector-encoder-add-via-encoder blocks))
+                        (offset-bytes (ash (block-code-offset-bits code) -3))
+                        (delta-nibbles (ash (block-code-delta-bits code) -2))
+                        (overlap-nibbles (ash (block-code-overlap-bits code) -2)))
+                    (encoder-ensure block (+ 1 offset-bytes (* delta-nibbles (ash +block-size+ -1))))
+                    (assert (<= (- offset-bytes overlap-nibbles) 7))
+                    (assert (<= overlap-nibbles 1))
+                    (assert (<= delta-nibbles 16))
+                    (encoder-put8 block (logior (- offset-bytes overlap-nibbles)
+                                                (ash overlap-nibbles 3)
+                                                (ash (1- delta-nibbles) 4)))
+
+                    (let ((offset (1- (ash 1 65)))
+                          (num-exceptions 0))
+                      (dotimes (i block-size)
+                        (let ((value (aref values (+ i j))))
+                          (if (equalp value +exception+)
+                              (incf num-exceptions)
+                              (progn
+                                (assert (>= value base))
+                                (setf offset (min offset (- value base)))))))
+                      (when (= num-exceptions block-size)
+                        (setf offset))
+
+                      (let ((offset-shift (- (block-code-delta-bits code)
+                                             (block-code-overlap-bits code))))
+                        (setf offset (logand offset (lognot (bit-mask offset-shift))))
+                        (assert (= (zerop offset) (zerop offset-bytes)))
+                        (when (> offset 0)
+                          (encode-uint-with-length (ash offset (- offset-shift)) offset-bytes block))
+
+                        (let ((delta-bytes (ash (1+ delta-nibbles) -1)))
+                          (setf (fill-pointer exceptions) 0)
+                          (dotimes (j block-size)
+                            (let ((delta 0)
+                                  (value (arerf values (+ i j))))
+                              (if (equalp value +exception+)
+                                  (progn
+                                    (setf delta (length exceptions))
+                                    (vector-push-extend (aref points (+ i j)) exceptions))
+                                  (progn
+                                    (assert (>= value (+ offset base)))
+                                    (setf delta (- value (+ offset base)))
+                                    (when have-exceptions
+                                      (assert (<= delta (- (1- (ash 1 65)) +block-size+)))
+                                      (incf delta +block-size+))))
+                              (assert (<= delta (bit-mask (block-code-delta-bits delta))))
+                              (when (and (logbitp delta-nibbles 0)
+                                         (logbitp j 0))
+                                ())
+                              )))
+                        ))))
+))))))