util/private/geometry.rkt
#lang racket/base
(require racket/contract
racket/list)
(provide (all-defined-out))

#|
Geometry according to mysql:
abstract Geometry
- Point = (x, y)
- abstract Curve
- LineString = (list of points)
- predicate Line
- predicate LinearRing (closed and non-self-intersecting, bleh)
- abstract Surface
- Polygon (defined by LinearRings, bleh)
= exterior ring, list of interior rings
- GeometryCollection = (list of geometry values)
- MultiPoint = (list of points)
- abstract MultiCurve
- MultiLineString = (list of line strings)
- abstract MultiSurface
- MultiPolygon = (list of polygons)

every geometric value has an associated Spacial Reference System (SRID), ignored by mysql

Geometry according to postgis:

same as above, but with coordinate variants: eg pointm = (x, y, m)
|#

(struct point (x y)
#:transparent
#:guard (lambda (x y _n)
(values (exact->inexact x)
(exact->inexact y))))

(struct line-string (points)
#:transparent)

(define (line? x)
(and (line-string? x)
(let ([points (line-string-points x)])
(and (= 2 (length points))
(not (equal? (first points) (second points)))))))

(define (linear-ring? x)
(and (line-string? x)
(let ([points (line-string-points x)])
;; FIXME: require at least ??? points
(equal? (first points) (last points)))))

(struct polygon (exterior interiors)
#:transparent)

(struct multi-point (elements)
#:transparent)

(struct multi-line-string (elements)
#:transparent)

(struct multi-polygon (elements)
#:transparent)

(struct geometry-collection (elements)
#:transparent)

(define (geometry2d? x)
(or (point? x)
(line-string? x)
(polygon? x)
(multi-point? x)
(multi-line-string? x)
(multi-polygon? x)
(geometry-collection? x)))

;; ----------------------------------------

;; Based on OGC 06-103r4

(define (wkb->geometry b [start 0] [end (bytes-length b)])
(bytes->geometry 'wkb->geometry b start end #:srid? #f))

(define (bytes->geometry who b [start 0] [end (bytes-length b)]
#:srid? [srid? #f])
(define (get-byte)
(begin0 (bytes-ref b start)
(set! start (+ start 1))))
(define (get-uint be?)
(begin0 (integer-bytes->integer b #f be? start (+ start 4))
(set! start (+ start 4))))
(define (get-multi n get-X)
(for/list ([i (in-range n)]) (get-X)))
(define (get-geometry)
(let ([srid (and srid? (get-uint #f))] ;; FIXME: store srid
[be? (zero? (get-byte))])
(define (get-double)
(begin0 (floating-point-bytes->real b be? start (+ start 8))
(set! start (+ start 8))))
(define (get-point)
(let* ([x (get-double)]
[y (get-double)])
(point x y)))
(define (get-linear-ring)
(let ([len (get-uint be?)])
(line-string (get-multi len get-point))))
(let ([type (get-uint be?)])
(case type
((1) (get-point))
((2) (let ([points (get-multi (get-uint be?) get-point)])
(line-string points)))
((3) (let ([rings (get-multi (get-uint be?) get-linear-ring)])
(when (null? rings)
(error who "polygon with zero rings"))
(polygon (car rings) (cdr rings))))
((4 5 6 7) (let ([constructor
(case type
((4) multi-point)
((5) multi-line-string)
((6) multi-polygon)
((7) geometry-collection))]
[elements (get-multi (get-uint be?) get-geometry)])
(constructor elements)))
(else
(error who "unsupported geometry type: ~s" type))))))
(begin0 (get-geometry)
(unless (= start end)
(error who "~s bytes left over" (- end start)))))

;; ----

(define (geometry->wkb g
#:big-endian? [be? (system-big-endian?)])
(geometry->bytes 'geometry->wkb g
#:big-endian? be?
#:srid? #f))

(define (geometry->bytes who g
#:big-endian? [be? (system-big-endian?)]
#:srid? [srid? #f])
(define out (open-output-bytes))
(define (put-uint n)
(write-bytes (integer->integer-bytes n 4 #f be?) out))
(define (put-double x)
(write-bytes (real->floating-point-bytes x 8 be?) out))
(define (put-point g)
(put-double (point-x g))
(put-double (point-y g)))
(define (put-line-string g)
(let ([points (line-string-points g)])
(put-uint (length points))
(for ([p (in-list points)])
(put-point p))))
(define (put-collection lst)
(put-uint (length lst))
(for ([g (in-list lst)])
(put-geometry g)))
(define (put-geometry g)
(when srid? (put-uint 0)) ;; FIXME
(write-byte (if be? 0 1) out)
(cond [(point? g)
(put-uint 1)
(put-point g)]
[(line-string? g)
(put-uint 2)
(put-line-string g)]
[(polygon? g)
(put-uint 3)
(let ([rings (cons (polygon-exterior g) (polygon-interiors g))])
(put-uint (length rings))
(for ([ring (in-list rings)])
(put-line-string ring)))]
[(multi-point? g)
(put-uint 4)
(put-collection (multi-point-elements g))]
[(multi-line-string? g)
(put-uint 5)
(put-collection (multi-line-string-elements g))]
[(multi-polygon? g)
(put-uint 6)
(put-collection (multi-polygon-elements g))]
[(geometry-collection? g)
(put-uint 7)
(put-collection (geometry-collection-elements g))]
[else
(error who "unsupported geometry type: ~e" g)]))
(put-geometry g)
(get-output-bytes out))

;; FIXME: define WKT functions?
;; FIXME: eventually, integrate with geos?