[bknr-cvs] hans changed trunk/projects/bos/web/

[BKNR Commits]

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))
      , at 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