[bknr-cvs] r2408 - in branches/bos/projects/bos: m2 web

[ksprotte at common-lisp.net]

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."))