[bknr-cvs] r2562 - branches/bos/projects/bos/web

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Tue Feb 19 11:42:05 2008
New Revision: 2562

Modified:
   branches/bos/projects/bos/web/kml-handlers.lisp
Log:
added demo-kml function to generate the fat demo file

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	Tue Feb 19 11:42:05 2008
@@ -46,36 +46,83 @@
     ;; (attribute "xmlns" "http://earth.google.com/kml/2.2")
     (with-element "Document"
       (dolist (c (contract-neighbours contract 50))
-	(let ((polygon (m2s-polygon-lon-lat (contract-m2s c)))
-	      (name (user-full-name (contract-sponsor c))))
-	  (with-element "Placemark"
-	    (with-element "name" (utf-8-text (format nil "~A ~Dm²"
-						     (if name name "anonymous")
-						     (length (contract-m2s c)))))
-	    (with-element "description" (utf-8-text (contract-description c :de)))
-	    (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 c) 175)))))
-	    (with-element "Polygon"
-	      (with-element "styleUrl" "#region")
-	      (with-element "tessellate" (text "1"))
-	      (with-element "outerBoundaryIs"
-		(with-element "LinearRing"
-		  (with-element "coordinates"
-		    (text (kml-format-points polygon)))))))
-	  ;; the center contract
-	  (when (eq c contract)
-	    (with-element "Placemark"
-	      (with-element "name" (utf-8-text (format nil "~A ~Dm²"
-						       (if name name "anonymous")
-						       (length (contract-m2s c)))))
-	      (with-element "description" (utf-8-text (contract-description c :de)))
-	      (with-element "Point"
-		(with-element "coordinates"
-		  (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))
+        (let ((polygon (m2s-polygon-lon-lat (contract-m2s c)))
+              (name (user-full-name (contract-sponsor c))))
+          (with-element "Placemark"
+            (with-element "name" (utf-8-text (format nil "~A ~Dm²"
+                                                     (if name name "anonymous")
+                                                     (length (contract-m2s c)))))
+            (with-element "description" (utf-8-text (contract-description c :de)))
+            (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 c) 175)))))
+            (with-element "Polygon"
+              (with-element "styleUrl" "#region")
+              (with-element "tessellate" (text "1"))
+              (with-element "outerBoundaryIs"
+                (with-element "LinearRing"
+                  (with-element "coordinates"
+                    (text (kml-format-points polygon)))))))
+          ;; the center contract
+          (when (eq c contract)
+            (with-element "Placemark"
+              (with-element "name" (utf-8-text (format nil "~A ~Dm²"
+                                                       (if name name "anonymous")
+                                                       (length (contract-m2s c)))))
+              (with-element "description" (utf-8-text (contract-description c :de)))
+              (with-element "Point"
+                (with-element "coordinates"
+                  (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))
 
 (defmethod handle-object ((handle-object contract-kml-handler) (object null) req)
   (error "Contract not found."))
+
+;;; static kml file demo generator
+(defun demo-kml (&optional (path #p"/tmp/demo.kml"))
+  (with-open-file (out path :direction :output :if-exists :supersede
+                       :element-type '(unsigned-byte 8))
+    (write-line "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" out)
+    (write-line "<kml xmlns=\"http://earth.google.com/kml/2.2\">" out)
+    (cxml:with-xml-output (cxml:make-octet-stream-sink out)
+      (with-element "Document"
+        (dolist (c (subseq (class-instances 'contract) 0 10))
+          (let ((polygon (m2s-polygon-lon-lat (contract-m2s c)))
+                (name (user-full-name (contract-sponsor c))))
+            (with-element "Placemark"
+              (with-element "name" (utf-8-text (format nil "~A ~Dm²"
+                                                       (if name name "anonymous")
+                                                       (length (contract-m2s c)))))
+              (with-element "description" (utf-8-text (contract-description c :de)))
+              (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 c) 175)))))
+              (with-element "Polygon"
+                (with-element "styleUrl" "#region")
+                (with-element "tessellate" (text "1"))
+                (with-element "outerBoundaryIs"
+                  (with-element "LinearRing"
+                    (with-element "coordinates"
+                      (text (kml-format-points polygon)))))))))
+        (dolist (poi (class-instances 'poi))
+          (when (and (poi-area poi)
+                     (gethash "en" (poi-title poi)))
+            (destructuring-bind (poi-x poi-y) (poi-area poi)
+              (let ((utm-x (+ +nw-utm-x+ poi-x))
+                    (utm-y (- +nw-utm-y+ poi-y)))     
+                (with-element "Placemark"
+                  (with-element "name" (text (gethash "en" (poi-title poi))))
+                  (when (gethash "en" (poi-description poi))
+                    (with-element "description" (text (gethash "en" (poi-description poi)))))
+                  (with-element "Point"
+                    (with-element "coordinates"
+                      (text (kml-format-points (list (geo-utm:utm-x-y-to-lon-lat utm-x utm-y +utm-zone+ t)))))))))))))
+    (write-line "</kml>" out)))
+
+(demo-kml)
+