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