Revision: 4132 Author: hans URL: http://bknr.net/trac/changeset/4132

Query sponsors by geo rectangle.

U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/sponsor-handlers.lisp

Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-12-10 14:15:39 UTC (rev 4131) +++ trunk/projects/bos/web/contract-tree.lisp 2008-12-13 21:04:38 UTC (rev 4132) @@ -126,10 +126,10 @@ (insert-contract contract-tree contract) (remove-contract contract-tree contract)))))

-(defmacro handle-if-node-modified (&body body) +(defmacro handle-if-node-modified ((node) &body body) `(let* ((path (parse-path path)) - (node (find-node-with-path *contract-tree* path))) - (hunchentoot:handle-if-modified-since (timestamp node)) + (,node (find-node-with-path *contract-tree* path))) + (hunchentoot:handle-if-modified-since (timestamp ,node)) ,@body))

;;; contract-placemark-handler @@ -218,7 +218,7 @@ :root-element "kml") (with-query-params ((lang "en") (path) (rmcpath) (rmcid)) - (handle-if-node-modified + (handle-if-node-modified (node) (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date (timestamp node))) (let* ((lod (node-lod node)) @@ -442,6 +442,37 @@ (list 0 0 +width+ +width+) #'contract-tree-changed))

-(register-transient-init-function 'make-contract-tree-from-m2 +(defun contract-size (contract) + (length (contract-m2s contract))) + +(defun contracts-in-geo-box (geo-box &key limit) + "Return all contracts that intersect the given GEO-BOX. If LIMIT is +specified, the LIMIT largest contracts are returned." + (let ((return-count 0) + (contracts (list nil))) + (ensure-intersecting-children *contract-tree* + geo-box + (lambda (node) + (dolist (contract (placemark-contracts node)) + (when (geo-box-encloses-p geo-box (contract-geo-box contract)) + (when (and limit + (>= return-count limit)) + (if (<= (contract-size contract) + (contract-size (cadr contracts))) + (return) + (setf contracts (cons nil (cddr contracts))))) + (incf return-count) + (do ((point contracts (cdr point))) + ((or (null (cddr point)) + (< (contract-size contract) + (contract-size (cadr point)))) + (setf (cdr point) (cons contract (cdr point)))))))) + (lambda (node) + (or (and limit + (>= return-count limit)) + (leaf-node-p node)))) + (cdr contracts))) + +y(register-transient-init-function 'make-contract-tree-from-m2 'make-quad-tree 'geometry:make-rect-publisher)

Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-10 14:15:39 UTC (rev 4131) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-13 21:04:38 UTC (rev 4132) @@ -358,6 +358,18 @@ (class-instances 'sponsor) :key (compose #'string-downcase #'user-full-name))))

+(defun sponsors-at (query) + (when (cl-ppcre:scan "^[0-9,]+$" query) + (destructuring-bind (east north west south) (mapcar #'parse-integer (cl-ppcre:split "," query)) + (labels + ((x-y-to-lon-lat (x y) + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) + (mapcar #'contract-sponsor + (contracts-in-geo-box (coerce (append (x-y-to-lon-lat east north) + (x-y-to-lon-lat west south)) + '(vector double-float)) + :limit 10)))))) + (defun largest-sponsors () (mapcar #'contract-sponsor (subseq (sort (copy-list (class-instances 'contract)) @@ -373,6 +385,8 @@ (cond ((query-param "q") (sponsors-matching (query-param "q"))) + ((query-param "at") + (sponsors-at (query-param "at"))) ((query-param "largest") (largest-sponsors)) (t