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

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Tue Jan 29 07:44:49 2008
New Revision: 2418

Modified:
   branches/bos/projects/bos/m2/m2.lisp
   branches/bos/projects/bos/m2/packages.lisp
   branches/bos/projects/bos/web/kml-handlers.lisp
Log:
the center contract is now marked with "YOUR M2s!!!"


Modified: branches/bos/projects/bos/m2/m2.lisp
==============================================================================
--- branches/bos/projects/bos/m2/m2.lisp	(original)
+++ branches/bos/projects/bos/m2/m2.lisp	Tue Jan 29 07:44:49 2008
@@ -365,6 +365,16 @@
 		(setf (gethash (m2-contract it) contracts) t))))))
       (hash-keys contracts))))
 
+(defun contract-center (contract)
+  (destructuring-bind (left top width height)
+      (contract-bounding-box contract)
+    (rect-center left top width height :roundp t)))
+
+(defun contract-center-lon-lat (contract)
+  (let ((center (contract-center contract)))
+    (with-points (center)
+      (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ center-x) (- +nw-utm-y+ center-y) +utm-zone+ t))))
+
 (defun tx-make-contract (sponsor m2-count &key date paidp expires)
   (warn "Old tx-make-contract transaction used, contract dates may be wrong")
   (tx-do-make-contract sponsor m2-count :date date :paidp paidp :expires expires))

Modified: branches/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp	(original)
+++ branches/bos/projects/bos/m2/packages.lisp	Tue Jan 29 07:44:49 2008
@@ -131,6 +131,8 @@
            #:contract-m2s
 	   #:contract-bounding-box
 	   #:contract-neighbours
+	   #:contract-center
+	   #:contract-center-lon-lat
 	   #:contract-color
 	   #:contract-cert-issued
            #:contract-set-paidp

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 Jan 29 07:44:49 2008
@@ -14,27 +14,37 @@
     ;; when name is xmlns, the attribute does not show up - why (?)
     ;; (attribute "xmlns" "http://earth.google.com/kml/2.2")
     (with-element "Document"
-      (dolist (contract (contract-neighbours contract))
-	(let ((polygon (m2s-polygon-lon-lat (contract-m2s contract)))
-	      (name (user-full-name (contract-sponsor contract))))
+      (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" (text (format nil "~A ~Dm2"
 					       (if name name "anonymous")
-					       (length (contract-m2s contract)))))
+					       (length (contract-m2s c)))))
 	    (with-element "description" (text "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 "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))))))))))))
+		    (text (kml-format-points polygon)))))))
+	  ;; the center contract
+	  (when (eq c contract)
+	    (with-element "Placemark"
+	      (with-element "name" (text "YOUR M2s !!!"))
+	      (with-element "description" (text (format nil "~A ~Dm2"
+							(if name name "anonymous")
+							(length (contract-m2s c)))))	      	    
+	      (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."))