Changeset 3204

Show
Ignore:
Timestamp:
05/29/08 17:59:31 (8 months ago)
Author:
ksprotte
Message:

make-sat-image-tile now allows for creation of a single
level of sat tiles. Still need to work on persistence.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/projects/bos/web/bos.web.asd

    r3153 r3204  
    3535               (:file "quad-tree" :depends-on ("packages")) 
    3636               (:file "contract-tree" :depends-on ("quad-tree")) 
     37               (:file "sat-tree" :depends-on ("quad-tree")) 
    3738               (:file "countries" :depends-on ("packages")) 
    3839               (:file "kml-handlers" :depends-on ("packages" "web-macros" "countries")) 

  • trunk/projects/bos/web/sat-tree.lisp

    r3197 r3204  
    55 
    66(defpersistent-class sat-layer () 
    7   ((name :reader name :initarg :name))) 
     7  ((name :reader name :initarg :name 
     8         :index-type unique-index 
     9         :index-reader find-sat-layer))) 
    810 
    911(defpersistent-class sat-image (store-image) 
    …… 
    2123  (name (layer obj))) 
    2224 
    23 ;;; was passiert, wenn die tile intersections sehr klein (sozusagen 
    24 ;;; Rundungsfehler) sind 
     25(defconstant +max-sat-image-tile-pixel-area+ (float (expt 256 2) 0d0)) 
     26 
     27(defun sat-image-tile-properties (image geo-box tile-geo-box &optional scaling) 
     28  #+nil(declare (optimize speed)) 
     29  ;; (the (double-float 0d0 #.(float most-positive-fixnum 0d0)) ...) 
     30  ;; might be useful 
     31  (let* ((gw (float (the (integer 1 #.most-positive-fixnum) (cl-gd:image-width image)) 0d0)) 
     32         (gh (float (the (integer 1 #.most-positive-fixnum) (cl-gd:image-height image)) 0d0)) 
     33         (w (geo-box-west geo-box)) 
     34         (n (geo-box-north geo-box)) 
     35         (e (geo-box-east geo-box)) 
     36         (s (geo-box-south geo-box))         
     37         (bw (geo-box-west tile-geo-box)) 
     38         (bn (geo-box-north tile-geo-box)) 
     39         (be (geo-box-east tile-geo-box)) 
     40         (bs (geo-box-south tile-geo-box)) 
     41         (xu (/ (- e w) gw)) 
     42         (yu (/ (- n s) gh)) 
     43         (px (floor (/ (- bw w) xu))) 
     44         (py (floor (/ (- n bn) yu))) 
     45         (px2 (ceiling (/ (- be w) xu))) 
     46         (py2 (ceiling (/ (- n bs) yu))) 
     47         (pw (- px2 px)) 
     48         (ph (- py2 py)) 
     49         (rounded-geo-box (make-geo-box (+   (* px  xu) w) 
     50                                        (- n (* py  yu)) 
     51                                        (+   (* px2 xu) w) 
     52                                        (- n (* py2 yu)))) 
     53         (scaling (if scaling 
     54                      scaling 
     55                      (ceiling (sqrt (/ (* pw ph) +max-sat-image-tile-pixel-area+))))) 
     56         (tw (round (/ pw scaling))) 
     57         (th (round (/ ph scaling)))) 
     58    (values scaling 
     59            pw ph px py px2 py2  
     60            tw th rounded-geo-box))) 
     61 
     62(defun make-sat-image-tile (image geo-box quad-node tile-geo-box name max-scaling) 
     63  (multiple-value-bind (scaling 
     64                        pw ph px py px2 py2  
     65                        tw th rounded-geo-box) 
     66      (sat-image-tile-properties image geo-box tile-geo-box max-scaling) 
     67    (declare (ignore scaling px2 py2)) 
     68    (let ((path (node-path quad-node))) 
     69      (cl-gd:with-image (cl-gd:*default-image* tw th t) 
     70        (cl-gd:copy-image image cl-gd:*default-image* 
     71                          px py 0 0 
     72                          pw ph 
     73                          :resize t :resample t 
     74                          :dest-width tw :dest-height th) 
     75        (make-instance 'node-extension 
     76                       :name name 
     77                       :base-node quad-node 
     78                       :image (make-store-image :class-name 'sat-image 
     79                                                :name (format nil "~A-~{~D~}" name path) 
     80                                                :initargs `(:path ,path 
     81                                                                  :image-geo-box ,rounded-geo-box))))))) 
     82 
    2583(defun make-sat-layer (image geo-box name &optional (start-depth 0))   
     84  (check-type name symbol) 
     85  (assert (not (find-sat-layer name))) 
     86  (check-type image cl-gd::image) 
     87  (assert (geo-box-encloses-p *m2-geo-box* geo-box))   
     88  (check-type start-depth (integer 0)) 
    2689  (labels ((layer-quad-nodes () 
    2790             (let (nodes) 
    …… 
    2992                                             (lambda (n) (when (= start-depth (depth n)) 
    3093                                                           (push n nodes))) 
    31                                              (lambda (n) (= start-depth (depth n)))) 
    32                nodes))) 
    33     (check-type image cl-gd::image) 
    34     (assert (geo-box-encloses-p *m2-geo-box* geo-box)) 
    35     (check-type name symbol) 
    36     (assert (not (find name (class-instances 'sat-layer) :key #'name))) 
    37     (check-type start-depth (integer 0)) 
    38     (let ((layer-quad-nodes (layer-quad-nodes))) 
    39       layer-quad-nodes))) 
     94                                             (lambda (n) (= start-depth (depth n))))                
     95               (mapcar 
     96                (lambda (quad-node) 
     97                  (list quad-node (geo-box-intersection geo-box (geo-box quad-node)))) 
     98                nodes))) 
     99           (quad-node (node) (first node)) 
     100           (tile-geo-box (node) (second node)) 
     101           (pw-ph-large-enough (node) 
     102             (multiple-value-bind (scaling pw ph) 
     103                 (sat-image-tile-properties image geo-box (tile-geo-box node)) 
     104               (declare (ignore scaling)) 
     105               (and (> pw 1) (> ph 1)))) 
     106           (max-scaling (nodes) 
     107             (reduce #'max nodes 
     108                     :key (lambda (node) 
     109                            (sat-image-tile-properties image geo-box (tile-geo-box node))))))     
     110    (let* ((nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes)))            
     111           (max-scaling (max-scaling nodes))) 
     112      (dolist (node nodes) 
     113        (make-sat-image-tile image geo-box (quad-node node) 
     114                             (tile-geo-box node) name max-scaling))))) 
    40115 
    41116;; (with-store-image (image (first (class-instances 'store-image)))