Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
327 lines (273 sloc) 10.8 KB
(in-package :bos.web)
;;; kml utils (including point / rect stuff) - for now
(defmacro values-nsew ()
'(values north south east west))
(defmacro bind-nsew (form &body body)
`(multiple-value-bind (north south east west)
(defmacro let-nsew ((north south east west) &body body)
`(let ((north ,north)
(south ,south)
(east ,east)
(west ,west))
(defclass point ()
(defgeneric point-lon-lat (point))
(defgeneric point-x-y (point))
(defmethod print-object ((point point) stream)
(print-unreadable-object (point stream)
(multiple-value-bind (x y)
(point-x-y point)
(if (and (integerp x) (integerp y))
(format stream "~a,~a" x y)
(format stream "~,5f,~,5f" x y)))))
(defclass lon-lat-point (point)
((lon :accessor %point-lon :initarg :lon)
(lat :accessor %point-lat :initarg :lat)))
(defmethod point-lon-lat ((p lon-lat-point))
(values (%point-lon p) (%point-lat p)))
(defmethod point-x-y ((p lon-lat-point))
(destructuring-bind (x y zone southhemi-p)
(geo-utm:lon-lat-to-utm-x-y (%point-lon p) (%point-lat p))
(assert (= +utm-zone+ zone))
(assert southhemi-p)
(values (- x +nw-utm-x+) (- +nw-utm-y+ y))))
(defclass x-y-point (point)
((x :accessor %point-x :initarg :x)
(y :accessor %point-y :initarg :y)))
(defmethod point-x-y ((p x-y-point))
(values (%point-x p) (%point-y p)))
(defmethod point-lon-lat ((p x-y-point))
(destructuring-bind (lon lat)
(geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ (%point-x p))
(- +nw-utm-y+ (%point-y p))
+utm-zone+ t)
(values lon lat)))
(defun make-point (&key x y lon lat)
((and x y (not lon) (not lat))
(make-instance 'x-y-point :x x :y y))
((and lon lat (not x) (not y))
(make-instance 'lon-lat-point :lon lon :lat lat))
(t (error "Cannot make point"))))
(defun point-equal (a b)
(assert (and (typep a 'x-y-point) (typep b 'x-y-point))
"point-equal only impl for 2 point-x-y")
(and (= (%point-x a) (%point-x b))
(= (%point-y a) (%point-y b))))
(defun point1- (point)
(multiple-value-bind (x y) (point-x-y point)
(make-point :x (1- x) :y (1- y))))
(defclass rectangle ()
((top-left :accessor top-left :initarg :top-left)
(bottom-right :accessor bottom-right :initarg :bottom-right)))
(defmethod width-height ((rect rectangle))
(x y)
(point-x-y (top-left rect))
(x2 y2)
(point-x-y (bottom-right rect))
(let ((width (- x2 x))
(height (- y2 y)))
(values width height)))))
(defmethod size ((rect rectangle))
(multiple-value-bind (width height)
(width-height rect)
(max width height)))
(defmethod print-object ((rect rectangle) stream)
(print-unreadable-object (rect stream :type t :identity t)
(x y)
(point-x-y (top-left rect))
(x2 y2)
(point-x-y (bottom-right rect))
(let ((width (- x2 x)))
(let ((height (- y2 y)))
(format stream "~a,~a ~a x ~a" x y width height)))))))
(defun make-rectangle (&key x y width height (type 'rectangle))
(make-instance type
:top-left (make-point :x x :y y)
:bottom-right (make-point :x (+ x width) :y (+ y height))))
(defun make-rectangle2 (x-y-width-height)
(destructuring-bind (x y width height)
(make-rectangle :x x :y y :width width :height height)))
(defun rect-equal (a b)
(and (point-equal (top-left a) (top-left b))
(point-equal (bottom-right a) (bottom-right b))))
(defmethod bounding-box-lon-lat ((rect rectangle))
(multiple-value-bind (west north)
(point-lon-lat (top-left rect))
(multiple-value-bind (east south)
(point-lon-lat (bottom-right rect))
(defmethod bounding-box-x-y ((rect rectangle))
(west north)
(point-x-y (top-left rect))
(east south)
(point-x-y (bottom-right rect))
;; (defmethod split ((rect rectangle) side-num)
;; (let ((array (make-array (list side-num side-num))))
;; (multiple-value-bind
;; (x y)
;; (point-x-y (top-left rect))
;; (multiple-value-bind
;; (width height)
;; (width-height rect)
;; (let ((new-width (/ width side-num)))
;; (assert (integerp (/ width side-num)))
;; (assert (= width height))
;; (dotimes (xind side-num)
;; (dotimes (yind side-num)
;; (setf (aref array xind yind)
;; (make-rectangle :x (+ x (* xind new-width)) :y
;; (+ y (* yind new-width)) :width new-width
;; :height new-width)))))))
;; array))
(defmethod quad-split ((rect rectangle) &optional (sub-rect-type 'rectangle))
(x y)
(point-x-y (top-left rect))
(width height)
(width-height rect)
(let ((width1 (floor width 2)))
(let ((width2 (ceiling width 2)))
(let ((height1 (floor height 2)))
(let ((height2 (ceiling height 2)))
(assert (> width 1))
(assert (> height 1))
(make-rectangle :x x :y y :width width1 :height height1 :type
(make-rectangle :x x :y (+ y height1) :width width1 :height
height2 :type sub-rect-type)
(make-rectangle :x (+ x width1) :y (+ y height1) :width width2
:height height2 :type sub-rect-type)
(make-rectangle :x (+ x width1) :y y :width width2 :height height1
:type sub-rect-type)))))))))
(defun point-in-rect-p (point rect)
(x y)
(point-x-y point)
(r-x r-y)
(point-x-y (top-left rect))
(r-x2 r-y2)
(point-x-y (bottom-right rect))
(and (<= r-x x (1- r-x2)) (<= r-y y (1- r-y2)))))))
(defun contains-p (parent-rect rect)
(and (point-in-rect-p (top-left rect) parent-rect)
(point-in-rect-p (point1- (bottom-right rect)) parent-rect)))
(defun intersects-p (parent-rect rect)
(or (point-in-rect-p (top-left rect) parent-rect)
(point-in-rect-p (point1- (bottom-right rect)) parent-rect)))
(defun rectangle-union (rects)
(let ((left (reduce #'min rects :key #'(lambda (r) (point-x-y (top-left r)))))
(right (reduce #'max rects :key #'(lambda (r) (point-x-y (bottom-right r)))))
(top (reduce #'min rects :key #'(lambda (r) (nth-value 1 (point-x-y (top-left r))))))
(bottom (reduce #'max rects :key #'(lambda (r) (nth-value 1 (point-x-y (bottom-right r)))))))
(make-rectangle :x left :y top :width (- right left) :height (- bottom top))))
(defun rectangle-points (rect)
(r-x r-y)
(point-x-y (top-left rect))
(r-x2 r-y2)
(point-x-y (bottom-right rect))
(loop for x from r-x below r-x2 for y from r-y below r-y2 collect
(make-point :x x :y y)))))
(defclass container ()
((items :accessor items :initarg :items :initform nil)))
(defclass quad ()
((quads :accessor quads :initarg :quads :initform nil)))
(defclass rectangle-container (rectangle container)
(defclass rectangle-quad (rectangle container quad)
(defmacro doarray ((array x y) &body body)
`(destructuring-bind (xdim ydim)
(array-dimensions ,array)
(dotimes (,y ydim)
(dotimes (,x xdim)
(defun float-text (float)
(text (format nil "~,20F" float)))
(defun integer-text (int)
(text (format nil "~D" int)))
(defun kml-format-points (points &optional (altitude 0))
(format nil "~:{~,20F,~,20F,~,20F ~}"
(mapcar #'(lambda (p) (append (multiple-value-list (point-lon-lat p))
(list altitude)))
(defun kml-format-color (color &optional (opacity 255))
(format nil "~2,'0X~{~2,'0X~}" opacity (reverse color)))
(defmethod kml-link ((href string) &key refresh-on-region http-query)
(with-element "Link"
(with-element "href" (text href))
(when refresh-on-region
(with-element "viewRefreshMode" (text "onRegion")))
(when http-query
(with-element "httpQuery" (text http-query)))))
;; (defmethod kml-link ((href puri:uri))
;; (let ((string (with-output-to-string (out)
;; (puri:render-uri href out))))
;; (kml-link string)))
(defun kml-hide-children-style ()
(with-element "Style"
(with-element "ListStyle"
(with-element "listItemType" (text "checkHideChildren"))
(with-element "bgColor" (text "00ffffff")))))
(defun kml-network-link (href &key rect lod name
fly-to-view hide-children
;; http-query could be added to &key args
(with-element "NetworkLink"
(when name (with-element "name" (text name)))
(when hide-children
(when rect (kml-region rect lod))
(when look-at (funcall look-at))
(when fly-to-view (with-element "flyToView" (text "1")))
(kml-link href :refresh-on-region (and rect t))))
(defun kml-lat-lon-box (rect &optional (element "LatLonBox"))
(bind-nsew (bounding-box-lon-lat rect)
(with-element element
(with-element "north" (float-text north))
(with-element "south" (float-text south))
(with-element "east" (float-text east))
(with-element "west" (float-text west)))))
(defun kml-lat-lon-alt-box (rect)
(kml-lat-lon-box rect "LatLonAltBox"))
(defun kml-overlay (img-path rect &key (draw-order 0) absolute lod)
(with-element "GroundOverlay"
(with-element "name" (text (file-namestring img-path)))
(when lod (kml-region rect lod))
(with-element "drawOrder" (integer-text draw-order))
(with-element "Icon"
(with-element "href" (text img-path))
;; (with-element "refreshMode" (text "..."))
(when absolute
(with-element "altitude" (text (princ-to-string absolute)))
(with-element "altitudeMode" (text "absolute")))
(kml-lat-lon-box rect)))
(defun kml-region (rect lod)
(with-element "Region"
(kml-lat-lon-alt-box rect)
(destructuring-bind (&key min max min-fade max-fade) lod
(with-element "Lod"
(when min (with-element "minLodPixels" (integer-text min)))
(when max (with-element "maxLodPixels" (integer-text max)))
(when min-fade (with-element "minFadeExtent" (integer-text min-fade)))
(when max-fade (with-element "maxFadeExtent" (integer-text max-fade)))))))
;; end kml utils
Jump to Line
Something went wrong with that request. Please try again.