root/trunk/projects/bos/web/map-browser-handler.lisp

Revision 3757, 7.1 kB (checked in by ksprotte, 3 months ago)

MAP-BROWSER-HANDLER is more careful when appending get-parameters to CHOSEN-URL
(it now inserts a '&', if needed)

Line 
1 ;; please don't read this code, it is not pretty
2
3 (in-package :bos.web)
4
5 (enable-interpol-syntax)
6
7 ;; map-browser-handler
8
9 ;; Dient zur Auswahl eines Punktes auf dem ProjektgelÀnde.  ZunÀchst
10 ;; wird die Übersichtskarte angezeigt (360x360 Pixel).  Bei Klick auf
11 ;; die Karte wird die unverkleinerte Overview-Ansicht angezeigt.
12 ;; Durch einen weiteren Klick wird die Position ausgewÀhlt.  Bei
13 ;; Auswahl des Punktes wird zu der im url-Parameter festgelegten URL
14 ;; verzweigt, die Koordinaten des Punktes werden als 'x'- und
15 ;; 'y'-Parameter an diese URL ÃŒbergeben.
16
17 (defclass map-browser-handler (prefix-handler)
18   ())
19
20 (defun decode-coords-in-handler-path (handler)
21   (labels ((ensure-valid-coordinates (x y)
22              (setq x (parse-integer x))
23              (setq y (parse-integer y))
24              (when (and (<= 491698 x 502498)
25                         (<= 9879300 y 9890100))
26                (decf x 491698)
27                (decf y 9879300))
28              (unless (and (<= 0 x 10800)
29                           (<= 0 y 10800))
30                (error "invalid coordinates ~A/~A" x y))
31              (list x y)))
32     (with-query-params (xcoord ycoord)
33       (when (and xcoord ycoord)
34         (return-from decode-coords-in-handler-path (ensure-valid-coordinates xcoord ycoord))))
35     (let ((handler-arguments (decoded-handler-path handler)))
36       (when (and handler-arguments
37                  (< 1 (length handler-arguments)))
38         (apply #'ensure-valid-coordinates handler-arguments)))))
39
40 (defmethod handle ((handler map-browser-handler))
41   (flet ((append-&-if-needed (string)
42            (if (char= #\& (char string (1- (length string))))
43                string
44                (concatenate 'string string "&"))))
45     (with-query-params (chosen-url)
46       (when chosen-url
47         (setf (hunchentoot:session-value :chosen-url) (append-&-if-needed chosen-url)))))
48   (with-query-params (view-x view-y)
49     (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string)
50       (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler)
51         (with-query-params (action)
52           (when (equal action "save")
53             (if (hunchentoot:session-value :chosen-url)
54                 (redirect (format nil "~Ax=~D&y=~D"
55                                   (hunchentoot:session-value :chosen-url)
56                                   point-x
57                                   point-y))
58                 (with-bos-cms-page (:title "Map Point Chooser")
59                   (html (:princ-safe "You chose " point-x " / " point-y))))
60             (return-from handle t)))
61         (cond
62           ((and view-x view-y)
63            (setq view-x (parse-integer view-x)
64                  view-y (parse-integer view-y)))
65           (t
66            (setq view-x point-x
67                  view-y point-y)))
68         (let ((start-tile (and point-y
69                                (ensure-map-tile (max 0 (- view-x 180))
70                                                 (max 0 (- view-y 180))))))
71           (when (and point-y click-y)
72             (let ((click-coord-x (+ (tile-nw-x start-tile) click-x))
73                   (click-coord-y (+ (tile-nw-y start-tile) click-y)))
74               (setq point-x click-coord-x
75                     point-y click-coord-y)
76               (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y))
77               (return-from handle t)))
78           (cond
79             ((and click-y (not point-y))
80              (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y))))
81             (point-y
82              (with-bos-cms-page (:title "Map Point Chooser")
83                (with-query-params (heading)
84                  (when heading
85                    (html (:h2 (:princ-safe heading)))))
86                (html
87                 ((:script :language "JavaScript")
88                  "
89 function updateCoords() {
90         var new_x = document.mapnavigator.xcoord.value;
91         var new_y = document.mapnavigator.ycoord.value;
92         document.location.href = '/map-browser/' + new_x + '/' + new_y;
93
94         return false;
95 }
96 "
97                  ))
98                (html ((:div :style "position:relative; height:400px;")
99                       ((:div :id "overview"
100                              :style "position:absolute; left:0px; top:0px;")
101                        ((:a :href "/map-browser/")
102                         ((:img :ismap "ismap" :width "360" :height "360" :border "0" :src "/images/sl_all.jpg"))))
103                       (let ((view-cursor-x (- (round (tile-nw-x start-tile) 30) 2))
104                             (view-cursor-y (- (round (tile-nw-y start-tile) 30) 2)))
105                         (html ((:div :id "overview-cursor-tile"
106                                      :style #?"position:absolute; left:$(view-cursor-x)px; top:$(view-cursor-y)px")
107                                ((:img :src "/images/overview-cursor.png")))))
108                       (let ((point-x (- (round point-x 30) 2))
109                             (point-y (- (round point-y 30) 2)))
110                         (html ((:div :id "overview-cursor"
111                                      :style #?"position:absolute; left:$(point-x)px; top:$(point-y)px")
112                                ((:img :src "/images/map-cursor.png" :width 5 :height 5)))))
113                       (loop for y from 0 upto 270 by 90
114                          for tile-index-y from 0 by 1
115                          for map-y = (+ (tile-nw-y start-tile) y)
116                          for screen-y = y
117                          do (loop for x from 0 upto 270 by 90
118                                for map-x = (+ (tile-nw-x start-tile) x)
119                                for tile-index-x from 0 by 1
120                                for screen-x = (+ x 380)
121                                do (html ((:div :id #?"tile-$(tile-index-x)-$(tile-index-y)"
122                                                :style #?"position:absolute; left:$(screen-x)px; top:$(screen-y)px;")
123                                          ((:img :width "90" :height "90"
124                                                             :border "0"
125                                                             :src #?"/overview/$(map-x)/$(map-y)"))))))
126                       ((:div :id "overlay"
127                              :style #?"position:absolute; left:380px; top:0px; width:360px; height:360px;")
128                        ((:a :href #?"/map-browser/$(point-x)/$(point-y)")
129                         ((:img :src "/images/trans.gif" :ismap "ismap" :border "0" :width "360" :height "360"))))
130                       (let* ((cursor-x (- (+ 380 (- point-x (tile-nw-x start-tile))) 8)) ; 380 -> horizontal offset for tiled map
131                              (cursor-y (- point-y (tile-nw-y start-tile) 8)))
132                         (html
133                          ((:div :id "cursor"
134                                 :style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible")
135                           ((:img :src "/images/map-cursor.png")))))))
136                (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();")))
137             (t
138              (with-bos-cms-page (:title "Map Point Chooser")
139                (html
140                 ((:a :href "/map-browser/")
141                  ((:img :ismap "ismap" :src "/image/sl_all"))))))))))))
Note: See TracBrowser for help on using the browser.