Author: ksprotte Date: Fri Jan 25 08:15:35 2008 New Revision: 2408 Modified: branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/web/kml-handlers.lisp Log: exporting contracts to GE now works with polygons + color Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Fri Jan 25 08:15:35 2008 @@ -113,6 +113,13 @@ (let ((m2 (apply #'get-m2 p))) (and m2 (eql contract (m2-contract m2)))))))) +(defun m2s-polygon-lon-lat (m2s) + (let ((polygon (m2s-polygon m2s))) + (mapcar (lambda (point) + (destructuring-bind (x y) point + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) + polygon))) + ;;;; SPONSOR ;;; Exportierte Funktionen: Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 25 08:15:35 2008 @@ -91,6 +91,8 @@ #:m2-utm-y #:m2-utm #:m2-lon-lat + #:m2s-polygon + #:m2s-polygon-lon-lat #:escape-nl #:return-m2s Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Fri Jan 25 08:15:35 2008 @@ -10,9 +10,12 @@ (setf max-y (max (m2-utm-y m2) (or max-y (m2-utm-y m2))))) (list min-x max-y max-x min-y))) -(defun points2string (points) +(defun kml-format-points (points) (format nil "~:{~F,~F,0 ~}" points)) +(defun kml-format-color (color &optional (opacity 255)) + (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color))) + (defclass contract-kml-handler (object-handler) ()) @@ -20,20 +23,24 @@ (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") ;; when name is xmlns, the attribute does not show up - why (?) ;; (attribute "xmlns" "http://earth.google.com/kml/2.2") - (destructuring-bind (left top right bottom) (contract-utm-bounding-box contract) + (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract)))) (with-element "Document" (with-element "Placemark" (with-element "name" (format nil "contract~a" (store-object-id contract))) - (with-element "description" "a description") - (with-element "Polygon" + (with-element "description" "a description") + (with-element "Style" + (attribute "id" "#region") + (with-element "LineStyle" + (with-element "color" (text "ffff3500"))) + (with-element "PolyStyle" + (with-element "color" (text (kml-format-color (contract-color contract) 175))))) + (with-element "Polygon" + (with-element "styleUrl" "#region") (with-element "tessellate" (text "1")) (with-element "outerBoundaryIs" (with-element "LinearRing" (with-element "coordinates" - (text (points2string (list (geo-utm:utm-x-y-to-lon-lat left bottom +utm-zone+ t) - (geo-utm:utm-x-y-to-lon-lat right bottom +utm-zone+ t) - (geo-utm:utm-x-y-to-lon-lat right top +utm-zone+ t) - (geo-utm:utm-x-y-to-lon-lat left top +utm-zone+ t))))))))))))) + (text (kml-format-points polygon))))))))))) (defmethod handle-object ((handle-object contract-kml-handler) (object null) req) (error "Contract not found."))