Changeset 2630

Show
Ignore:
Timestamp:
02/26/08 19:00:48 (9 months ago)
Author:
ksprotte
Message:

added with-bounding-box-collect and bounding-box to geometry

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/bos/projects/bos/m2/geometry.lisp

    r2454 r2630  
    7777  (<= (distance point center) radius)) 
    7878 
     79(defun point-in-rect-p (point left top width height) 
     80  (with-point point 
     81    (and (<= left point-x (1- (+ left width))) 
     82         (<= top point-y (1- (+ top height)))))) 
     83 
    7984;;; for fun... 
    8085(defun point-in-circle-p-test () 
    …… 
    8489          (princ "x") 
    8590          (princ "."))))) 
     91 
     92(defun bounding-box (objects &key (key #'identity)) 
     93  (let (min-x min-y max-x max-y) 
     94    (dolist (obj objects) 
     95      (let ((point (funcall key obj))) 
     96        (with-point point 
     97          (setf min-x (min point-x (or min-x point-x))) 
     98          (setf min-y (min point-y (or min-y point-y))) 
     99          (setf max-x (max point-x (or max-x point-x))) 
     100          (setf max-y (max point-y (or max-y point-y)))))) 
     101    (list min-x min-y (1+ (- max-x min-x)) (1+ (- max-y min-y))))) 
     102 
     103(defmacro with-bounding-box-collect ((collect) &body body) 
     104  `(let (min-x min-y max-x max-y)      
     105     (flet ((,collect (point) 
     106              (with-point point 
     107                (setf min-x (min point-x (or min-x point-x))) 
     108                (setf min-y (min point-y (or min-y point-y))) 
     109                (setf max-x (max point-x (or max-x point-x))) 
     110                (setf max-y (max point-y (or max-y point-y)))))) 
     111       ,@body) 
     112     (list min-x min-y (1+ (- max-x min-x)) (1+ (- max-y min-y))))) 
    86113 
    87114;;; directions 

  • branches/bos/projects/bos/m2/packages.lisp

    r2454 r2630  
    99           #:point-in-polygon-p 
    1010           #:point-in-circle-p 
     11           #:point-in-rect-p 
     12           #:bounding-box 
     13           #:with-bounding-box-collect 
    1114           #:find-boundary-point 
    1215           #:region-to-polygon 

  • branches/bos/projects/bos/web/kml-handlers.lisp

    r2589 r2630  
    8383  (error "Contract not found.")) 
    8484 
    85 ;;; static kml file demo generator 
    86 (defun demo-kml (&optional (path #p"/tmp/demo.kml")) 
    87   (with-open-file (out path :direction :output :if-exists :supersede 
    88                        :element-type '(unsigned-byte 8)) 
    89     (write-line "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" out) 
    90     (write-line "<kml xmlns=\"http://earth.google.com/kml/2.2\">" out) 
    91     (cxml:with-xml-output (cxml:make-octet-stream-sink out) 
    92       (with-element "Document" 
    93         (dolist (c (subseq (class-instances 'contract) 0 10)) 
    94           (let ((polygon (m2s-polygon-lon-lat (contract-m2s c))) 
    95                 (name (user-full-name (contract-sponsor c)))) 
    96             (with-element "Placemark" 
    97               (with-element "name" (utf-8-text (format nil "~A ~Dm²" 
    98                                                        (if name name "anonymous") 
    99                                                        (length (contract-m2s c))))) 
    100               (with-element "description" (utf-8-text (contract-description c :de))) 
    101               (with-element "Style" 
    102                 (attribute "id" "#region") 
    103                 (with-element "LineStyle" 
    104                   (with-element "color" (text "ffff3500"))) 
    105                 (with-element "PolyStyle" 
    106                   (with-element "color" (text (kml-format-color (contract-color c) 175))))) 
    107               (with-element "Polygon" 
    108                 (with-element "styleUrl" "#region") 
    109                 (with-element "tessellate" (text "1")) 
    110                 (with-element "outerBoundaryIs" 
    111                   (with-element "LinearRing" 
    112                     (with-element "coordinates" 
    113                       (text (kml-format-points polygon))))))))) 
    114         (dolist (poi (class-instances 'poi)) 
    115           (when (and (poi-area poi) 
    116                      (gethash "en" (poi-title poi))) 
    117             (destructuring-bind (poi-x poi-y) (poi-area poi) 
    118               (let ((utm-x (+ +nw-utm-x+ poi-x)) 
    119                     (utm-y (- +nw-utm-y+ poi-y)))      
    120                 (with-element "Placemark" 
    121                   (with-element "name" (text (gethash "en" (poi-title poi)))) 
    122                   (when (gethash "en" (poi-description poi)) 
    123                     (with-element "description" (text (gethash "en" (poi-description poi))))) 
    124                   (with-element "Point" 
    125                     (with-element "coordinates" 
    126                       (text (kml-format-points (list (geo-utm:utm-x-y-to-lon-lat utm-x utm-y +utm-zone+ t))))))))))))) 
    127     (write-line "</kml>" out))) 
    128  
    129 ;; (demo-kml) 
    130  
    131 (net.aserve:publish 
    132  :path "/ttt.kml" 
    133  :content-type "application/vnd.google-earth.kml+xml"  
    134  :function 
    135  #'(lambda (req ent) 
    136      (net.aserve:with-http-response (req ent) 
    137        (net.aserve:with-http-body (req ent) 
    138          (cxml:with-xml-output (cxml:make-octet-stream-sink *html-stream*) 
    139            (with-element "Document"                                           
    140              (dolist (poi (subseq (class-instances 'poi) 0 (parse-integer (net.aserve:request-query-value "n" req :post nil)))) 
    141                (when (and (poi-area poi) 
    142                           (gethash "en" (poi-title poi))) 
    143                  (destructuring-bind (poi-x poi-y) (poi-area poi) 
    144                    (let ((utm-x (+ +nw-utm-x+ poi-x)) 
    145                          (utm-y (- +nw-utm-y+ poi-y)))      
    146                      (with-element "Placemark" 
    147                        (with-element "name" (text (gethash "en" (poi-title poi)))) 
    148                        (when (gethash "en" (poi-description poi)) 
    149                          (with-element "description" (text (gethash "en" (poi-description poi))))) 
    150                        (with-element "Point" 
    151                          (with-element "coordinates" 
    152                            (text (kml-format-points (list (geo-utm:utm-x-y-to-lon-lat utm-x utm-y +utm-zone+ t))))))))))))))))) 
    153  
    154  
    155 (net.aserve:publish-prefix 
    156  :prefix "/kilian" 
    157  :function 
    158  #'(lambda (req ent) 
    159      (net.aserve:with-http-response (req ent) 
    160        (net.aserve:with-http-body (req ent) 
    161          (princ (net.aserve:request-uri req) *html-stream*) 
    162          )))) 
    163  
    164  
    165 (defun uri-x-y (uri) 
    166   (destructuring-bind (x y) 
    167       (last (ppcre:split #?r{/} (uri-path uri)) 2) 
    168     (values (parse-integer x) 
    169             (parse-integer y)))) 
    170  
    171 (defun publish-x-y (prefix function) 
    172   (net.aserve:publish-prefix 
    173    :prefix prefix 
     85#| 
     86 
     87indented to make emacs happy 
     88 
     89code will be deleted soon 
     90 
     91  ;;; static kml file demo generator 
     92  (defun demo-kml (&optional (path #p"/tmp/demo.kml")) 
     93    (with-open-file (out path :direction :output :if-exists :supersede 
     94                         :element-type '(unsigned-byte 8)) 
     95      (write-line "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" out) 
     96      (write-line "<kml xmlns=\"http://earth.google.com/kml/2.2\">" out) 
     97      (cxml:with-xml-output (cxml:make-octet-stream-sink out) 
     98        (with-element "Document" 
     99          (dolist (c (subseq (class-instances 'contract) 0 10)) 
     100            (let ((polygon (m2s-polygon-lon-lat (contract-m2s c))) 
     101                  (name (user-full-name (contract-sponsor c)))) 
     102              (with-element "Placemark" 
     103                (with-element "name" (utf-8-text (format nil "~A ~Dm²" 
     104                                                         (if name name "anonymous") 
     105                                                         (length (contract-m2s c))))) 
     106                (with-element "description" (utf-8-text (contract-description c :de))) 
     107                (with-element "Style" 
     108                  (attribute "id" "#region") 
     109                  (with-element "LineStyle" 
     110                    (with-element "color" (text "ffff3500"))) 
     111                  (with-element "PolyStyle" 
     112                    (with-element "color" (text (kml-format-color (contract-color c) 175))))) 
     113                (with-element "Polygon" 
     114                  (with-element "styleUrl" "#region") 
     115                  (with-element "tessellate" (text "1")) 
     116                  (with-element "outerBoundaryIs" 
     117                    (with-element "LinearRing" 
     118                      (with-element "coordinates" 
     119                        (text (kml-format-points polygon))))))))) 
     120          (dolist (poi (class-instances 'poi)) 
     121            (when (and (poi-area poi) 
     122                       (gethash "en" (poi-title poi))) 
     123              (destructuring-bind (poi-x poi-y) (poi-area poi) 
     124                (let ((utm-x (+ +nw-utm-x+ poi-x)) 
     125                      (utm-y (- +nw-utm-y+ poi-y))) 
     126                  (with-element "Placemark" 
     127                    (with-element "name" (text (gethash "en" (poi-title poi)))) 
     128                    (when (gethash "en" (poi-description poi)) 
     129                      (with-element "description" (text (gethash "en" (poi-description poi))))) 
     130                    (with-element "Point" 
     131                      (with-element "coordinates" 
     132                        (text (kml-format-points (list (geo-utm:utm-x-y-to-lon-lat utm-x utm-y +utm-zone+ t))))))))))))) 
     133      (write-line "</kml>" out))) 
     134   
     135  ;; (demo-kml) 
     136   
     137  (net.aserve:publish 
     138   :path "/ttt.kml" 
     139   :content-type "application/vnd.google-earth.kml+xml" 
    174140   :function 
    175141   #'(lambda (req ent) 
    176        (multiple-value-bind (x y) 
    177            (uri-x-y (net.aserve:request-uri req)) 
    178          (funcall function req ent x y))))) 
    179  
    180 (defun princ-text (obj) 
    181   (text (princ-to-string obj))) 
    182  
    183 (defun float-text (float) 
    184   (text (format nil "~F" float))) 
    185  
    186 (defun integer-text (integer) 
    187   (text (format nil "~D" integer))) 
    188  
    189 (defun kml-lat-lon-box (north south east west) 
    190   (with-element "LatLonBox" 
    191     (with-element "north" (float-text north)) 
    192     (with-element "south" (float-text south)) 
    193     (with-element "east" (float-text east)) 
    194     (with-element "west" (float-text west)))) 
    195  
    196 (defun kml-lat-lon-alt-box (north south east west) 
    197   (with-element "LatLonAltBox" 
    198     (with-element "north" (float-text north)) 
    199     (with-element "south" (float-text south)) 
    200     (with-element "east" (float-text east)) 
    201     (with-element "west" (float-text west)))) 
    202  
    203 (defun x-y2lon-lat (x y) 
    204   (destructuring-bind (lon lat) 
    205       (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t) 
    206     (values lon lat))) 
    207  
    208 (defun nw-se2box (nw-lon nw-lat se-lon se-lat) 
    209   (let ((north nw-lat) 
    210         (south se-lat) 
    211         (east se-lon) 
    212         (west nw-lon)) 
    213     (values north south east west))) 
    214  
    215 (defun x-y2box (nw-x nw-y se-x se-y) 
    216   (multiple-value-bind (nw-lon nw-lat) 
    217       (x-y2lon-lat nw-x nw-y) 
    218     (multiple-value-bind (se-lon se-lat) 
    219         (x-y2lon-lat se-x se-y) 
    220       (nw-se2box nw-lon nw-lat se-lon se-lat)))) 
    221  
    222 (publish-x-y 
    223  "/overview-kml" 
    224  #'(lambda (req ent x y) 
    225      (net.aserve:with-http-response (req ent) 
    226        (net.aserve:with-http-body (req ent) 
    227          (cxml:with-xml-output (cxml:make-octet-stream-sink *html-stream* :canonical nil) 
    228            (with-element "GroundOverlay"                                           
    229              (with-element "name" (text (format nil "overview-kml-~D-~D" x y))) 
    230              (with-element "Icon" 
    231                (with-element "href" (text (format nil "~A:~D/overview/~D/~D" *website-url* *port* x y))) 
    232                (with-element "refreshMode" (text "onRegion"))) 
    233              (multiple-value-bind (north south east west) 
    234                  (x-y2box x y (+ +m2tile-width+ x) (+ +m2tile-width+ y)) 
    235                (kml-lat-lon-box north south east west)))))))) 
    236  
    237 (publish 
    238  :path "/uebersicht.kml" 
    239  :function 
    240  #'(lambda (req ent) 
    241      (let ((x 0) 
    242            (y 0)) 
     142       (net.aserve:with-http-response (req ent) 
     143         (net.aserve:with-http-body (req ent) 
     144           (cxml:with-xml-output (cxml:make-octet-stream-sink *html-stream*) 
     145             (with-element "Document" 
     146               (dolist (poi (subseq (class-instances 'poi) 0 (parse-integer (net.aserve:request-query-value "n" req :post nil)))) 
     147                 (when (and (poi-area poi) 
     148                            (gethash "en" (poi-title poi))) 
     149                   (destructuring-bind (poi-x poi-y) (poi-area poi) 
     150                     (let ((utm-x (+ +nw-utm-x+ poi-x)) 
     151                           (utm-y (- +nw-utm-y+ poi-y))) 
     152                       (with-element "Placemark" 
     153                         (with-element "name" (text (gethash "en" (poi-title poi)))) 
     154                         (when (gethash "en" (poi-description poi)) 
     155                           (with-element "description" (text (gethash "en" (poi-description poi))))) 
     156                         (with-element "Point" 
     157                           (with-element "coordinates" 
     158                             (text (kml-format-points (list (geo-utm:utm-x-y-to-lon-lat utm-x utm-y +utm-zone+ t))))))))))))))))) 
     159   
     160   
     161  (net.aserve:publish-prefix 
     162   :prefix "/kilian" 
     163   :function 
     164   #'(lambda (req ent) 
     165       (net.aserve:with-http-response (req ent) 
     166         (net.aserve:with-http-body (req ent) 
     167           (princ (net.aserve:request-uri req) *html-stream*) 
     168           )))) 
     169   
     170   
     171  (defun uri-x-y (uri) 
     172    (destructuring-bind (x y) 
     173        (last (ppcre:split #?r{/} (uri-path uri)) 2) 
     174      (values (parse-integer x) 
     175              (parse-integer y)))) 
     176   
     177  (defun publish-x-y (prefix function) 
     178    (net.aserve:publish-prefix 
     179     :prefix prefix 
     180     :function 
     181     #'(lambda (req ent) 
     182         (multiple-value-bind (x y) 
     183             (uri-x-y (net.aserve:request-uri req)) 
     184           (funcall function req ent x y))))) 
     185   
     186  (defun princ-text (obj) 
     187    (text (princ-to-string obj))) 
     188   
     189  (defun float-text (float) 
     190    (text (format nil "~F" float))) 
     191   
     192  (defun integer-text (integer) 
     193    (text (format nil "~D" integer))) 
     194   
     195  (defun kml-lat-lon-box (north south east west) 
     196    (with-element "LatLonBox" 
     197      (with-element "north" (float-text north)) 
     198      (with-element "south" (float-text south)) 
     199      (with-element "east" (float-text east)) 
     200      (with-element "west" (float-text west)))) 
     201   
     202  (defun kml-lat-lon-alt-box (north south east west) 
     203    (with-element "LatLonAltBox" 
     204      (with-element "north" (float-text north)) 
     205      (with-element "south" (float-text south)) 
     206      (with-element "east" (float-text east)) 
     207      (with-element "west" (float-text west)))) 
     208   
     209  (defun x-y2lon-lat (x y) 
     210    (destructuring-bind (lon lat) 
     211        (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t) 
     212      (values lon lat))) 
     213   
     214  (defun nw-se2box (nw-lon nw-lat se-lon se-lat) 
     215    (let ((north nw-lat) 
     216          (south se-lat) 
     217          (east se-lon) 
     218          (west nw-lon)) 
     219      (values north south east west))) 
     220   
     221  (defun x-y2box (nw-x nw-y se-x se-y) 
     222    (multiple-value-bind (nw-lon nw-lat) 
     223        (x-y2lon-lat nw-x nw-y) 
     224      (multiple-value-bind (se-lon se-lat) 
     225          (x-y2lon-lat se-x se-y) 
     226        (nw-se2box nw-lon nw-lat se-lon se-lat)))) 
     227   
     228  (publish-x-y 
     229   "/overview-kml" 
     230   #'(lambda (req ent x y) 
    243231       (net.aserve:with-http-response (req ent) 
    244232         (net.aserve:with-http-body (req ent) 
    245233           (cxml:with-xml-output (cxml:make-octet-stream-sink *html-stream* :canonical nil) 
    246              (with-element "GroundOverlay"                                                        
     234             (with-element "GroundOverlay" 
     235               (with-element "name" (text (format nil "overview-kml-~D-~D" x y))) 
    247236               (with-element "Icon" 
    248                  (with-element "href" (text "http://plfreebsd:8080/infosystem/bilder/karte_uebersicht.jpg")) 
     237                 (with-element "href" (text (format nil "~A:~D/overview/~D/~D" *website-url* *port* x y))) 
    249238                 (with-element "refreshMode" (text "onRegion"))) 
    250239               (multiple-value-bind (north south east west) 
    251                    (x-y2box x y (+ +width+ x) (+ +width+ y)) 
    252                  (kml-lat-lon-box north south east west))))))))) 
    253  
    254 (publish-x-y 
    255  "/collection-kml" 
    256  #'(lambda (req ent x y) 
    257      (let ((num 8)) 
    258        (net.aserve:with-http-response (req ent) 
    259          (net.aserve:with-http-body (req ent) 
    260            (cxml:with-xml-output (cxml:make-octet-stream-sink *html-stream* :canonical t) 
    261              (multiple-value-bind (north south east west) 
    262                  (x-y2box x y (+ (* num +m2tile-width+) x) (+ (* num +m2tile-width+) y))              
    263                (with-element "kml" 
    264                  (attribute "xmlns" "http://earth.google.com/kml/2.1") 
    265                  (with-element "Document" 
    266                    ;; (with-element "Region" 
    267                    ;;                      ) 
    268                    (with-element "Link" 
    269                      (with-element "href" (text "http://plfreebsd:8080/uebersicht.kml")) 
    270                      (with-element "viewRefreshMode" (text "onRegion")))                    
    271                    (with-element "Folder" 
    272                      (with-element "name" (text "Nested Regions")) 
    273                      (with-element "Region" 
    274                        (kml-lat-lon-alt-box north south east west) 
    275                        (with-element "Lod" 
    276                          (with-element "minLodPixels" (integer-text 128)) 
    277                          (with-element "maxLodPixels" (integer-text -1))))                    
    278                      ;; link 
    279                      (loop for y-offset from 0 below num 
    280                         do (loop for x-offset from 0 below num 
    281                               do (multiple-value-bind (north south east west) 
    282                                      (x-y2box (+ (* x-offset +m2tile-width+) x) (+ (* y-offset +m2tile-width+) y) 
    283                                               (+ (* (1+ x-offset) +m2tile-width+) x) (+ (* (1+ y-offset) +m2tile-width+) y)) 
    284                                    (with-element "NetworkLink" 
    285                                      (with-element "Region" 
    286                                        (kml-lat-lon-alt-box north south east west) 
    287                                        (with-element "Lod" 
    288                                          (with-element "minLodPixels" (integer-text 128)) 
    289                                          (with-element "maxLodPixels" (integer-text -1))))                                    
    290                                      (with-element "Link" 
    291                                        (with-element "href" (text (format nil "~A:~D/overview-kml/~D/~D" 
    292                                                                           *website-url* *port* 
    293                                                                           (+ x (* +m2tile-width+ x-offset)) 
    294                                                                           (+ y (* +m2tile-width+ y-offset))))) 
    295                                        (with-element "viewRefreshMode" (text "onRegion"))))))))))))))))) 
    296  
    297  
     240                   (x-y2box x y (+ +m2tile-width+ x) (+ +m2tile-width+ y)) 
     241                 (kml-lat-lon-box north south east west)))))))) 
     242   
     243  (publish 
     244   :path "/uebersicht.kml" 
     245   :function 
     246   #'(lambda (req ent) 
     247       (let ((x 0) 
     248             (y 0)) 
     249         (net.aserve:with-http-response (req ent) 
     250           (net.aserve:with-http-body (req ent) 
     251             (cxml:with-xml-output (cxml:make-octet-stream-sink *html-stream* :canonical nil) 
     252               (with-element "GroundOverlay" 
     253                 (with-element "Icon" 
     254                   (with-element "href" (text "http://plfreebsd:8080/infosystem/bilder/karte_uebersicht.jpg")) 
     255                   (with-element "refreshMode" (text "onRegion"))) 
     256                 (multiple-value-bind (north south east west) 
     257                     (x-y2box x y (+ +width+ x) (+ +width+ y)) 
     258                   (kml-lat-lon-box north south east west))))))))) 
     259   
     260  (publish-x-y 
     261   "/collection-kml" 
     262   #'(lambda (req ent x y) 
     263       (let ((num 8)) 
     264         (net.aserve:with-http-response (req ent) 
     265           (net.aserve:with-http-body (req ent) 
     266             (cxml:with-xml-output (cxml:make-octet-stream-sink *html-stream* :canonical t) 
     267               (multiple-value-bind (north south east west) 
     268                   (x-y2box x y (+ (* num +m2tile-width+) x) (+ (* num +m2tile-width+) y)) 
     269                 (with-element "kml" 
     270                   (attribute "xmlns" "http://earth.google.com/kml/2.1") 
     271                   (with-element "Document" 
     272                     ;; (with-element "Region" 
     273                     ;;                      ) 
     274                     (with-element "Link" 
     275                       (with-element "href" (text "http://plfreebsd:8080/uebersicht.kml")) 
     276                       (with-element "viewRefreshMode" (text "onRegion"))) 
     277                     (with-element "Folder" 
     278                       (with-element "name" (text "Nested Regions")) 
     279                       (with-element "Region" 
     280                         (kml-lat-lon-alt-box north south east west) 
     281                         (with-element "Lod" 
     282                           (with-element "minLodPixels" (integer-text 128)) 
     283                           (with-element "maxLodPixels" (integer-text -1)))) 
     284                       ;; link 
     285                       (loop for y-offset from 0 below num 
     286                          do (loop for x-offset from 0 below num 
     287                                do (multiple-value-bind (north south east west) 
     288                                       (x-y2box (+ (* x-offset +m2tile-width+) x) (+ (* y-offset +m2tile-width+) y) 
     289                                                (+ (* (1+ x-offset) +m2tile-width+) x) (+ (* (1+ y-offset) +m2tile-width+) y)) 
     290                                     (with-element "NetworkLink" 
     291                                       (with-element "Region" 
     292                                         (kml-lat-lon-alt-box north south east west) 
     293                                         (with-element "Lod" 
     294                                           (with-element "minLodPixels" (integer-text 128)) 
     295                                           (with-element "maxLodPixels" (integer-text -1)))) 
     296                                       (with-element "Link" 
     297                                         (with-element "href" (text (format nil "~A:~D/overview-kml/~D/~D" 
     298                                                                            *website-url* *port* 
     299                                                                            (+ x (* +m2tile-width+ x-offset)) 
     300                                                                            (+ y (* +m2tile-width+ y-offset))))) 
     301                                         (with-element "viewRefreshMode" (text "onRegion"))))))))))))))))) 
     302 
     303|# 
     304