Permalink
Browse files

Initial commit

  • Loading branch information...
0 parents commit f3e3775f5c86485c1427b3e7fc6a8f32b02000fe @filonenko-mikhail committed May 24, 2011
Showing with 969 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +33 −0 README
  3. +23 −0 cl-ewkb.asd
  4. +483 −0 cl-ewkb/ewkb.lisp
  5. +137 −0 cl-ewkb/ieee-floats.lisp
  6. +12 −0 cl-ewkb/package.lisp
  7. +143 −0 examples/cl-opengl/main.lisp
  8. +137 −0 test/tests.lisp
1 .gitignore
@@ -0,0 +1 @@
+*.fasl
33 README
@@ -0,0 +1,33 @@
+
+cl-postgis - library for encoding/decoding to/from Well-Known Binary format. Also library supports PostGIS EWKB.
+
+DEPENDENCIES:
+ ieee-floats (built-in)
+ flexi-streams
+
+USING
+
+Library supports following PostGIS types:
+
+POINT
+LINSTRING
+POLYGON
+MULTIPOINT
+MULTILINESTRING
+MULTIPOLYGON
+GEOMETRYCOLLECTION
+
+Functions for decoding:
+
+(decode octets)
+Decode from wkb sequence
+(decode-from stream)
+Decode from wkb stream
+
+Functions for encoding:
+
+(encode object endianness)
+Encode object to vector
+
+(encode-to object stream endianness)
+Encode object to stream with endianness
23 cl-ewkb.asd
@@ -0,0 +1,23 @@
+(defpackage :cl-ewkb-system
+ (:use :common-lisp :asdf))
+
+(in-package :cl-ewkb-system)
+
+(defsystem :cl-ewkb
+ :version "0.1"
+ :maintainer "Michael Filonenko <filonenko.mikhail@gmail.com>"
+ :author "Michael Filonenko <filonenko.mikhail@gmail.com>"
+ :licence "MIT"
+ :description "cl-ewkb is a geospatial library, based on cl-wkb, that implements the OGC Well-Known Binary geographic geometry data model with PostGIS 3d, 4d extensions, and provides WKB and EWKB encoding and decoding functionality. cl-wkb author is J.P. Larocue."
+ :depends-on (:ieee-floats :sb-flexi-streams)
+ :components
+ ((:module :cl-ewkb
+ :components ((:file "ieee-floats")
+ (:file "package")
+ (:file "ewkb" :depends-on ("package"))))))
+
+(defsystem :cl-ewkb-tests
+ :depends-on (:cl-ewkb :postmodern)
+ :components
+ ((:module :cl-ewkb
+ :components ((:file "tests")))))
483 cl-ewkb/ewkb.lisp
@@ -0,0 +1,483 @@
+(in-package :cl-ewkb)
+;;;; -----------------------------------------------------
+;;;;
+;;;; PRIMITIVE TYPES: Integers.
+;;;;
+
+(deftype uint8 ()
+ '(unsigned-byte 8))
+(deftype strictly-encoded-uint8 ()
+ '(vector (unsigned-byte 8) 1))
+(deftype encoded-uint8 ()
+ '(or strictly-encoded-uint8 list))
+
+(deftype uint32 ()x
+ '(unsigned-byte 32))
+(deftype strictly-encoded-uint32 ()
+ '(vector (unsigned-byte 8) 4))
+(deftype encoded-uint32 ()
+ '(or strictly-encoded-uint32 list))
+
+(deftype uint64 ()
+ '(unsigned-byte 64))
+(deftype strictly-encoded-uint64 ()
+ '(vector (unsigned-byte 8) 8))
+(deftype encoded-uint64 ()
+ '(or strictly-encoded-uint64 list))
+
+;;; FIXME: eschew the bulk of the macro code in favor of more
+;;; functional-style code, with the macros serving as thin
+;;; syntactic-sugar.
+(defmacro define-stream-encoder (name seq-function)
+ (let ((value-var (gensym "VALUE-"))
+ (endianness-var (gensym "ENDIANNESS-"))
+ (buffer-var (gensym "BUFFER-"))
+ (stream-var (gensym "STREAM-")))
+ `(defun ,name (,value-var ,endianness-var ,stream-var)
+ (let ((,buffer-var (,seq-function ,value-var ,endianness-var)))
+ (write-sequence ,buffer-var ,stream-var)))))
+(defmacro define-stream-decoder (name seq-function data-size-octets)
+ (let ((endianness-var (gensym "ENDIANNESS-"))
+ (stream-var (gensym "STREAM-"))
+ (buffer-var (gensym "BUFFER-"))
+ (read-len-var (gensym "READ-LEN-")))
+ `(defun ,name (,endianness-var ,stream-var)
+ (let* ((,buffer-var (make-array ,data-size-octets :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ ;; FIXME: superfluous :END?
+ (,read-len-var (read-sequence ,buffer-var ,stream-var :end ,data-size-octets)))
+ (unless (= ,read-len-var ,data-size-octets)
+ (error "Expected ~D octet~:P, got only ~D." ,data-size-octets ,read-len-var))
+ (,seq-function ,buffer-var ,endianness-var)))))
+
+(eval-when (:compile-toplevel)
+ (let ((endiannesses `((:big-endian . ,(lambda (bit-offset bits)
+ (1- (/ (- bits bit-offset) 8))))
+ (:little-endian . ,(lambda (bit-offset bits)
+ (declare (ignore bits))
+ (/ bit-offset 8))))))
+ (defmacro def-uint-encoder (name bits lisp-type)
+ "Defines a function with the given NAME that encodes an integer
+of LISP-TYPE to a sequence of octets whose total number of bits equals
+BITS.
+
+The defined function takes two arguments: an integer, and an
+endianness designator: :BIG-ENDIAN or :LITTLE-ENDIAN."
+ (unless (and (plusp bits)
+ (zerop (mod bits 8)))
+ (error "Can't define ~S: number of bits ~S must be positive and divisible by 8."
+ name bits))
+ (let ((int-var (gensym "INT-"))
+ (endianness-var (gensym "ENDIANNESS-"))
+ (out-var (gensym))
+ (octets (/ bits 8)))
+ `(defun ,name (,int-var ,endianness-var)
+ (declare (type ,lisp-type ,int-var)
+ (type symbol ,endianness-var))
+ (let ((,out-var (make-array '(,octets) :element-type '(unsigned-byte 8) :initial-element 0)))
+ (ecase ,endianness-var
+ ,@(loop for (endianness . octet-offset-fn) in endiannesses
+ collecting `(,endianness
+ ,@(loop for bit-offset from 0 below bits by 8
+ for octet-offset = (funcall octet-offset-fn bit-offset bits)
+ collecting `(setf (elt ,out-var ,octet-offset)
+ (ldb (byte 8 ,bit-offset) ,int-var))))))
+ ,out-var))))
+ (defmacro def-uint-decoder (name bits lisp-type)
+ (unless (and (plusp bits)
+ (zerop (mod bits 8)))
+ (error "Can't define ~S: invalid number of bits ~S." name bits))
+ (let ((octets-var (gensym "OCTETS-"))
+ (endianness-var (gensym "ENDIANNESS-"))
+ (out-var (gensym))
+ (octets (/ bits 8)))
+ `(defun ,name (,octets-var ,endianness-var)
+ (declare (type (or (vector (unsigned-byte 8) ,octets)
+ list)
+ ,octets-var)
+ (type symbol ,endianness-var))
+ (let ((,out-var (the ,lisp-type 0)))
+ (declare (type ,lisp-type ,out-var))
+ (ecase ,endianness-var
+ ,@(loop for (endianness . octet-offset-fn) in endiannesses
+ collecting `(,endianness
+ ,@(loop for bit-offset from 0 below bits by 8
+ for octet-offset = (funcall octet-offset-fn bit-offset bits)
+ collecting `(setf (ldb (byte 8 ,bit-offset) ,out-var)
+ (elt ,octets-var ,octet-offset))))))
+ ,out-var))))))
+
+(def-uint-encoder encode-uint8 8 uint8)
+(define-stream-encoder encode-uint8-to encode-uint8)
+(def-uint-decoder decode-uint8 8 uint8)
+(define-stream-decoder decode-uint8-from decode-uint8 1)
+
+(def-uint-encoder encode-uint32 32 uint32)
+(define-stream-encoder encode-uint32-to encode-uint32)
+(def-uint-decoder decode-uint32 32 uint32)
+(define-stream-decoder decode-uint32-from decode-uint32 4)
+
+(def-uint-encoder encode-uint64 64 uint64)
+(define-stream-encoder encode-uint64-to encode-uint64)
+(def-uint-decoder decode-uint64 64 uint64)
+(define-stream-decoder decode-uint64-from decode-uint64 8)
+
+;;;;
+;;;; PRIMITIVE TYPES: Floating-point numbers.
+;;;;
+
+;;; For the sake of "efficiency," we're going to go out on a limb here
+;;; and say this Lisp uses IEEE-754 internally, and that if a Lisp
+;;; float type passes the most-negative / most-negative-normalized /
+;;; most-positive tests for a double-precision 64-bit float, there
+;;; will be no loss in precision in trying to express a
+;;; double-precision 64-bit float in that Lisp float type.
+;;;
+;;; This hack returns 'DOUBLE-FLOAT on SBCL x86_64.
+(deftype ieee754-double ()
+ (let* ((least-positive-64bit-float (expt 2 -1074))
+ (least-negative-64bit-float (- least-positive-64bit-float))
+ (least-positive-normalized-64bit-float (expt 2 -1022))
+ (least-negative-normalized-64bit-float (- least-positive-normalized-64bit-float))
+ (most-negative-64bit-float (* (1- (expt 1/2 53))
+ (expt 2 1024)))
+ (most-positive-64bit-float (- most-negative-64bit-float)))
+ (flet ((cl-sym (&rest args)
+ (intern (apply #'concatenate 'string args)
+ :common-lisp)))
+ (loop ;; FIXME: CLISP 2.41 stack-overflows when taking the
+ ;; rational of any of the six extreme long-float
+ ;; constants.
+ for type-abbr in '("SHORT" "SINGLE" "DOUBLE" #-CLISP "LONG")
+ for type = (cl-sym type-abbr "-FLOAT")
+ for type-name = (symbol-name type)
+ ;; FIXME: CLISP 2.41 fails X3J13 issue
+ ;; CONTAGION-ON-NUMERICAL-COMPARISONS (see CLHS 12.1.4.1).
+ ;; When that bug is fixed, replace RATIONAL calls below
+ ;; with their arguments.
+ for least-positive = (rational (symbol-value (cl-sym "LEAST-POSITIVE-" type-name)))
+ for least-negative = (rational (symbol-value (cl-sym "LEAST-NEGATIVE-" type-name)))
+ for least-positive-normalized = (rational (symbol-value (cl-sym "LEAST-POSITIVE-NORMALIZED-" type-name)))
+ for least-negative-normalized = (rational (symbol-value (cl-sym "LEAST-NEGATIVE-NORMALIZED-" type-name)))
+ for most-positive = (rational (symbol-value (cl-sym "MOST-POSITIVE-" type-name)))
+ for most-negative = (rational (symbol-value (cl-sym "MOST-NEGATIVE-" type-name)))
+ when (and (<= least-positive least-positive-64bit-float)
+ (>= least-negative least-negative-64bit-float)
+ (<= least-positive-normalized least-positive-normalized-64bit-float)
+ (>= least-negative-normalized least-negative-normalized-64bit-float)
+ (>= most-positive most-positive-64bit-float)
+ (<= most-negative most-negative-64bit-float))
+ return type
+ finally (return 'rational)))))
+(deftype strictly-encoded-ieee754-double ()
+ '(vector (unsigned-byte 8) 8))
+(deftype encoded-ieee754-double ()
+ '(or strictly-encoded-ieee754-double list))
+
+(defun encode-ieee754-double (float endianness)
+ (declare (type ieee754-double float)
+ (type symbol endianness))
+ (the strictly-encoded-ieee754-double
+ (encode-uint64 (ieee-floats:encode-float64 float) endianness)))
+(define-stream-encoder encode-ieee754-double-to encode-ieee754-double)
+(defun decode-ieee754-double (octets endianness)
+ (declare (type encoded-ieee754-double octets)
+ (type symbol endianness))
+ (the ieee754-double
+ (ieee-floats:decode-float64 (decode-uint64 octets endianness))))
+(define-stream-decoder decode-ieee754-double-from decode-ieee754-double 8)
+
+;;;;
+;;;; API and COMMON PROCEDURES.
+;;;;
+
+;; (defmacro simple-defstruct-and-export (structure specials &rest members)
+;; "Define a structure STRUCT with members MEMBERS and export the
+;; standard functions created. SPECIALS is a list of extra parameters eg
+;; ((:print-function pf)). Note double parentheses."
+;; (append
+;; `(progn
+;; ,(append `(defstruct ,(append `(,structure) specials)) members)
+;; ,`(export ,`(quote ,(intern (concatenate 'string "MAKE-" (symbol-name structure)))))
+;; ,`(export ,`(quote ,(intern (concatenate 'string "COPY-" (symbol-name structure))))))
+;; (mapcar
+;; #'(lambda (member)
+;; `(export ,`(quote ,(intern (concatenate 'string(symbol-namestructure) "-" (symbol-name member))))))
+;; members)))
+
+
+(defmacro defstruct-and-export (structure &rest members)
+ "Define a structure STRUCT with members MEMBERS and export the
+ standard functions created. SPECIALS is a list of extra parameters eg
+ ((:print-function pf)). Note double parentheses."
+ (append
+ `(progn
+ ,(if (not (null members))
+ (if (stringp (car members))
+ `(defstruct ,structure ,(car members) ,@(cdr members))
+ `(defstruct ,structure ,@members))
+ `(defstruct ,structure))
+ ,`(export ,`(quote ,(intern (concatenate 'string "MAKE-" (symbol-name (car structure))))))
+ ,`(export ,`(quote ,(intern (concatenate 'string "COPY-" (symbol-name (car structure)))))))
+ (if (not (null members))
+ (if (stringp (car members))
+ (mapcar #'(lambda (member)
+ `(export ,`(quote ,(intern (concatenate 'string (symbol-name (car structure)) "-" (symbol-name (car member))))))) (cdr members))
+ (mapcar #'(lambda (member)
+ `(export ,`(quote ,(intern (concatenate 'string (symbol-name (car structure)) "-" (symbol-name (car member))))))) members)))
+ (if (find :named structure)
+ `((export ,`(quote ,(intern (concatenate 'string (symbol-name (car structure)) "-P" ))))
+ (deftype ,(intern (symbol-name (car structure))) () '(satisfies ,(intern (concatenate 'string (symbol-name (car structure)) "-P" ))))
+ ))))
+
+(defstruct-and-export (point-primitive (:type vector)
+ :named
+ (:constructor make-point-primitive (x y)))
+ "2d point data - struct contains x y coordinates."
+ (x 0.0d0 :type ieee754-double)
+ (y 0.0d0 :type ieee754-double))
+
+
+(defstruct-and-export (pointz-primitive (:type vector)
+ :named
+ (:include point-primitive)
+ (:constructor make-pointz-primitive (x y z)))
+ "3dz point data - struct contains x y z coordinates."
+ (z 0.0d0 :type ieee754-double))
+
+(defstruct-and-export (pointm-primitive (:type vector)
+ :named
+ (:include point-primitive)
+ (:constructor make-pointm-primitive (x y m)))
+ "3dm point data - struct contains x y m coordinates."
+ (m 0.0d0 :type ieee754-double))
+
+(defstruct-and-export (pointzm-primitive (:type vector)
+ :named
+ (:include pointz-primitive)
+ (:constructor make-pointzm-primitive (x y z m)))
+ "4d point data - struct contains x y z m coordinates."
+ (m 0.0d0 :type ieee754-double))
+
+(defstruct-and-export (linear-ring (:type vector)
+ :named
+ (:constructor make-linear-ring (points)))
+ (points nil :type vector))
+
+(defstruct-and-export (gisgeometry (:type vector)
+ :named
+ (:constructor make-gisgeometry (type srid object)))
+ (type 0 :type uint32)
+ (srid 0 :type uint32)
+ (object))
+
+(defstruct-and-export (point (:type vector)
+ :named
+ (:include gisgeometry)
+ (:constructor make-point (type srid object))))
+
+(defstruct-and-export (linestring (:type vector)
+ :named
+ (:include gisgeometry)
+ (:constructor make-linestring (type srid object))))
+
+(defstruct-and-export (polygon (:type vector)
+ :named
+ (:include gisgeometry)
+ (:constructor make-polygon (type srid object))))
+
+(defstruct-and-export (multipoint (:type vector)
+ :named
+ (:include gisgeometry)
+ (:constructor make-multipoint (type srid object))))
+
+(defstruct-and-export (multilinestring (:type vector)
+ :named
+ (:include gisgeometry)
+ (:constructor make-multilinestring (type srid object))))
+
+(defstruct-and-export (multipolygon (:type vector)
+ :named
+ (:include gisgeometry)
+ (:constructor make-multipolygon (type srid object))))
+
+
+
+;;; FIXME: document these functions.
+(defparameter +endiannesses+
+ '((0 . :big-endian)
+ (1 . :little-endian)))
+
+(defparameter +wkb-z+ #x80000000)
+(defparameter +wkb-m+ #x40000000)
+(defparameter +wkb-srid+ #x20000000)
+
+(defparameter +wkb-typemask+ #x0000000F)
+(defparameter +wkb-types+
+ '(
+ (1 . :point)
+ (2 . :linestring)
+ (3 . :polygon)
+ (4 . :multi-point)
+ (5 . :multi-linestring)
+ (6 . :multi-polygon)
+ (7 . :geometry-collection)))
+
+(defun dimension (type)
+ (if (zerop (logand +wkb-z+ type))
+ (if (zerop (logand +wkb-m+ type))
+ :2d
+ :3dm)
+ (if (zerop (logand +wkb-m+ type))
+ :3dz
+ :4d)))
+
+(defgeneric generic-decode-primitive-point (type in endianness)
+ (:documentation "Generic decode function for primitive point")
+ (:method ((type (eql :2d)) in endianness)
+ (make-point-primitive
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in))
+ )
+ (:method ((type (eql :3dm)) in endianness)
+ (make-pointm-primitive
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in))
+ )
+ (:method ((type (eql :3dz)) in endianness)
+ (make-pointz-primitive
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in))
+ )
+ (:method ((type (eql :4d)) in endianness)
+ (make-pointzm-primitive
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in)
+ (decode-ieee754-double-from endianness in))
+ ))
+
+(defun decode-primitive-point (in type endianness)
+ (generic-decode-primitive-point (dimension type) in endianness))
+
+(defun decode-llinear-ring (in type endianness)
+ (let ((data (make-array 0 :fill-pointer 0 :element-type 'vector :adjustable T)))
+ (dotimes (i (decode-uint32-from endianness in))
+ (vector-push-extend (decode-primitive-point in type endianness) data))
+ (make-linear-ring data)))
+
+(defun decode-from (in)
+ "Function to decode geoobject from WKB/EWKB representation from stream."
+ (let* ((endianness (cdr (assoc (decode-uint8-from :big-endian in) +endiannesses+ :test #'=)))
+ (type (decode-uint32-from endianness in))
+ (srid 0)
+ (data (make-array 0 :fill-pointer 0 :element-type 'vector :adjustable T)))
+ (unless (zerop (logand +wkb-srid+ type))
+ (setf srid (decode-uint32-from endianness in)))
+ (case (cdr (assoc (logand type +wkb-typemask+) +wkb-types+ :test #'=))
+ (:point
+ (make-point type srid (decode-primitive-point in type endianness)))
+ (:line-string
+ (make-linestring type srid (decode-llinear-ring in type endianness)))
+ (:polygon
+ (dotimes (i (decode-uint32-from endianness in))
+ (vector-push-extend (decode-linear-ring in type endianness) data))
+ (make-polygon type srid data))
+ (:multi-point
+ (dotimes (i (decode-uint32-from endianness in))
+ (vector-push-extend (decode-from in) data))
+ (make-multipoint type srid data))
+ (:multi-line-string
+ (dotimes (i (decode-uint32-from endianness in))
+ (vector-push-extend (decode-from in) data))
+ (make-multilinestring type srid data))
+ (:multi-polygon
+ (dotimes (i (decode-uint32-from endianness in))
+ (vector-push-extend (decode-from in) data))
+ (make-multipolygon type srid data))
+ (:geometry-collection
+ (dotimes (i (decode-uint32-from endianness in))
+ (vector-push-extend (decode-from in) data))
+ (make-gisgeometry type srid data))
+ )))
+
+(defun decode (octets)
+ "Function to decode geoobject from WKB/EWKB representation from sequence."
+ (flexi-streams:with-input-from-sequence (in octets)
+ (decode-from in)))
+
+(defgeneric generic-encode-primitive-point (type object out endianness)
+ (:documentation "Generic decode function for primitive point")
+ (:method ((type (eql :2d)) object out endianness)
+ (encode-ieee754-double-to (point-primitive-x object) endianness out)
+ (encode-ieee754-double-to (point-primitive-y object) endianness out))
+ (:method ((type (eql :3dm)) object out endianness)
+ (encode-ieee754-double-to (pointm-primitive-x object) endianness out)
+ (encode-ieee754-double-to (pointm-primitive-y object) endianness out)
+ (encode-ieee754-double-to (pointm-primitive-m object) endianness out))
+ (:method ((type (eql :3dz)) object out endianness)
+ (encode-ieee754-double-to (pointz-primitive-x object) endianness out)
+ (encode-ieee754-double-to (pointz-primitive-y object) endianness out)
+ (encode-ieee754-double-to (pointz-primitive-z object) endianness out))
+ (:method ((type (eql :4d)) object out endianness)
+ (encode-ieee754-double-to (pointzm-primitive-x object) endianness out)
+ (encode-ieee754-double-to (pointzm-primitive-y object) endianness out)
+ (encode-ieee754-double-to (pointzm-primitive-z object) endianness out)
+ (encode-ieee754-double-to (pointzm-primitive-m object) endianness out)
+ ))
+
+(defun encode-primitive-point (object out type endianness)
+ (generic-encode-primitive-point (dimension type) object out endianness))
+
+(defun encode-linear-ring (object out type endianness)
+ (encode-uint32-to (length (linear-ring-points object)) endianness out)
+ (map 'nil (lambda (point) (encode-primitive-point point out type endianness)) (linear-ring-points object)))
+
+(defun encode-to (object stream &optional (endianness :little-endian))
+"Function to encode geoobject to WKB/EWKB representation to binary stream. Endianness: :little-endian, :big-endian"
+ (encode-uint8-to (car (rassoc endianness +endiannesses+ :test #'equal)) :big-endian stream)
+ (let*
+ ((type (gisgeometry-type object))
+ (srid (gisgeometry-srid object)))
+ (encode-uint32-to type endianness stream)
+ (unless (zerop (logand +wkb-srid+ type))
+ (encode-uint32-to srid endianness stream))
+ (case (cdr (assoc (logand type +wkb-typemask+) +wkb-types+ :test #'=))
+ (:point
+ (encode-primitive-point (gisgeometry-object object) stream type endianness))
+ (:line-string
+ (encode-linear-ring (gisgeometry-object object) stream type endianness))
+ (:polygon
+ (encode-uint32-to (length (gisgeometry-object object)) endianness stream)
+ (map 'nil (lambda (line)
+ (encode-linear-ring line stream type endianness))
+ (gisgeometry-object object)))
+ (:multi-point
+ (encode-uint32-to (length (gisgeometry-object object)) endianness stream)
+ (map 'nil (lambda (object)
+ (encode-to object stream endianness))
+ (gisgeometry-object object)))
+ (:multi-line-string
+ (encode-uint32-to (length (gisgeometry-object object)) endianness stream)
+ (map 'nil (lambda (object)
+ (encode-to object stream endianness))
+ (gisgeometry-object object)))
+ (:multi-polygon
+ (encode-uint32-to (length (gisgeometry-object object)) endianness stream)
+ (map 'nil (lambda (object)
+ (encode-to object stream endianness))
+ (gisgeometry-object object)))
+ (:geometry-collection
+ (encode-uint32-to (length (gisgeometry-object object)) endianness stream)
+ (map 'nil (lambda (object)
+ (encode-to object stream endianness))
+ (gisgeometry-object object)))
+ )))
+
+(defun encode (object &optional (endianness :little-endian))
+ "Function to encode geoobject to WKB/EWKB representation to sequence. Endianness: :little-endian, :big-endian"
+ (flexi-streams:with-output-to-sequence (out)
+ (encode-to object out endianness)))
+
137 cl-ewkb/ieee-floats.lisp
@@ -0,0 +1,137 @@
+;;; Functions for converting floating point numbers represented in
+;;; IEEE 754 style to lisp numbers.
+;;;
+;;; See http://common-lisp.net/project/ieee-floats/
+
+(defpackage :ieee-floats
+ (:use :common-lisp)
+ (:export :make-float-converters
+ :encode-float32
+ :decode-float32
+ :encode-float64
+ :decode-float64))
+
+(in-package :ieee-floats)
+
+;; The following macro may look a bit overcomplicated to the casual
+;; reader. The main culprit is the fact that NaN and infinity can be
+;; optionally included, which adds a bunch of conditional parts.
+;;
+;; Assuming you already know more or less how floating point numbers
+;; are typically represented, I'll try to elaborate a bit on the more
+;; confusing parts, as marked by letters:
+;;
+;; (A) Exponents in IEEE floats are offset by half their range, for
+;; example with 8 exponent bits a number with exponent 2 has 129
+;; stored in its exponent field.
+;;
+;; (B) The maximum possible exponent is reserved for special cases
+;; (NaN, infinity).
+;;
+;; (C) If the exponent fits in the exponent-bits, we have to adjust
+;; the significand for the hidden bit. Because decode-float will
+;; return a significand between 0 and 1, and we want one between 1
+;; and 2 to be able to hide the hidden bit, we double it and then
+;; subtract one (the hidden bit) before converting it to integer
+;; representation (to adjust for this, 1 is subtracted from the
+;; exponent earlier). When the exponent is too small, we set it to
+;; zero (meaning no hidden bit, exponent of 1), and adjust the
+;; significand downward to compensate for this.
+;;
+;; (D) Here the hidden bit is added. When the exponent is 0, there is
+;; no hidden bit, and the exponent is interpreted as 1.
+;;
+;; (E) Here the exponent offset is subtracted, but also an extra
+;; factor to account for the fact that the bits stored in the
+;; significand are supposed to come after the 'decimal dot'.
+
+(defmacro make-float-converters (encoder-name
+ decoder-name
+ exponent-bits
+ significand-bits
+ support-nan-and-infinity-p)
+ "Writes an encoder and decoder function for floating point
+numbers with the given amount of exponent and significand
+bits (plus an extra sign bit). If support-nan-and-infinity-p is
+true, the decoders will also understand these special cases. NaN
+is represented as :not-a-number, and the infinities as
+:positive-infinity and :negative-infinity. Note that this means
+that the in- or output of these functions is not just floating
+point numbers anymore, but also keywords."
+ (let* ((total-bits (+ 1 exponent-bits significand-bits))
+ (exponent-offset (1- (expt 2 (1- exponent-bits)))) ; (A)
+ (sign-part `(ldb (byte 1 ,(1- total-bits)) bits))
+ (exponent-part `(ldb (byte ,exponent-bits ,significand-bits) bits))
+ (significand-part `(ldb (byte ,significand-bits 0) bits))
+ (nan support-nan-and-infinity-p)
+ (max-exponent (1- (expt 2 exponent-bits)))) ; (B)
+ `(progn
+ (defun ,encoder-name (float)
+ ,@(unless nan `((declare (type float float))))
+ (multiple-value-bind (sign significand exponent)
+ (cond ,@(when nan `(((eq float :not-a-number)
+ (values 0 1 ,max-exponent))
+ ((eq float :positive-infinity)
+ (values 0 0 ,max-exponent))
+ ((eq float :negative-infinity)
+ (values 1 0 ,max-exponent))))
+ ((zerop float)
+ (values 0 0 0))
+ (t
+ (multiple-value-bind (significand exponent sign) (decode-float float)
+ (let ((exponent (+ (1- exponent) ,exponent-offset))
+ (sign (if (= sign 1.0) 0 1)))
+ (unless (< exponent ,(expt 2 exponent-bits))
+ (error "Floating point overflow when encoding ~A." float))
+ (if (< exponent 0) ; (C)
+ (values sign (ash (round (* ,(expt 2 significand-bits) significand)) exponent) 0)
+ (values sign (round (* ,(expt 2 significand-bits) (1- (* significand 2)))) exponent))))))
+ (let ((bits 0))
+ (declare (type (unsigned-byte ,total-bits) bits))
+ (setf ,sign-part sign
+ ,exponent-part exponent
+ ,significand-part significand)
+ bits)))
+
+ (defun ,decoder-name (bits)
+ (declare (type (unsigned-byte ,total-bits) bits))
+ (let* ((sign ,sign-part)
+ (exponent ,exponent-part)
+ (significand ,significand-part))
+ ,@(when nan `((when (= exponent ,max-exponent)
+ (return-from ,decoder-name
+ (cond ((not (zerop significand)) :not-a-number)
+ ((zerop sign) :positive-infinity)
+ (t :negative-infinity))))))
+ (if (zerop exponent) ; (D)
+ (setf exponent 1)
+ (setf (ldb (byte 1 ,significand-bits) significand) 1))
+ (unless (zerop sign)
+ (setf significand (- significand)))
+ (scale-float (float significand ,(if (> total-bits 32) 1.0d0 1.0))
+ (- exponent ,(+ exponent-offset significand-bits)))))))) ; (E)
+
+;; And instances of the above for the common forms of floats.
+(make-float-converters encode-float32 decode-float32 8 23 nil)
+(make-float-converters encode-float64 decode-float64 11 52 nil)
+
+;;; Copyright (c) 2006 Marijn Haverbeke
+;;;
+;;; This software is provided 'as-is', without any express or implied
+;;; warranty. In no event will the authors be held liable for any
+;;; damages arising from the use of this software.
+;;;
+;;; Permission is granted to anyone to use this software for any
+;;; purpose, including commercial applications, and to alter it and
+;;; redistribute it freely, subject to the following restrictions:
+;;;
+;;; 1. The origin of this software must not be misrepresented; you must
+;;; not claim that you wrote the original software. If you use this
+;;; software in a product, an acknowledgment in the product
+;;; documentation would be appreciated but is not required.
+;;;
+;;; 2. Altered source versions must be plainly marked as such, and must
+;;; not be misrepresented as being the original software.
+;;;
+;;; 3. This notice may not be removed or altered from any source
+;;; distribution.
12 cl-ewkb/package.lisp
@@ -0,0 +1,12 @@
+(in-package :common-lisp-user)
+
+(defpackage :cl-ewkb
+ (:use :common-lisp :ieee-floats
+ :flexi-streams)
+ (:export #:encode
+ #:encode-to
+ #:decode
+ #:decode-from
+ ))
+
+(in-package :cl-ewkb)
143 examples/cl-opengl/main.lisp
@@ -0,0 +1,143 @@
+(require :asdf)
+
+(require :cl-opengl)
+(require :cl-glu)
+(require :cl-glut)
+
+(require :postmodern)
+(use-package :postmodern)
+
+(require :cl-ewkb)
+(use-package :cl-ewkb)
+
+;;--------------------------------------------------------
+
+(defun init-db ()
+ (if (not *database*)
+ (connect-toplevel "michael" "michael" "xxx" "localhost")))
+
+(defun draw-point-primitive (point)
+ (cond
+ ((point-primitive-p point)
+ (gl:vertex
+ (point-primitive-x point)
+ (point-primitive-y point)))
+ ((pointz-primitive-p point)
+ (gl:vertex
+ (point-primitive-x point)
+ (point-primitive-y point)
+ (pointz-primitive-z point)))
+ ((pointm-primitive-p point)
+ (gl:vertex
+ (point-primitive-x point)
+ (point-primitive-y point)
+ 0.0
+ (pointm-primitive-m point)))
+ ((pointzm-primitive-p point)
+ (gl:vertex
+ (point-primitive-x point)
+ (point-primitive-y point)
+ (pointz-primitive-z point)
+ (pointzm-primitive-m point)))))
+
+(defun draw-line-primitive (line)
+ (map 'nil (lambda (point) (draw-point-primitive point))
+ (line-primitive-points line)))
+
+(defun draw-single-point (point)
+ (draw-point-primitive (gisgeometry-object point)))
+
+(defun draw-point (point)
+ (gl:with-primitives :points
+ (draw-point-primitive (gisgeometry-object point))))
+
+(defun draw-linestring (line)
+ (gl:with-primitives :line-strip
+ (draw-line-primitive (gisgeometry-object line))))
+
+(defun draw-polygon (polygon)
+ "Draw only first line of polygon"
+ (gl:with-primitives :polygon
+ (draw-line-primitive (elt (gisgeometry-object polygon) 0))))
+
+(defun draw-multipoint (points)
+ (gl:with-primitive :points
+ (map 'nil (lambda (point) (draw-single-point point)) (gisgeometry-object points))))
+
+(defun draw-multilinestring (lines)
+ (map 'nil (lambda (line)
+ (draw-linestring line))
+ (gisgeometry-object lines)))
+
+(defun draw-multipolygon (polygons)
+ (map 'nil (lambda (polygon)
+ (draw-polygon polygon))
+ (gisgeometry-object polygons)))
+
+(defun draw-gisobject (object)
+ (cond
+ ((point-p object) (draw-point object))
+ ((linestring-p object) (draw-linestring object))
+ ((polygon-p object) (draw-polygon object))
+ ((multipoint-p object) (draw-multipoint object))
+ ((multilinestring-p object) (draw-multilinestring object))
+ ((multipolygon-p object) (draw-multipolygon object))
+ ((gisgeometry-p object) (draw-geometrycollection object))))
+
+(defun draw-geometrycollection (geometries)
+ (map 'nil (lambda (object)
+ (draw-gisobject object))
+ (gisgeometry-object geometries)))
+
+
+(cffi:defcallback key :void ((key :uchar) (x :int) (y :int))
+ (case (code-char key)
+ (#\Esc (glut:leave-main-loop))
+ (#\q (glut:leave-main-loop))
+ (#\r (glut:post-redisplay))))
+
+(cffi:defcallback draw :void ()
+ (gl:clear :color-buffer)
+
+ ;; Letter P
+ (dolist (row (query
+ (:select
+ (:raw "unnest(ARRAY[ST_AsBinary(ST_AsEWKB('GEOMETRYCOLLECTION(LINESTRING(-100 0 0, 100 0 0), LINESTRING(0 -100 0, 0 100 0), LINESTRING(0 0 -100, 0 0 100))'))
+-- Letter O
+,ST_AsBinary(ST_AsEWKB('LINESTRING(3.5 0, 2.2 1, 3 3, 4.2 5, 5.2 3, 4.5 1, 3.5 0)'))
+-- letter S
+,ST_AsBinary(ST_AsEWKB('LINESTRING(3.5 0, 2.2 1, 3 3, 4.2 5, 5.2 3, 4.5 1, 3.5 0)'))
+])
+"))))
+ (draw-gisobject (decode (car row))))
+ (gl:flush))
+
+;;,
+(defun init ()
+ (gl:clear-color 0.0 0.0 0.05 0))
+
+(defparameter nrange 50.0)
+
+(cffi:defcallback reshape :void ((width :int) (height :int))
+ (if (= height 0)
+ (setf height 1))
+ (gl:viewport 0 0 width height)
+ (gl:matrix-mode :projection)
+ (gl:load-identity)
+ (if (<= width height)
+ (gl:ortho (- nrange) nrange (- (* nrange (/ height width)))
+ (* nrange (/ height width)) (- nrange) nrange)
+ (gl:ortho (- (* nrange (/ height width))) (* nrange (/ height width))
+ (- nrange) nrange (- nrange) nrange))
+ )
+
+(defun main ()
+ (init-db)
+ (glut:init)
+ (glut:init-display-mode :single :rgb)
+ (glut:create-window "Stars")
+ (init)
+ (glut:display-func (cffi:callback draw))
+ (glut:reshape-func (cffi:callback reshape))
+ (glut:keyboard-func (cffi:callback key))
+ (glut:main-loop))
137 test/tests.lisp
@@ -0,0 +1,137 @@
+;;(defpackage :cl-postgis-tests
+;; (:use :common-lisp :postmodern)
+;; (:export #:prompt-connection))
+
+;;(in-package :cl-postgis-tests)
+
+
+(require :postmodern)
+(use-package :postmodern)
+
+(defmacro with-gensyms ((&rest names) &body body)
+ `(let ,(loop for n in names collect `(,n (gensym)))
+ ,@body))
+
+(defvar *test-name* nil)
+(defmacro deftest (name parameters &body body)
+ "Define a test function. Within a test function we can call
+other test functuins or use 'check' to run individual test
+cases."
+ `(defun ,name ,parameters
+ (let ((*test-name* (append *test-name* (list ',name))))
+ ,@body)))
+(defmacro check (&body forms)
+ "Run each expression in 'forms' as a test case."
+ `(combine-results
+ ,@(loop for f in forms collect `(report-result ,f ',f))))
+(defmacro combine-results (&body forms)
+ "Combine the results (as booleans) of evaluating 'forms' in order."
+ (with-gensyms (result)
+ `(let ((,result t))
+ ,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
+ ,result)))
+(defun report-result (result form)
+ "Report the results of a single test case. Called by 'check'."
+ (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
+ result)
+
+
+
+;;(connect-toplevel "michael" "michael" "xxx" "localhost")
+
+(deftest gispoint-test ()
+ (let ((gispoint (caar (query (:select (:ST_AsEWKB "POINT(0 0)")))))
+ (gispointz (caar (query (:select (:ST_AsEWKB "POINT(0 0 1)")))))
+ (gispointzm (caar (query (:select (:ST_AsEWKB "POINT(0 0 1 2)")))))
+ (gispointm (caar (query (:select (:ST_AsEWKB "POINTM(0 0 2)")))))
+ (gispointzm-srid (caar (query (:select (:ST_AsEWKB "SRID=4326;POINT(0 0 1 2)"))))))
+ (check
+ (equalp gispoint (encode (decode gispoint)))
+ (equalp gispointz (encode (decode gispointz)))
+ (equalp gispointm (encode (decode gispointm)))
+ (equalp gispointzm (encode (decode gispointzm)))
+ (equalp gispointzm-srid (encode (decode gispointzm-srid)))
+ )))
+
+(deftest gislinestring-test ()
+ (let (
+ (gislinestring (caar (query (:select (:ST_AsEWKB "LINESTRING(0 0, 1 1, 2 2)")))))
+ (gislinestringz (caar (query (:select (:ST_AsEWKB "LINESTRING(0 0 0, 1 1 1, 2 2 2)")))))
+ (gislinestringzm (caar (query (:select (:ST_AsEWKB "LINESTRING(0 0 1 2, 1 1 2 3, 2 2 3 4)")))))
+ (gislinestringm (caar (query (:select (:ST_AsEWKB "LINESTRINGM(0 0 2, 1 1 3, 2 2 4)")))))
+ (gislinestringzm-srid (caar (query (:select (:ST_AsEWKB "SRID=4326;LINESTRING(0 0 1 2, 1 1 2 3, 2 2 3 4)"))))))
+ (check
+ (equalp gislinestring (encode (decode gislinestring)))
+ (equalp gislinestringz (encode (decode gislinestringz)))
+ (equalp gislinestringzm (encode (decode gislinestringzm)))
+ (equalp gislinestringm (encode (decode gislinestringm)))
+ (equalp gislinestringzm-srid (encode (decode gislinestringzm-srid)))
+ )))
+
+(deftest gispolygon-test ()
+ (let (
+ (gispolygon (caar (query (:select (:ST_AsEWKB "POLYGON((0 0 ,4 0 ,4 4 ,0 4 ,0 0 ),(1 1 ,2 1 ,2 2 ,1 2 ,1 1 ))")))))
+ (gispolygonz (caar (query (:select (:ST_AsEWKB "POLYGON((0 0 0,4 0 0,4 4 0,0 4 0,0 0 0),(1 1 0,2 1 0,2 2 0,1 2 0,1 1 0))")))))
+ (gispolygonzm (caar (query (:select (:ST_AsEWKB "POLYGON((0 0 0 0,4 0 0 1,4 4 0 1,0 4 0 2,0 0 0 3),(1 1 0 4,2 1 0 5,2 2 0 6,1 2 0 7,1 1 0 8))")))))
+ (gispolygonzm-srid (caar (query (:select (:ST_AsEWKB "SRID=4326;POLYGON((0 0 0 0,4 0 0 1,4 4 0 1,0 4 0 2,0 0 0 3),(1 1 0 4,2 1 0 5,2 2 0 6,1 2 0 7,1 1 0 8))"))))))
+ (check
+ (equalp gispolygon (encode (decode gispolygon)))
+ (equalp gispolygonz (encode (decode gispolygonz)))
+ (equalp gispolygonzm (encode (decode gispolygonzm)))
+ (equalp gispolygonzm-srid (encode (decode gispolygonzm-srid)))
+ )))
+
+(deftest gismultipoint-test ()
+ (let (
+ (multi-gispoint (caar (query (:select (:ST_AsEWKB "MULTIPOINT(0 0, 1 1)")))))
+ (multi-gispointz (caar (query (:select (:ST_AsEWKB "MULTIPOINT(0 0 1, 1 1 2)")))))
+ (multi-gispointzm (caar (query (:select (:ST_AsEWKB "MULTIPOINT(0 0 1 2, 1 1 2 3)")))))
+ (multi-gispointzm-srid (caar (query (:select (:ST_AsEWKB "SRID=4326;MULTIPOINT(0 0 1 2, 1 1 2 3)"))))))
+ (check
+ (equalp multi-gispoint (encode (decode multi-gispoint)))
+ (equalp multi-gispointz (encode (decode multi-gispointz)))
+ (equalp multi-gispointzm (encode (decode multi-gispointzm)))
+ (equalp multi-gispointzm-srid (encode (decode multi-gispointzm-srid)))
+ )))
+
+(deftest gismultilinestring-test ()
+ (let (
+ (multi-gislinestring (caar (query (:select (:ST_AsEWKB "MULTILINESTRING((0 0 ,1 1 ,1 2 ),(2 3 ,3 2 ,5 4 ))")))))
+ (multi-gislinestringz (caar (query (:select (:ST_AsEWKB "MULTILINESTRING((0 0 0,1 1 0,1 2 1),(2 3 1,3 2 1,5 4 1))")))))
+ (multi-gislinestringzm (caar (query (:select (:ST_AsEWKB "MULTILINESTRING((0 0 0 1,1 1 0 2,1 2 1 3),(2 3 1 2,3 2 1 3,5 4 1 4))")))))
+ (multi-gislinestringzm-srid (caar (query (:select (:ST_AsEWKB "SRID=4326;MULTILINESTRING((0 0 0 1,1 1 0 2,1 2 1 3),(2 3 1 2,3 2 1 3,5 4 1 4))"))))))
+ (check
+ (equalp multi-gislinestring (encode (decode multi-gislinestring)))
+ (equalp multi-gislinestringz (encode (decode multi-gislinestringz)))
+ (equalp multi-gislinestringzm (encode (decode multi-gislinestringzm)))
+ (equalp multi-gislinestringzm-srid (encode (decode multi-gislinestringzm-srid)))
+ )))
+
+(deftest gismultipolygon-test ()
+ (let (
+ (multi-gispolygon (caar (query (:select (:ST_AsEWKB "MULTIPOLYGON(((0 0,4 0,4 4,0 4,0 0),(1 1,2 1,2 2,1 2,1 1)), ((-1 -1,-1 -2,-2 -2,-2 -1,-1 -1)))")))))
+ (multi-gispolygonz (caar (query (:select (:ST_AsEWKB "MULTIPOLYGON(((0 0 1,4 0 2,4 4 3,0 4 4,0 0 5),(1 1 6,2 1 7,2 2 8,1 2 9,1 1 10)), ((-1 -1 -1,-1 -2 -3,-2 -2 -2,-2 -1 -1,-1 -1 -2)))")))))
+ (multi-gispolygonzm (caar (query (:select (:ST_AsEWKB "MULTIPOLYGON(((0 0 1 1,4 0 2 2,4 4 3 3,0 4 4 4,0 0 5 5),(1 1 1 6,2 1 2 7,2 2 3 8,1 2 4 9,1 1 5 10)), ((-1 -1 5 -1,-1 6 -2 -3,-2 -2 -2 -2,-2 -5 -1 -1,-1 -1 -1 -2)))")))))
+ (multi-gispolygonzm-srid (caar (query (:select (:ST_AsEWKB "SRID=4326;MULTIPOLYGON(((0 0 1 1,4 0 2 2,4 4 3 3,0 4 4 4,0 0 5 5),(1 1 1 6,2 1 2 7,2 2 3 8,1 2 4 9,1 1 5 10)), ((-1 -1 5 -1,-1 6 -2 -3,-2 -2 -2 -2,-2 -5 -1 -1,-1 -1 -1 -2)))"))))))
+ (check
+ (equalp multi-gispolygon (encode (decode multi-gispolygon)))
+ (equalp multi-gispolygonz (encode (decode multi-gispolygonz)))
+ (equalp multi-gispolygonzm (encode (decode multi-gispolygonzm)))
+ (equalp multi-gispolygonzm-srid (encode (decode multi-gispolygonzm-srid)))
+ )))
+
+(deftest gisgeometrycollection-test ()
+ (let (
+ (geometrycollection (caar (query (:select (:ST_AsEWKB "GEOMETRYCOLLECTION(POINT(2 3),LINESTRING(2 3,3 4))"))))))
+ (check
+ (equalp geometrycollection (encode (decode geometrycollection))))))
+
+(deftest test-postgis ()
+ (combine-results
+ (gispoint-test)
+ (gislinestring-test)
+ (gispolygon-test)
+ (gismultipoint-test)
+ (gismultilinestring-test)
+ (gismultipolygon-test)
+ (gisgeometrycollection-test)))

0 comments on commit f3e3775

Please sign in to comment.