[bknr-cvs] r2414 - in branches/bos/projects/bos: m2 web
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Tue Jan 29 11:43:21 UTC 2008
Author: ksprotte
Date: Tue Jan 29 06:43:20 2008
New Revision: 2414
Modified:
branches/bos/projects/bos/m2/geometry.lisp
branches/bos/projects/bos/m2/m2.lisp
branches/bos/projects/bos/m2/packages.lisp
branches/bos/projects/bos/web/kml-handlers.lisp
Log:
kml-handler now uses the new function CONTRACT-NEIGHBOURS and
exports and entire region (a first version...)
Modified: branches/bos/projects/bos/m2/geometry.lisp
==============================================================================
--- branches/bos/projects/bos/m2/geometry.lisp (original)
+++ branches/bos/projects/bos/m2/geometry.lisp Tue Jan 29 06:43:20 2008
@@ -44,10 +44,16 @@
(setf (first ,point) x
(second ,point) y)
(when ,(if test
- `(funcall ,test point)
+ `(funcall ,test ,point)
t)
, at body)))))
+(defun rect-center (left top width height &key roundp)
+ (let ((x (+ left (/ width 2)))
+ (y (+ top (/ height 2))))
+ (if roundp
+ (list (round x) (round y))
+ (list x y))))
;; maybe change this function to take a
;; point as an argument?
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 06:43:20 2008
@@ -350,6 +350,21 @@
(setf max-y (max (m2-y m2) (or max-y (m2-y m2)))))
(list min-x min-y (1+ (- max-x min-x)) (1+ (- max-y min-y)))))
+(defun contract-neighbours (contract &optional (radius 100))
+ (destructuring-bind (left top width height)
+ (contract-bounding-box contract)
+ (let ((center (rect-center left top width height :roundp t))
+ (diameter (* 2 radius))
+ (contracts (make-hash-table :test #'eq)))
+ (with-points (center)
+ (dorect (point ((- center-x radius) (- center-y radius) diameter diameter)
+ :test (lambda (point) (point-in-circle-p point center radius)))
+ (with-points (point)
+ (awhen (get-m2 point-x point-y)
+ (when (m2-contract it)
+ (setf (gethash (m2-contract it) contracts) t))))))
+ (hash-keys contracts))))
+
(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 06:43:20 2008
@@ -2,7 +2,10 @@
(defpackage :geometry
(:use :cl :iterate :arnesi)
- (:export #:distance
+ (:export #:with-points
+ #:distance
+ #:dorect
+ #:rect-center
#:point-in-polygon-p
#:point-in-circle-p
#:find-boundary-point
@@ -127,6 +130,7 @@
#:contract-date
#:contract-m2s
#:contract-bounding-box
+ #:contract-neighbours
#: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 06:43:20 2008
@@ -1,15 +1,5 @@
(in-package :bos.web)
-(defun contract-utm-bounding-box (contract)
- "Returns LEFT, TOP, RIGHT, BOTTOM."
- (let (min-x min-y max-x max-y)
- (dolist (m2 (contract-m2s contract))
- (setf min-x (min (m2-utm-x m2) (or min-x (m2-utm-x m2))))
- (setf min-y (min (m2-utm-y m2) (or min-y (m2-utm-y m2))))
- (setf max-x (max (m2-utm-x m2) (or max-x (m2-utm-x m2))))
- (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 kml-format-points (points)
(format nil "~:{~F,~F,0 ~}" points))
@@ -20,28 +10,31 @@
())
(defmethod handle-object ((handler contract-kml-handler) (contract contract) req)
- (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml")
+ (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")
- (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 "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 (kml-format-points polygon)))))))))))
+ (with-element "Document"
+ (dolist (contract (contract-neighbours contract))
+ (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract)))
+ (name (user-full-name (contract-sponsor contract))))
+ (with-element "Placemark"
+ (with-element "name" (text (format nil "~A ~Dm2"
+ (if name name "anonymous")
+ (length (contract-m2s contract)))))
+ (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 "Polygon"
+ (with-element "styleUrl" "#region")
+ (with-element "tessellate" (text "1"))
+ (with-element "outerBoundaryIs"
+ (with-element "LinearRing"
+ (with-element "coordinates"
+ (text (kml-format-points polygon))))))))))))
(defmethod handle-object ((handle-object contract-kml-handler) (object null) req)
(error "Contract not found."))
-
More information about the Bknr-cvs
mailing list