[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp

[BKNR Commits]

Revision: 3793
Author: ksprotte
URL: http://bknr.net/trac/changeset/3793

fixed KML/Google Earth bug. Einblenden der Vertrags-Icons erfolgt zu sp?\195?\164t, werden erst sichtbar, wenn man sehr nah ranfliegt
U   trunk/projects/bos/web/contract-tree.lisp

Modified: trunk/projects/bos/web/contract-tree.lisp
===================================================================
--- trunk/projects/bos/web/contract-tree.lisp	2008-09-04 14:03:38 UTC (rev 3792)
+++ trunk/projects/bos/web/contract-tree.lisp	2008-09-04 14:37:34 UTC (rev 3793)
@@ -58,31 +58,41 @@
     (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t)))
 
 (defun contract-placemark-at-node-p (node contract)
-  "Returns T if CONTRACT is large enough at the LOD of NODE to be displayed
-with its center placemark."
-  (if (not (node-has-children-p node))
-      t
-      (let ((geo-box (geo-box node)))
-        (destructuring-bind (geo-box-utm-west geo-box-utm-north &rest _)
-            (geo-utm:lon-lat-to-utm-x-y (geo-box-west geo-box) (geo-box-north geo-box))
-          (declare (ignore _))
-          (destructuring-bind (geo-box-utm-east geo-box-utm-south &rest _)
-              (geo-utm:lon-lat-to-utm-x-y (geo-box-east geo-box) (geo-box-south geo-box))
-            (declare (ignore _))
-            (let* ((output-images-size *contract-tree-images-size*)
-                   (rect (contract-largest-rectangle contract))
-                   (contract-width (third rect))
-                   (contract-height (fourth rect))
-                   (geo-width (- geo-box-utm-east geo-box-utm-west))
-                   (geo-height (- geo-box-utm-north geo-box-utm-south))
-                   (contract-pixel-size (min (* contract-width (/ output-images-size geo-width))
-                                             (* contract-height (/ output-images-size geo-height)))))
-              (if (< (contract-area contract) 4)
-                  nil
-                  (if (< (depth node) 6)
-                      (> contract-pixel-size 15)
-                      (> contract-pixel-size 30)))))))))
+  "Returns T if CONTRACT is large enough at the LOD of NODE to be
+displayed with its center placemark.
 
+This predicate is called by INSERT-CONTRACT. We assume that for
+bulk-insertions contracts with larger area are inserted first."
+  (cond
+    ((not (node-has-children-p node))
+     t)
+    ;; let's fill nodes to a very low minimum - as noted above, larger
+    ;; contracts are inserted first
+    ((and (> (depth node) 3)
+          (< (length (placemark-contracts node)) 2))
+     t)
+    (t (let ((geo-box (geo-box node)))
+         (destructuring-bind (geo-box-utm-west geo-box-utm-north &rest _)
+             (geo-utm:lon-lat-to-utm-x-y (geo-box-west geo-box) (geo-box-north geo-box))
+           (declare (ignore _))
+           (destructuring-bind (geo-box-utm-east geo-box-utm-south &rest _)
+               (geo-utm:lon-lat-to-utm-x-y (geo-box-east geo-box) (geo-box-south geo-box))
+             (declare (ignore _))
+             (let* ((output-images-size *contract-tree-images-size*)
+                    (rect (contract-largest-rectangle contract))
+                    (contract-width (third rect))
+                    (contract-height (fourth rect))
+                    (geo-width (- geo-box-utm-east geo-box-utm-west))
+                    (geo-height (- geo-box-utm-north geo-box-utm-south))
+                    (contract-pixel-size (min (* contract-width (/ output-images-size geo-width))
+                                              (* contract-height (/ output-images-size geo-height)))))
+               (cond
+                 ((< (contract-area contract) 4)
+                  nil)
+                 ((< (depth node) 4)
+                  (> contract-pixel-size 5))
+                 (t (> contract-pixel-size 10))))))))))
+
 (defun find-contract-node (node contract)
   (find-node-if (lambda (node) (member contract (placemark-contracts node))) node))
 
@@ -353,12 +363,14 @@
 
 ;;; make-contract-tree-from-m2
 (defun make-contract-tree-from-m2 ()
+  (when *contract-tree*
+    (map-nodes #'delete-node-extension *contract-tree*))
   (setq *contract-tree* (make-instance 'contract-node
                                        ;; we know that MAKE-QUAD-TREE
                                        ;; has already been called
                                        :base-node *quad-tree*
                                        :name '*contract-tree*))
-  (dolist (contract (all-contracts))
+  (dolist (contract (sort (copy-list (all-contracts)) #'> :key #'contract-area))    
     (when (contract-published-p contract)
       (insert-contract *contract-tree* contract)))
   (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree*