1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011, 2012 Bert Burgemeister
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 2 of the License, or
7 ;;; (at your option) any later version.
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
14 ;;; You should have received a copy of the GNU General Public License along
15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 (hunchentoot:define-easy-handler
(phoros.js
) ()
21 "Serve some Javascript."
22 (assert-authentication)
25 (setf debug-info
(@ *open-layers
*console info
))
27 (defmacro inner-html-with-id
(id)
28 "innerHTML of element with id=\"id\"."
29 `(chain document
(get-element-by-id ,id
) inner-h-t-m-l
))
31 (defmacro value-with-id
(id)
32 "Value of element with id=\"id\"."
33 `(chain document
(get-element-by-id ,id
) value
))
35 (defmacro checkbox-status-with-id
(id)
36 "Whether checkbox with id=\"id\" is checked or not."
37 `(chain document
(get-element-by-id ,id
) checked
))
43 (:p
"User role. \"Read\" can't write or modify anything.
44 \"Write\" may write user points and edit/delete their own
45 ones (and ownerless points). \"Admin\" may write user
46 points and edit/delete points written by anyone."))
47 :presentation-project-name
49 (:p
"Presentation project name."))
50 :presentation-project-emptiness
52 (:p
"This presentation project is empty. You can't do much
54 :recommend-fresh-login
56 (:p
"Sorry, but you are no longer authenticated. Your
57 session may have expired due to prolonged inactivity, or an
58 administrator has kicked you out by restarting the server.")
59 (:p
"Please repeat the login process."))
62 (:p
"Caching images.")
63 (:p
"As I'm currently idle, I'm preemptively putting images
64 into your browser's cache which later on may help speed up
67 (:code
"about:cache?device=disk")
68 (:p
"into your address bar to see what's going on there.")
69 (:p
"Your browser cache size should be set to 2000 GB or
70 bigger. Bigger is better."))
73 (:p
"Phoros version.")
74 (:p
"In a version string A.B.C, changes in A denote
75 incompatible changes in data (you can't access a database
76 set up by a different version of Phoros); changes in B mean
77 user-visible changes in feature set; changes in C denote
78 bug fixes and minor improvements."))
81 (:p
"Current action."))
82 :multiple-points-viewer
84 (:p
"Try reading the text under mouse pointer."))
87 (:p
"Delete current point."))
90 (:p
"Store user point with its attributes kind,
91 numeric-description and description, and with its auxiliary
92 data into database; warn if the given set of attributes
94 :suggest-unique-button
96 (:h3
"Non-unique set of user point attributes")
97 (:p
"Recommend a set of user point attributes that is
98 unique among the currently defined user points, preferably
99 by incrementing a portion of attribute numeric-description
100 that looks like a number."))
101 :force-duplicate-button
103 (:h3
"Non-unique set of user point attributes")
104 (:p
"Store user point with its attributes kind,
105 numeric-description and description, and with its auxiliary
106 data into database; don't care whether the given set of
107 attributes is unique."))
108 :download-user-points-button
110 (:p
"Download all user points as GeoJSON-fomatted text
111 file. Do this regularly if you don't want to lose your
112 work due to server crashes or major Phoros updates.")
113 (:p
"Points saved this way can be fed back into your
114 project using the command line interface (on server or on
115 any other host where the database is reachable)."))
119 (:p
"The standard ones, polygon, polyline, and solitary, are
120 rendered as asterisk, square, and triangle respectively.
121 The numbers 0 to 9, if used as values, are mapped to an
122 alternative set of distinct symbols. Anything else is
126 (:h3
"\"description\"")
127 (:p
"Optional textual description of the set of user points
128 the current point belongs to."))
129 :point-numeric-description
131 (:h3
"\"numeric-description\"")
132 (:p
"Optional description of the current user point. It is
133 occasionally used to label representations of this point in
134 streetmap and in images.")
135 (:p
"It should contain a numeric part, possibly with
136 leading zeros, which will be incremented automatically to
137 make the attribute sets of points with otherwise identical
138 attributes unique."))
141 (:p
"Creation date of current user point. Will be updated
142 when you change this point."))
145 (:p
"Check this if the user point being created is to
146 include auxiliary data."))
147 :display-nearest-aux-data
149 (:p
"Check this to see auxiliary data near streetmap
151 (:p
"You need to uncheck this before you can select user
152 points in streetmap."))
155 (:p
"Select a set of auxiliary data by its distance (in
156 metres) from the current estimated position if any, or its
157 distance from streetmap cursor otherwise.")
158 (:p
"Alternatively, a set of auxiliary data is also
159 selectable by clicking its representation in streetmap."))
162 (:p
"Auxiliary data connected to this presentation project;
163 all the numeric values followed by all the text values if
167 (:p
"Creator of current user point. Will be updated when
168 you change this point."))
169 :remove-work-layers-button
171 (:p
"Discard the current, unstored user point or unselect
172 any selected user points. Zoom out all images. Keep
173 the rest of the workspace untouched."))
176 (:p
"View some info about Phoros."))
179 (:p
"Finish this session after storing current streetmap
180 zoom status and your cursor position.")
181 (:p
"Fresh login is required to continue."))
184 (:p
"Clicking into the streetmap fetches images which most
185 probably feature the clicked point.")
186 (:p
"To pan the map, drag the mouse. To zoom, spin the
187 mouse wheel, or hold shift down whilst dragging a box, or
188 double-click (shift double-click for larger zoom steps) a
189 point of interest."))
192 (:p
"Clicking into an image sets or resets the active point
193 there. Once a feature is marked by active points in more
194 than one image, the estimated position is calculated.")
195 (:p
"To pan an image, drag the mouse. To zoom, spin the
196 mouse wheel, or hold shift down whilst dragging a box, or
197 double-click (shift double-click for larger zoom steps) a
198 point of interest."))
199 ol-Control-Pan-West-Item-Inactive
201 (:p
"Move viewport left."))
202 ol-Control-Pan-East-Item-Inactive
204 (:p
"Move viewport right."))
205 ol-Control-Pan-North-Item-Inactive
207 (:p
"Move viewport up."))
208 ol-Control-Pan-South-Item-Inactive
210 (:p
"Move viewport down."))
211 ol-Control-Zoom-In-Item-Inactive
214 ol-Control-Zoom-Out-Item-Inactive
217 streetmap-Zoom-To-Max-Extent-Item-Inactive
219 (:p
"Zoom to the extent of presentation project."))
220 ol-Control-Zoom-To-Max-Extent-Item-Inactive
222 (:p
"Zoom out completely, restoring the original view."))
223 :zoom-images-to-max-extent
225 (:p
"Zoom all images out completely, restoring the original
229 (:p
"I haven't been able to display a set of images that
230 cover a common area because I couldn't find the necessary
231 information. As a fallback, I'm displaying a set of images
232 with points of view close to the point you selected.")
233 (:p
"The server is probably trying to remedy this problem
234 but this may take some time."))
238 (:p
"Check this to automatically zoom into images once they
239 get an estimated position."))
242 (:p
"Check this to have underexposed images brightened up.")
243 (:p
"Brightening starts with the next set of images and may
244 slow things down a bit."))
247 (:p
"Check this to snap your current position onto a line
248 along points of auxiliary data, and to keep streetmap
249 centered around current position."))
252 (:p
"Decrease step size. Double-click to decrease harder."))
255 (:p
"Step size in metres. Click to increase; double-click
256 to increase harder."))
259 (:p
"Increase step size. Double-click to increase harder."))
262 (:p
"Move your position by one step on a line along points
263 of auxiliary data. Double-click to change direction."))
264 :image-layer-switcher
266 (:p
"Toggle display of image."))
269 (:p
"No photogrammetric survey possible as there isn't any
270 usable calibration data available for this image.")
271 (:p
"This means no image footprints can be calculated
272 either which prevents me from selecting images covering a
276 (:p
"Time this image was taken."))
279 (:p
"Choose a background streetmap."))
282 (:p
"Toggle visibility of data layers."))
283 :unselect-all-restrictions-button
285 (:h3
"Image Restrictions")
286 (:p
"Remove all image restrictions."))
289 (:h3
"Image Restrictions")
290 (:p
"Select one ore more of the restrictions in order to
291 consider only a subset of the images available. No
292 selection at all means no restriction.")
293 (:p
"Shift-click selects a range of restrictions,
294 control-click selects or unselects a particular
295 restriction, click selects a restriction unselecting
299 (:p
"Click to re-center streetmap, or drag the red
301 :streetmap-mouse-position
303 (:p
"Cursor position in geographic coordinates when cursor
307 (:p
"Hints on Phoros' displays and controls are shown here
308 while hovering over the respective elements."))))
310 (defun add-help-topic (topic element
)
311 "Add mouse events to DOM element that initiate display of a
314 (setf (@ element onmouseover
)
316 (lambda () (show-help x
)))
318 (setf (@ element onmouseout
) show-help
)))
320 (defun add-help-events ()
321 "Add mouse events to DOM elements that initiate display of a
324 (topic *help-topics
*)
325 (add-help-topic topic
(chain document
(get-element-by-id topic
)))
326 (dolist (element (chain document
(get-elements-by-class-name topic
)))
327 (add-help-topic topic element
))))
329 (defun show-help (&optional topic
)
330 "Put text on topic into help-display"
331 (setf (inner-html-with-id "help-display")
332 (let ((help-body (getprop *help-topics
* topic
)))
333 (if (undefined help-body
)
337 (defvar *click-control
*
341 (@ *open-layers
*control
)
349 (apply this arguments
))
350 (setf (@ this handler
)
351 (new (chain *open-layers
355 :click
(@ this trigger
)))))))))))
357 (defvar +unix-epoch
+ (lisp *unix-epoch
*)
358 "Seconds between Lisp epoch and UNIX epoch.")
360 (new (chain *open-layers
(*projection
"EPSG:4326"))))
361 (defvar +spherical-mercator
+
362 (new (chain *open-layers
(*projection
"EPSG:900913"))))
366 "First element of URL path; defaults to phoros but may be
367 turned into something different by an HTTP proxy
370 (defvar +user-name
+ (lisp (hunchentoot:session-value
'user-name
))
371 "User's (short) name.")
372 (defvar +user-role
+ (lisp (string-downcase (hunchentoot:session-value
374 "User's permissions.")
376 (defvar +presentation-project-bbox-text
+
377 (lisp (hunchentoot:session-value
'presentation-project-bbox
)))
379 (defvar +presentation-project-bounds
+
380 (chain (new (chain *open-layers
383 (or +presentation-project-bbox-text
+
384 "-180,-89,180,89"))))
385 (transform +geographic
+ +spherical-mercator
+))
386 "Bounding box of the entire presentation project.")
389 (lisp (hunchentoot:session-value
'aux-data-p
)))
391 (defvar +aux-numeric-labels
+
392 (lisp (when *aux-numeric-labels
*
393 (coerce *aux-numeric-labels
* 'vector
))))
395 (defvar +aux-text-labels
+
396 (lisp (when *aux-text-labels
*
397 (coerce *aux-text-labels
* 'vector
))))
399 (defvar *images
* (array) "Collection of the photos currently shown.")
401 (defvar *streetmap
* undefined
402 "The streetmap shown to the user.")
404 (defvar *aux-point-distance-select
* undefined
405 "The HTML element for selecting one of a few nearest
408 (defvar *global-position
* undefined
409 "Coordinates of the current estimated position")
411 (defvar *linestring-step-ratio
* 4
412 "Look for auxiliary points to include into linestring within
413 a radius of *linestring-step-ratio* multilied by multiplied by
416 (defvar *current-nearest-aux-point
*
417 (create attributes
(create aux-numeric undefined
419 "Attributes of currently selected point of auxiliary data.")
421 (defvar *bbox-strategy
* (@ *open-layers
*strategy
*bbox
*))
422 (setf (@ *bbox-strategy
* prototype ratio
) 1.5)
423 (setf (@ *bbox-strategy
* prototype res-factor
) 1.5)
425 (defvar *json-parser
* (new (chain *open-layers
*format
*json
*)))
427 (defvar *geojson-parser
* (new (chain *open-layers
*format
*geo-j-s-o-n
)))
429 (defvar *geojson-format
* (chain *open-layers
*format
*geo-j-s-o-n
))
430 (setf (@ *geojson-format
* prototype ignore-extra-dims
)
431 t
) ;doesn't handle height anyway
432 (setf (@ *geojson-format
* prototype external-projection
)
434 (setf (@ *geojson-format
* prototype internal-projection
)
438 (new (chain *open-layers
441 (create external-projection
+geographic
+
442 internal-projection
+spherical-mercator
+)))))
444 (defvar *http-protocol
* (chain *open-layers
*protocol
*http
*))
445 (setf (chain *http-protocol
* prototype format
) (new *geojson-format
*))
447 (defvar *pristine-images-p
* t
448 "T if none of the current images has been clicked into yet.")
450 (defvar *current-user-point
* undefined
451 "The currently selected user-point.")
453 (defun write-permission-p (&optional
(current-owner +user-name
+))
454 "Nil if current user can't edit stuff created by
455 current-owner or, without arguments, new stuff."
456 (or (equal +user-role
+ "admin")
457 (and (equal +user-role
+ "write")
458 (or (equal +user-name
+ current-owner
)
459 (not current-owner
)))))
462 "Anything necessary to deal with a photo."
468 (create projection
+spherical-mercator
+
470 controls
(array (new (chain *open-layers
472 (*navigation
)))))))))
473 (setf (@ this dummy
) false
) ;TODO why? (omitting splices map components directly into *image)
476 (setf (@ *image prototype delete-photo
)
478 (setf (@ *image prototype photop
)
480 (setf (@ *image prototype show-photo
)
482 (setf (@ *image prototype draw-epipolar-line
)
484 (setf (@ *image prototype draw-active-point
)
486 (setf (@ *image prototype draw-estimated-positions
)
487 draw-estimated-positions
)
489 (defun photo-path (photo-parameters)
490 "Create from stuff found in photo-parameters and in checkbox
491 brighten-images-p a path with parameters for use in an image
495 (@ photo-parameters directory
) "/"
496 (@ photo-parameters filename
) "/"
497 (@ photo-parameters byte-position
) ".png"
498 "?mounting-angle=" (@ photo-parameters mounting-angle
)
499 "&bayer-pattern=" (@ photo-parameters bayer-pattern
)
500 "&color-raiser=" (@ photo-parameters color-raiser
)
501 (if (checkbox-status-with-id "brighten-images-p")
505 (defun has-layer-p (map layer-name
)
506 "False if map doesn't have a layer called layer-name."
507 (chain map
(get-layers-by-name layer-name
) length
))
509 (defun some-active-point-p ()
510 "False if no image in *images* has an Active Point."
512 for i across
*images
*
513 sum
(has-layer-p (@ i map
) "Active Point")))
515 (defun remove-layer (map layer-name
)
516 "Destroy layer layer-name in map."
517 (when (has-layer-p map layer-name
)
518 (chain map
(get-layers-by-name layer-name
) 0 (destroy))))
520 (defun remove-any-layers (layer-name)
521 "Destroy in all *images* and in *streetmap* the layer named layer-name."
523 for i across
*images
* do
524 (remove-layer (@ i map
) layer-name
))
525 (remove-layer *streetmap
* layer-name
))
527 (defun reset-controls ()
528 (disable-element-with-id "finish-point-button")
529 (disable-element-with-id "delete-point-button")
530 (disable-element-with-id "remove-work-layers-button")
531 (setf (inner-html-with-id "creator") nil
)
532 (setf (inner-html-with-id "point-creation-date") nil
)
533 (hide-aux-data-choice)
534 (setf (inner-html-with-id "aux-numeric-list") nil
)
535 (setf (inner-html-with-id "aux-text-list") nil
))
537 (defun disable-streetmap-nearest-aux-points-layer ()
538 "Get (@ *streetmap* nearest-aux-points-layer) out of the way,
539 i.e., remove features and disable feature select control so
540 it won't shadow any other control."
541 (chain *streetmap
* nearest-aux-points-layer
(remove-all-features))
542 (chain *streetmap
* nearest-aux-points-select-control
(deactivate))
543 (chain *streetmap
* user-points-select-control
(activate)))
545 (defun reset-layers-and-controls ()
546 "Destroy user-generated layers in *streetmap* and in all
547 *images*, and put controls into pristine state."
548 (remove-any-layers "Epipolar Line")
549 (remove-any-layers "Active Point")
550 (remove-any-layers "Estimated Position")
551 (remove-any-layers "User Point")
552 (chain *streetmap
* user-points-select-control
(unselect-all))
553 (when (and (not (equal undefined
*current-user-point
*))
554 (@ *current-user-point
* layer
))
556 user-points-select-control
557 (unselect *current-user-point
*)))
560 (switch-phoros-controls-to "aux-data-viewer")
561 (switch-phoros-controls-to "point-creator"))
562 (setf *pristine-images-p
* t
)
563 (if (and +aux-data-p
+
564 (checkbox-status-with-id "display-nearest-aux-data-p"))
565 (request-aux-points-near-cursor 30)
566 (disable-streetmap-nearest-aux-points-layer))
567 (zoom-images-to-max-extent))
569 (defun enable-element-with-id (id)
570 "Activate HTML element with id=\"id\". Return t if element
571 was greyed out before."
573 (chain document
(get-element-by-id id
) disabled
)
574 (setf (chain document
(get-element-by-id id
) disabled
) nil
)))
576 (defun enable-elements-of-class (class-name)
577 "Activate HTML elements with class=\"class\"."
579 for element in
(chain document
580 (get-elements-by-class-name class-name
))
581 do
(setf (@ element disabled
) nil
)))
583 (defun disable-element-with-id (id)
584 "Grey out HTML element with id=\"id\". Return t if element
587 (not (chain document
(get-element-by-id id
) disabled
))
588 (setf (chain document
(get-element-by-id id
) disabled
) t
)))
590 (defun hide-element-with-id (id)
591 "Hide HTML element with id=\"id\"."
592 (setf (chain document
(get-element-by-id id
) style display
)
595 (defun hide-elements-of-class (class-name)
596 "Hide HTML elements with class=\"class\"."
598 for element in
(chain document
599 (get-elements-by-class-name class-name
))
600 do
(setf (@ element style display
) "none")))
602 (defun reveal-element-with-id (id)
603 "Reveal HTML element with id=\"id\"."
604 (setf (chain document
(get-element-by-id id
) style display
)
607 (defun reveal-elements-of-class (class-name)
608 "Reveal HTML elements with class=\"class\"."
610 for element in
(chain document
611 (get-elements-by-class-name class-name
))
612 do
(setf (@ element style display
) "")))
614 (defun switch-phoros-controls-to (class-name)
615 "Reveal elements of class class-name; hide anything else.
616 Unless there is auxiliary data available, hide the related
618 (let ((phoros-controls-classes
619 '("point-creator" "point-editor" "point-viewer"
620 "multiple-points-viewer" "aux-data-viewer")))
621 (dolist (c phoros-controls-classes
)
622 (unless (equal c class-name
) (hide-elements-of-class c
))))
623 (reveal-elements-of-class class-name
)
625 (hide-elements-of-class "aux-data-dependent")))
627 (defun hide-aux-data-choice ()
628 "Disable selector for auxiliary data."
629 (hide-element-with-id "include-aux-data")
630 (hide-element-with-id "aux-point-distance")
631 (setf (chain document
632 (get-element-by-id "aux-point-distance")
637 (defun refresh-layer (layer)
638 "Have layer re-request and redraw features."
639 (chain layer
(refresh (create :force t
))))
641 (defun present-photos ()
642 "Handle the response triggered by request-photos-for-point."
643 (let ((photo-parameters
646 photo-request-response response-text
)))))
648 for i across
*images
*
649 do
(chain i
(delete-photo)))
650 (if (@ photo-parameters
0 footprintp
)
651 (hide-element-with-id "no-footprints-p")
652 (reveal-element-with-id "no-footprints-p"))
654 for p across photo-parameters
655 for i across
*images
*
657 (setf (@ i photo-parameters
) p
)
658 (chain i
(show-photo)))))
660 (defun recommend-fresh-login ()
661 "Notify user about invalid authentication."
662 (setf (inner-html-with-id "recommend-fresh-login")
663 "(not authenticated)")
664 (disable-element-with-id "download-user-points-button")
665 (disable-element-with-id "blurb-button")
666 (hide-element-with-id "phoros-controls")
667 (hide-element-with-id "images"))
669 (defun consolidate-combobox (combobox-id)
670 "Help faking a combobox: copy selected option into input."
671 (let* ((combobox-select (+ combobox-id
"-select"))
672 (combobox-input (+ combobox-id
"-input"))
673 (combobox-selected-index
675 (get-element-by-id combobox-select
)
677 (when (< -
1 combobox-selected-index
)
678 (setf (value-with-id combobox-input
)
679 (getprop (chain document
680 (get-element-by-id combobox-select
)
682 combobox-selected-index
685 (get-element-by-id combobox-input
)
688 (defun unselect-combobox-selection (combobox-id)
689 "Help faking a combobox: unset selected option so any
690 selection there will trigger an onchange event."
691 (let ((combobox-select (+ combobox-id
"-select")))
692 (setf (chain document
693 (get-element-by-id combobox-select
)
697 (defun stuff-combobox (combobox-id values
&optional
(selection -
1))
698 "Stuff combobox with values. If selection is a non-negative
699 integer, select the respective item."
700 (let ((combobox-select (+ combobox-id
"-select"))
701 (combobox-input (+ combobox-id
"-input")))
702 (setf (chain document
703 (get-element-by-id combobox-select
)
708 (loop for i in values do
710 (chain document
(create-element "option")))
711 (setf (@ combobox-item text
) i
)
713 (get-element-by-id combobox-select
)
714 (add combobox-item null
)))
715 (setf (chain document
716 (get-element-by-id combobox-select
)
719 (consolidate-combobox combobox-id
)))
721 (defun stuff-user-point-comboboxes (&optional selectp
)
722 "Stuff user point attribute comboboxes with sensible values.
723 If selectp it t, select the most frequently used one."
727 user-point-choice-response response-text
))))
729 (chain response kinds
(map (lambda (x)
732 (chain response descriptions
(map (lambda (x)
733 (@ x description
)))))
735 (best-used-description -
1))
739 for i across
(@ response descriptions
)
741 do
(when (< maximum
(@ i count
))
742 (setf maximum
(@ i count
))
743 (setf best-used-description k
)))
746 for i across
(@ response kinds
)
748 do
(when (< maximum
(@ i count
))
749 (setf maximum
(@ i count
))
750 (setf best-used-kind k
))))
752 "point-kind" kinds best-used-kind
)
754 "point-description" descriptions best-used-description
)))
756 (defun request-user-point-choice (&optional selectp
)
757 "Stuff user point attribute comboboxes with sensible values.
758 If selectp it t, select the most frequently used one."
759 (setf (@ *streetmap
* user-point-choice-response
)
764 (create :url
(+ "/" +proxy-root
+
765 "/lib/user-point-attributes.json")
767 :headers
(create "Content-type" "text/plain")
769 (stuff-user-point-comboboxes selectp
))
770 :failure recommend-fresh-login
)))))
772 (defun stuff-restriction-select ()
773 "Stuff available restriction IDs into restriction-select."
777 restriction-select-choice-response
779 (restriction-select-options
781 (get-element-by-id "restriction-select")
784 for restriction in response
786 do
(setf (elt restriction-select-options i
)
787 (new (chain (*option restriction
)))))))
789 (defun request-restriction-select-choice ()
790 "Stuff available restriction IDs into restriction-select."
791 (setf (@ *streetmap
* restriction-select-choice-response
)
796 (create :url
(+ "/" +proxy-root
+
797 "/lib/selectable-restrictions.json")
799 :headers
(create "Content-type" "text/plain")
800 :success stuff-restriction-select
801 :failure recommend-fresh-login
)))))
803 (defun selected-restrictions ()
804 "Return list of restriction IDs selected by user."
805 (let ((restriction-select-options
807 (get-element-by-id "restriction-select")
810 for restriction in restriction-select-options
811 when
(@ restriction selected
)
812 collect
(@ restriction text
))))
814 (defun unselect-all-restrictions ()
815 "Clear any selected restrictions."
817 for option across
(chain document
818 (get-element-by-id "restriction-select")
820 do
(setf (@ option selected
) f
))
823 (defun request-photos-after-click (event)
824 "Handle the response to a click into *streetmap*; fetch photo
825 data. Set or update streetmap cursor."
826 (request-photos (chain *streetmap
*
827 (get-lon-lat-from-pixel (@ event xy
)))))
829 (defun request-photos (&optional lonlat
)
830 "Set streetmap cursor to lonlat if provided. Fetch photo
831 data for a point near streetmap cursor."
833 (setf (@ *streetmap
* clicked-lonlat
) lonlat
))
834 (if (checkbox-status-with-id "walk-p")
835 (request-aux-data-linestring-for-point
836 (@ *streetmap
* clicked-lonlat
))
837 (request-photos-for-point))
838 (request-cache-fodder (@ *streetmap
* clicked-lonlat
)))
840 (defun request-aux-data-linestring-for-point (lonlat-spherical-mercator)
841 "Fetch a linestring along auxiliary points near
842 lonlat-spherical-mercator."
843 (let ((lonlat-geographic
844 (chain lonlat-spherical-mercator
846 (transform +spherical-mercator
+ +geographic
+))))
847 (request-aux-data-linestring (@ lonlat-geographic lon
)
848 (@ lonlat-geographic lat
)
849 (* *linestring-step-ratio
*
851 (step-size-degrees))))
853 (defun request-photos-for-point ()
854 "Fetch photo data near (@ *streetmap* clicked-lonlat); set or
855 update streetmap cursor."
856 (remove-any-layers "Estimated Position")
857 (disable-streetmap-nearest-aux-points-layer)
858 (reset-layers-and-controls)
859 (let* ((lonlat-spherical-mercator
860 (@ *streetmap
* clicked-lonlat
))
862 (chain lonlat-spherical-mercator
864 (transform +spherical-mercator
+ +geographic
+)))
868 (create :longitude
(@ lonlat-geographic lon
)
869 :latitude
(@ lonlat-geographic lat
)
870 :zoom
(chain *streetmap
* (get-zoom))
871 :count
(lisp *number-of-images
*)
872 :selected-restriction-ids
873 (selected-restrictions))))))
876 (remove-all-features))
880 (new (chain *open-layers
886 (*point
(@ lonlat-spherical-mercator
888 (@ lonlat-spherical-mercator
891 overview-cursor-layer
892 (remove-all-features))
894 overview-cursor-layer
896 (new (chain *open-layers
902 (*point
(@ lonlat-spherical-mercator
904 (@ lonlat-spherical-mercator
906 (setf (@ *streetmap
* photo-request-response
)
912 :url
(+ "/" +proxy-root
+ "/lib/nearest-image-data")
914 :headers
(create "Content-type" "text/plain"
915 "Content-length" (@ content length
))
916 :success present-photos
917 :failure recommend-fresh-login
))))))
919 (defvar *cache-stuffer
*
920 (create xhr undefined
;instance of XMLHttpRequest
921 cache-fodder-request-response undefined
922 photo-url-ingredients undefined
923 index undefined
;current element of
924 ; photo-url-ingredients
926 cache-size
(* 2084000 1024)
927 ;we assume cache-size is set
928 ; to 2000MB by browser user
929 average-image-size undefined
930 current-center undefined
931 cache-photo-timeout undefined
932 request-cache-fodder-group-timeout undefined
)
933 "Things used to preemptively stuff the browser cache.")
935 (defun request-cache-fodder (lonlat-spherical-mercator)
936 "Abort any previous cache stuffing activities, wait a few
937 seconds, and start a new cache stuffing session centered at
938 lonlat-spherical-mercator."
939 (setf (@ *cache-stuffer
* current-center
)
940 (chain lonlat-spherical-mercator
942 (transform +spherical-mercator
+ +geographic
+)))
943 (setf (@ *cache-stuffer
* average-image-size
) 0)
944 (clear-timeout (@ *cache-stuffer
* cache-photo-timeout
))
945 (clear-timeout (@ *cache-stuffer
* request-cache-fodder-group-timeout
))
946 (hide-element-with-id "caching-indicator")
947 (setf (@ *cache-stuffer
* request-cache-fodder-group-timeout
)
948 (set-timeout request-cache-fodder-group
15000)))
950 (defun request-cache-fodder-group ()
951 "Request a bunch of image url ingredients, initiate caching
952 of the respective images. Keep trying if unsuccessful."
957 :longitude
(@ *cache-stuffer
* current-center lon
)
958 :latitude
(@ *cache-stuffer
* current-center lat
))))))
959 (setf (@ *cache-stuffer
* cache-fodder-request-response
)
965 :url
(+ "/" +proxy-root
+ "/lib/nearest-image-urls")
967 :headers
(create "Content-type" "text/plain"
968 "Content-length" (@ content length
))
969 :success handle-request-cache-fodder-group
971 (if (= (@ *cache-stuffer
* cache-fodder-request-response status
) 504)
975 request-cache-fodder-group-timeout
))
976 (setf (@ *cache-stuffer
*
977 request-cache-fodder-group-timeout
)
978 (set-timeout request-cache-fodder-group
980 (recommend-fresh-login)))))))))
982 (defun handle-request-cache-fodder-group ()
983 "Handle the response triggered by request-cache-fodder-group."
984 (when (setf (@ *cache-stuffer
* photo-url-ingredients
)
986 (read (@ *cache-stuffer
*
987 cache-fodder-request-response
989 ;; otherwise preemptive caching is probably suppressed by server
990 (setf (@ *cache-stuffer
* index
) 0)
991 (reveal-element-with-id "caching-indicator")
994 (defun cache-photo ()
995 "Cache another image if the previous one is done."
996 (if (and (< (@ *cache-stuffer
* index
)
997 (length (@ *cache-stuffer
* photo-url-ingredients
)))
998 (< (* (@ *cache-stuffer
* index
)
999 (@ *cache-stuffer
* average-image-size
))
1000 (* .5 (@ *cache-stuffer
* cache-size
))))
1001 (if (@ *cache-stuffer
* caching-photo-p
)
1003 (clear-timeout (@ *cache-stuffer
* cache-photo-timeout
))
1004 (setf (@ *cache-stuffer
* cache-photo-timeout
)
1005 (set-timeout cache-photo
3000)))
1007 (setf (@ *cache-stuffer
* caching-photo-p
) t
)
1008 (setf (@ *cache-stuffer
* xhr
) (new (*x-m-l-http-request
)))
1009 (chain *cache-stuffer
*
1013 (aref (@ *cache-stuffer
* photo-url-ingredients
)
1014 (@ *cache-stuffer
* index
)))
1016 (setf (@ *cache-stuffer
* xhr onload
)
1018 (setf (@ *cache-stuffer
* average-image-size
)
1019 (/ (+ (* (@ *cache-stuffer
* average-image-size
)
1020 (@ *cache-stuffer
* index
))
1021 (@ event total
)) ;bytes received
1022 (1+ (@ *cache-stuffer
* index
))))
1023 (setf (@ *cache-stuffer
* caching-photo-p
) nil
)
1024 (incf (@ *cache-stuffer
* index
))))
1025 ;; We do our best to have the browser use its cache.
1026 ;; Note however that in certain cases use of the
1027 ;; cache may be hampered by pressing the browser's
1029 (chain *cache-stuffer
*
1033 (+ "max-age=" (lisp *browser-cache-max-age
*))))
1034 (chain *cache-stuffer
* xhr
(send))
1035 (clear-timeout (@ *cache-stuffer
* cache-photo-timeout
))
1036 (setf (@ *cache-stuffer
* cache-photo-timeout
)
1038 cache-photo
;come back quickly in case
1039 500)))) ; photo is already in cache
1040 (hide-element-with-id "caching-indicator")))
1042 (defun draw-epipolar-line ()
1043 "Draw an epipolar line from response triggered by clicking
1044 into a (first) photo."
1045 (disable-streetmap-nearest-aux-points-layer)
1046 (enable-element-with-id "remove-work-layers-button")
1047 (switch-phoros-controls-to "point-creator")
1048 (let* ((epipolar-line
1049 (chain *json-parser
*
1051 (@ this epipolar-request-response response-text
))))
1053 (chain epipolar-line
1055 (new (chain *open-layers
1058 (@ x
:m
) (@ x
:n
))))))))
1060 (new (chain *open-layers
1066 (*line-string points
))))))))
1067 (setf (@ feature render-intent
) "temporary")
1068 (chain this epipolar-layer
1069 (add-features feature
))))
1071 (defun request-aux-points-near-cursor (count)
1072 "Draw into streetmap the count nearest points of auxiliary
1073 data around streetmap cursor."
1074 (let ((lonlat-geographic
1075 (chain (@ *streetmap
* clicked-lonlat
)
1077 (transform +spherical-mercator
+ +geographic
+))))
1078 (request-nearest-aux-points
1079 (create :longitude
(@ lonlat-geographic lon
)
1080 :latitude
(@ lonlat-geographic lat
))
1083 (defun request-nearest-aux-points (global-position count
)
1084 "Draw into streetmap the count nearest points of auxiliary
1085 data around global-position."
1086 (let ((global-position-etc global-position
)
1088 (setf (@ global-position-etc count
) count
)
1089 (setf content
(chain *json-parser
*
1090 (write global-position-etc
)))
1091 (setf (@ *streetmap
* aux-local-data-request-response
)
1095 (create :url
(+ "/" +proxy-root
+
1096 "/lib/aux-local-data")
1098 :headers
(create "Content-type" "text/plain"
1101 :success draw-nearest-aux-points
1102 :failure recommend-fresh-login
))))))
1104 (defun request-aux-data-linestring (longitude latitude radius step-size
)
1105 "Draw into streetmap a piece of linestring threaded along the
1106 nearest points of auxiliary data inside radius."
1107 (let* ((payload (create longitude longitude
1111 azimuth
(@ *streetmap
*
1112 linestring-central-azimuth
)))
1113 (content (chain *json-parser
* (write payload
))))
1114 (setf (@ *streetmap
* aux-data-linestring-request-response
)
1118 (create :url
(+ "/" +proxy-root
+
1119 "/lib/aux-local-linestring.json")
1121 :headers
(create "Content-type" "text/plain"
1124 :success draw-aux-data-linestring
1125 :failure recommend-fresh-login
))))))
1127 (defun draw-estimated-positions ()
1128 "Draw into streetmap and into all images points at Estimated
1129 Position. Estimated Position is the point returned so far
1130 from photogrammetric calculations that are triggered by
1131 clicking into another photo. Also draw into streetmap the
1132 nearest auxiliary points to Estimated Position."
1133 (when (write-permission-p)
1134 (setf (chain document
1135 (get-element-by-id "finish-point-button")
1137 (lambda () (finish-point #'store-point
)))
1138 (enable-element-with-id "finish-point-button"))
1139 (let* ((estimated-positions-request-response
1140 (chain *json-parser
*
1143 estimated-positions-request-response
1145 (estimated-positions
1146 (aref estimated-positions-request-response
1))
1147 (estimated-position-style
1148 (create stroke-color
(chain *open-layers
1151 style
"temporary" stroke-color
)
1154 (setf *global-position
*
1155 (aref estimated-positions-request-response
0))
1162 (new (chain *open-layers
1165 (@ *global-position
* longitude
)
1166 (@ *global-position
* latitude
))))
1167 (transform +geographic
+ +spherical-mercator
+)))))))
1168 (setf (@ feature render-intent
) "temporary")
1169 (setf (@ *streetmap
* estimated-position-layer
)
1170 (new (chain *open-layers
1173 "Estimated Position"
1174 (create display-in-layer-switcher nil
)))))
1175 (setf (@ *streetmap
* estimated-position-layer style
)
1176 estimated-position-style
)
1177 (chain *streetmap
* estimated-position-layer
(add-features feature
))
1179 (add-layer (@ *streetmap
* estimated-position-layer
))))
1180 (request-nearest-aux-points *global-position
* 7)
1183 for p in estimated-positions
1185 (when p
;otherwise a photogrammetry error has occured
1186 (setf (@ i estimated-position-layer
)
1191 "Estimated Position"
1192 (create display-in-layer-switcher nil
)))))
1193 (setf (@ i estimated-position-lonlat
)
1194 (new (chain *open-layers
(*lon-lat
(@ p m
)
1196 (setf (@ i estimated-position-layer style
)
1197 estimated-position-style
)
1200 (chain *open-layers
*geometry
(*point
(@ p m
)
1204 (chain *open-layers
*feature
(*vector point
)))))
1206 (add-layer (@ i estimated-position-layer
)))
1207 (chain i estimated-position-layer
1208 (add-features feature
))))))
1209 (zoom-anything-to-point)
1211 (get-element-by-id "finish-point-button")
1214 (defun draw-nearest-aux-points ()
1215 "Draw a few auxiliary points into streetmap."
1217 (chain *json-parser
*
1220 aux-local-data-request-response
1223 (disable-streetmap-nearest-aux-points-layer)
1224 (chain *streetmap
* user-points-select-control
(deactivate))
1225 (chain *streetmap
* nearest-aux-points-select-control
(activate))
1226 (chain *streetmap
* nearest-aux-points-hover-control
(activate))
1227 (setf (@ *aux-point-distance-select
* options length
)
1237 (*point
(@ i geometry coordinates
0)
1238 (@ i geometry coordinates
1))))
1239 (transform +geographic
+ +spherical-mercator
+)))
1242 (chain *open-layers
*feature
(*vector point
)))))
1243 (setf (@ feature attributes
)
1245 (setf (@ feature fid
) ;this is supposed to correspond to
1246 n
) ; option of *aux-point-distance-select*
1248 nearest-aux-points-layer
1249 (add-features feature
))
1250 (setf aux-point-distance-item
1251 (chain document
(create-element "option")))
1252 (setf (@ aux-point-distance-item text
)
1255 n
;let's hope add-features alway stores features in order of arrival
1259 (format (@ i properties distance
) 3 ""))))
1260 (chain *aux-point-distance-select
*
1261 (add aux-point-distance-item null
))))
1263 nearest-aux-points-select-control
1266 (elt (@ *streetmap
* nearest-aux-points-layer features
)
1268 (enable-element-with-id "aux-point-distance")))
1270 (defun draw-aux-data-linestring ()
1271 "Draw a piece of linestring along a few auxiliary points into
1272 streetmap. Pan streetmap accordingly."
1275 aux-data-linestring-request-response
1278 (chain *json-parser
* (read data
) linestring
))
1280 (chain *json-parser
* (read data
) current-point
))
1282 (chain *json-parser
* (read data
) previous-point
))
1284 (chain *json-parser
* (read data
) next-point
))
1286 (chain *json-parser
* (read data
) azimuth
))
1288 (chain *wkt-parser
* (read linestring-wkt
)))
1290 (chain *wkt-parser
* (read current-point-wkt
)))
1292 (chain *wkt-parser
* (read previous-point-wkt
)))
1294 (chain *wkt-parser
* (read next-point-wkt
)))
1295 (current-point-lonlat
1296 (new (chain *open-layers
1297 (*lon-lat
(@ current-point geometry x
)
1298 (@ current-point geometry y
))))))
1299 (chain *streetmap
* (pan-to current-point-lonlat
))
1300 (setf (@ *streetmap
* clicked-lonlat
) current-point-lonlat
)
1301 (setf (@ *streetmap
* linestring-central-azimuth
) azimuth
)
1302 (request-photos-for-point)
1303 (setf (@ *streetmap
* step-back-point
) previous-point
)
1304 (setf (@ *streetmap
* step-forward-point
) next-point
)
1305 (chain *streetmap
* aux-data-linestring-layer
(remove-all-features))
1307 aux-data-linestring-layer
1308 (add-features linestring
))))
1310 (defun step (&optional back-p
)
1311 "Enable walk-mode if necessary, and do a step along
1312 aux-data-linestring."
1313 (if (checkbox-status-with-id "walk-p")
1314 (let ((next-point-geometry
1317 (if (< (- (@ *streetmap
* linestring-central-azimuth
) pi
) 0)
1318 (setf (@ *streetmap
* linestring-central-azimuth
)
1319 (+ (@ *streetmap
* linestring-central-azimuth
) pi
))
1320 (setf (@ *streetmap
* linestring-central-azimuth
)
1321 (- (@ *streetmap
* linestring-central-azimuth
) pi
)))
1326 (transform +spherical-mercator
+ +geographic
+)))
1331 (transform +spherical-mercator
+ +geographic
+)))))
1332 (request-aux-data-linestring (@ next-point-geometry x
)
1333 (@ next-point-geometry y
)
1334 (* *linestring-step-ratio
*
1335 (step-size-degrees))
1336 (step-size-degrees)))
1338 (setf (checkbox-status-with-id "walk-p") t
) ;doesn't seem to trigger event
1339 (flip-walk-mode)))) ; so we have to do it explicitly
1341 (defun step-size-degrees ()
1342 "Return inner-html of element step-size (metres) converted
1343 into map units (degrees). You should be close to the
1345 (/ (inner-html-with-id "step-size") 1855.325 60))
1347 (defun decrease-step-size ()
1348 (when (> (inner-html-with-id "step-size") 0.5)
1349 (setf (inner-html-with-id "step-size")
1350 (/ (inner-html-with-id "step-size") 2))))
1352 (defun increase-step-size ()
1353 (when (< (inner-html-with-id "step-size") 100)
1354 (setf (inner-html-with-id "step-size")
1355 (* (inner-html-with-id "step-size") 2))))
1357 (defun user-point-style-map (label-property)
1358 "Create a style map where styles dispatch on feature property
1359 \"kind\" and features are labelled after feature
1360 property label-property."
1361 (let* ((symbolizer-property "kind")
1363 (new (chain *open-layers
1365 (*comparison
(create type
(chain *open-layers
1369 property symbolizer-property
1370 value
"solitary")))))
1372 (new (chain *open-layers
1374 (*comparison
(create type
(chain *open-layers
1378 property symbolizer-property
1379 value
"polyline")))))
1381 (new (chain *open-layers
1383 (*comparison
(create type
(chain *open-layers
1387 property symbolizer-property
1388 value
"polygon")))))
1390 (new (chain *open-layers
1392 (*comparison
(create type
(chain *open-layers
1396 property symbolizer-property
1399 (new (chain *open-layers
1401 (*comparison
(create type
(chain *open-layers
1405 property symbolizer-property
1408 (new (chain *open-layers
1410 (*comparison
(create type
(chain *open-layers
1414 property symbolizer-property
1417 (new (chain *open-layers
1419 (*comparison
(create type
(chain *open-layers
1423 property symbolizer-property
1426 (new (chain *open-layers
1428 (*comparison
(create type
(chain *open-layers
1432 property symbolizer-property
1435 (new (chain *open-layers
1437 (*comparison
(create type
(chain *open-layers
1441 property symbolizer-property
1444 (new (chain *open-layers
1446 (*comparison
(create type
(chain *open-layers
1450 property symbolizer-property
1453 (new (chain *open-layers
1455 (*comparison
(create type
(chain *open-layers
1459 property symbolizer-property
1462 (new (chain *open-layers
1464 (*comparison
(create type
(chain *open-layers
1468 property symbolizer-property
1471 (new (chain *open-layers
1473 (*comparison
(create type
(chain *open-layers
1477 property symbolizer-property
1480 (new (chain *open-layers
1482 filter solitary-filter
1484 graphic-name
"triangle"))))))
1486 (new (chain *open-layers
1488 filter polyline-filter
1490 graphic-name
"square"
1491 point-radius
4))))))
1493 (new (chain *open-layers
1495 filter polygon-filter
1497 graphic-name
"star"))))))
1499 (new (chain *open-layers
1503 graphic-name
"circle"))))))
1505 (new (chain *open-layers
1509 graphic-name
"cross"))))))
1511 (new (chain *open-layers
1515 graphic-name
"x"))))))
1517 (new (chain *open-layers
1521 graphic-name
"triangle"))))))
1523 (new (chain *open-layers
1527 graphic-name
"square"))))))
1529 (new (chain *open-layers
1533 graphic-name
"star"))))))
1535 (new (chain *open-layers
1540 graphic-name
"circle"))))))
1542 (new (chain *open-layers
1547 graphic-name
"triangle"))))))
1549 (new (chain *open-layers
1554 graphic-name
"square"))))))
1556 (new (chain *open-layers
1561 graphic-name
"star"))))))
1563 (new (chain *open-layers
1567 graphic-name
"x"))))))
1568 (user-point-default-style
1571 (*style
(create stroke-color
"OrangeRed"
1572 fill-color
"OrangeRed"
1575 font-color
"OrangeRed"
1576 font-family
"'andale mono', 'lucida console', monospace"
1581 (create rules
(array solitary-rule
1595 (user-point-select-style
1598 (*style
(create stroke-opacity
1
1599 label label-property
)
1600 (create rules
(array solitary-rule
1613 (user-point-temporary-style
1616 (*style
(create fill-opacity
.5)
1617 (create rules
(array solitary-rule
1630 (new (chain *open-layers
1632 (create "default" user-point-default-style
1633 "temporary" user-point-temporary-style
1634 "select" user-point-select-style
))))))
1636 (defun draw-user-points ()
1637 "Draw currently selected user points into all images."
1638 (let* ((user-point-positions-response
1639 (chain *json-parser
*
1641 (@ *user-point-in-images-response
* response-text
))))
1642 (user-point-collections
1643 (chain user-point-positions-response image-points
))
1645 (chain user-point-positions-response user-point-count
))
1647 (when (> user-point-count
1) "${numericDescription}")))
1650 for user-point-collection in user-point-collections
1652 (when i
;otherwise a photogrammetry error has occured
1656 (@ user-point-collection features
)
1659 (@ raw-feature geometry coordinates
0))
1661 (@ raw-feature geometry coordinates
1))
1663 (new (chain *open-layers
1669 (@ raw-feature properties
))
1671 (new (chain *open-layers
1673 (*vector point attributes
)))))
1674 (setf (@ feature fid
) fid
)
1675 (setf (@ feature render-intent
) "select")
1678 (@ i user-point-layer
)
1679 (new (chain *open-layers
1683 (create display-in-layer-switcher nil
1684 style-map
(user-point-style-map
1686 (chain i map
(add-layer (@ i user-point-layer
)))
1687 (chain i user-point-layer
(add-features features
)))))))
1689 (defun finish-point (database-writer)
1690 "Try, with some user interaction, to uniquify user-point
1691 attributes and call database-writer."
1693 (create user-point-id
(if (defined *current-user-point
*)
1694 (@ *current-user-point
* fid
)
1697 (value-with-id "point-kind-input")
1699 (value-with-id "point-description-input")
1701 (value-with-id "point-numeric-description")))
1703 (chain *json-parser
*
1704 (write point-data
)))
1705 (delete-point-button-active-p
1706 (disable-element-with-id "delete-point-button")))
1707 (disable-element-with-id "finish-point-button")
1708 (setf *uniquify-point-attributes-response
* nil
)
1709 (setf *uniquify-point-attributes-response
*
1715 :url
(+ "/" +proxy-root
+ "/lib/uniquify-point-attributes")
1717 :headers
(create "Content-type" "text/plain"
1718 "Content-length" (@ content
1722 (enable-element-with-id "finish-point-button")
1723 (when delete-point-button-active-p
1724 (enable-element-with-id "delete-point-button"))
1729 (@ *uniquify-point-attributes-response
*
1731 (if (equal null response
)
1737 "force-duplicate-button")
1740 (hide-element-with-id "uniquify-buttons")
1741 (reveal-element-with-id "finish-point-button")
1743 (hide-element-with-id "finish-point-button")
1744 (reveal-element-with-id "uniquify-buttons")))))
1745 :failure recommend-fresh-login
))))))
1747 (defun insert-unique-suggestion ()
1748 "Insert previously received set of unique user-point
1749 attributes into their respective input elements; switch
1750 buttons accordingly."
1752 (create user-point-id
(if (defined *current-user-point
*)
1753 (@ *current-user-point
* fid
)
1756 (value-with-id "point-kind-input")
1758 (value-with-id "point-description-input")
1760 (value-with-id "point-numeric-description")))
1762 (chain *json-parser
*
1763 (write point-data
)))
1764 (delete-point-button-active-p
1765 (disable-element-with-id "delete-point-button")))
1766 (disable-element-with-id "finish-point-button")
1767 (hide-element-with-id "uniquify-buttons")
1768 (reveal-element-with-id "finish-point-button")
1769 (setf *uniquify-point-attributes-response
* nil
)
1770 (setf *uniquify-point-attributes-response
*
1777 "/lib/uniquify-point-attributes")
1779 :headers
(create "Content-type" "text/plain"
1780 "Content-length" (@ content
1784 (enable-element-with-id "finish-point-button")
1785 (when delete-point-button-active-p
1786 (enable-element-with-id "delete-point-button"))
1791 (@ *uniquify-point-attributes-response
*
1793 (unless (equal null response
)
1794 (setf (value-with-id
1795 "point-numeric-description")
1796 (@ response numeric-description
)))))
1797 :failure recommend-fresh-login
))))))
1799 (defun store-point ()
1800 "Send freshly created user point to the database."
1801 (let ((global-position-etc *global-position
*))
1802 (setf (@ global-position-etc kind
)
1803 (value-with-id "point-kind-input"))
1804 (setf (@ global-position-etc description
)
1805 (value-with-id "point-description-input"))
1806 (setf (@ global-position-etc numeric-description
)
1807 (value-with-id "point-numeric-description"))
1808 (when (checkbox-status-with-id "include-aux-data-p")
1809 (setf (@ global-position-etc aux-numeric
)
1810 (@ *current-nearest-aux-point
*
1813 (setf (@ global-position-etc aux-text
)
1814 (@ *current-nearest-aux-point
*
1818 (chain *json-parser
*
1819 (write global-position-etc
))))
1820 (disable-element-with-id "finish-point-button")
1825 (create :url
(+ "/" +proxy-root
+ "/lib/store-point")
1827 :headers
(create "Content-type" "text/plain"
1828 "Content-length" (@ content length
))
1831 (@ *streetmap
* user-point-layer
))
1832 (reset-layers-and-controls)
1833 (request-user-point-choice))
1834 :failure recommend-fresh-login
))))))
1836 (defun update-point ()
1837 "Send changes to currently selected user point to database."
1839 (create user-point-id
(@ *current-user-point
* fid
)
1841 (value-with-id "point-kind-input")
1843 (value-with-id "point-description-input")
1845 (value-with-id "point-numeric-description")))
1847 (chain *json-parser
*
1848 (write point-data
))))
1849 (disable-element-with-id "finish-point-button")
1850 (disable-element-with-id "delete-point-button")
1854 (create :url
(+ "/" +proxy-root
+ "/lib/update-point")
1856 :headers
(create "Content-type" "text/plain"
1857 "Content-length" (@ content
1861 (@ *streetmap
* user-point-layer
))
1862 (reset-layers-and-controls)
1863 (request-user-point-choice))
1864 :failure recommend-fresh-login
)))))
1866 (defun delete-point ()
1867 "Purge currently selected user point from database."
1868 (let* ((user-point-id (@ *current-user-point
* fid
))
1870 (chain *json-parser
*
1871 (write user-point-id
))))
1872 (disable-element-with-id "finish-point-button")
1873 (disable-element-with-id "delete-point-button")
1877 (create :url
(+ "/" +proxy-root
+ "/lib/delete-point")
1879 :headers
(create "Content-type" "text/plain"
1880 "Content-length" (@ content
1884 (@ *streetmap
* user-point-layer
))
1885 (reset-layers-and-controls)
1886 (request-user-point-choice true
))
1887 :failure recommend-fresh-login
)))))
1889 (defun draw-active-point ()
1890 "Draw an Active Point, i.e. a point used in subsequent
1891 photogrammetric calculations."
1895 (new (chain *open-layers
1898 (new (chain *open-layers
1901 (@ this photo-parameters m
)
1902 (@ this photo-parameters n
))))))))))
1904 (defun image-click-action (clicked-image)
1906 "Do appropriate things when an image is clicked into."
1908 (chain clicked-image map
(get-lon-lat-from-view-port-px
1911 (@ clicked-image photo-parameters
))
1912 pristine-image-p content request
)
1913 (when (and (@ photo-parameters usable
)
1914 (chain clicked-image
(photop)))
1915 (setf (@ photo-parameters m
) (@ lonlat lon
)
1916 (@ photo-parameters n
) (@ lonlat lat
))
1917 (remove-layer (@ clicked-image map
) "Active Point")
1918 (remove-any-layers "Epipolar Line")
1919 (setf *pristine-images-p
* (not (some-active-point-p)))
1920 (setf (@ clicked-image active-point-layer
)
1921 (new (chain *open-layers
1923 (*vector
"Active Point"
1924 (create display-in-layer-switcher
1926 (chain clicked-image
1928 (add-layer (@ clicked-image active-point-layer
)))
1929 (chain clicked-image
(draw-active-point))
1934 (remove-any-layers "User Point") ;from images
1936 ;; There's something in the following line that
1937 ;; restores layer "User Point" and removes layer
1938 ;; "Active Point" when coming from directly a
1939 ;; point-editor situation.
1940 (chain *streetmap
* user-points-select-control
(unselect-all))
1942 for i across
*images
* do
1943 (when (and (not (equal i clicked-image
))
1946 (@ i epipolar-layer
)
1947 (new (chain *open-layers
1949 (*vector
"Epipolar Line"
1951 display-in-layer-switcher nil
))))
1952 content
(chain *json-parser
*
1954 (append (array photo-parameters
)
1955 (@ i photo-parameters
))))
1956 (@ i epipolar-request-response
)
1960 (create :url
(+ "/" +proxy-root
+
1961 "/lib/epipolar-line")
1964 "Content-type" "text/plain"
1967 :success
(@ i draw-epipolar-line
)
1968 :failure recommend-fresh-login
1972 (add-layer (@ i epipolar-layer
))))))
1974 (remove-any-layers "Epipolar Line")
1975 (remove-any-layers "Estimated Position")
1976 (let* ((active-pointed-photo-parameters
1978 for i across
*images
*
1979 when
(has-layer-p (@ i map
) "Active Point")
1980 collect
(@ i photo-parameters
)))
1982 (chain *json-parser
*
1984 (list active-pointed-photo-parameters
1989 photo-parameters
)))))))))
1990 (setf (@ clicked-image estimated-positions-request-response
)
1994 (create :url
(+ "/" +proxy-root
+
1995 "/lib/estimated-positions")
1998 "Content-type" "text/plain"
2001 :success
(@ clicked-image
2002 draw-estimated-positions
)
2003 :failure recommend-fresh-login
2004 :scope clicked-image
)))))))))))
2006 (defun iso-time-string (lisp-time)
2007 "Return Lisp universal time formatted as ISO time string"
2008 (let* ((unix-time (- lisp-time
+unix-epoch
+))
2009 (js-date (new (*date
(* 1000 unix-time
)))))
2010 (chain *open-layers
*date
(to-i-s-o-string js-date
))))
2012 (defun delete-photo ()
2013 "Delete this object's photo."
2015 repeat
(chain this map
(get-num-layers))
2016 do
(chain this map layers
0 (destroy)))
2017 (hide-element-with-id (@ this usable-id
))
2018 (setf (@ this trigger-time-div inner-h-t-m-l
) nil
))
2021 "Check if this object contains a photo."
2022 (@ this trigger-time-div inner-h-t-m-l
))
2024 (defun show-photo ()
2025 "Show the photo described in this object's photo-parameters."
2026 (let ((image-div-width
2027 (parse-int (chain (get-computed-style (@ this map div
) nil
)
2030 (parse-int (chain (get-computed-style (@ this map div
) nil
)
2033 (@ this photo-parameters sensor-width-pix
))
2035 (@ this photo-parameters sensor-height-pix
)))
2045 (photo-path (@ this photo-parameters
))
2046 (new (chain *open-layers
2049 (+ image-width
.5) (+ image-height
.5))))
2050 (new (chain *open-layers
2051 (*size image-div-width
2054 max-resolution
(chain
2057 (/ image-width image-div-width
)
2058 (/ image-height image-div-height
)))))))))
2059 (when (@ this photo-parameters rendered-footprint
)
2060 (setf (@ this footprint-layer
)
2064 (*vector
"Footprint"
2065 (create display-in-layer-switcher nil
2066 style
(create stroke-color
"yellow"
2068 stroke-opacity
.3))))))
2072 (chain *geojson-parser
*
2075 rendered-footprint
)))))
2078 (add-layer (@ this footprint-layer
))))
2079 (chain this map
(zoom-to-max-extent))
2080 (if (@ this photo-parameters usable
)
2081 (hide-element-with-id (@ this usable-id
))
2082 (reveal-element-with-id (@ this usable-id
)))
2083 (setf (@ this trigger-time-div inner-h-t-m-l
)
2084 (iso-time-string (@ this photo-parameters trigger-time
)))))
2086 (defun zoom-images-to-max-extent ()
2087 "Zoom out all images."
2089 for i across
*images
*
2090 do
(when (> (@ i map layers length
) 0)
2091 (chain i map
(zoom-to-max-extent)))))
2093 (defun zoom-anything-to-point ()
2094 "For streetmap and for images that have an Active Point or an
2095 Estimated Position, zoom in and recenter."
2096 (when (checkbox-status-with-id "zoom-to-point-p")
2098 (new (chain *open-layers
2099 (*lon-lat
(@ *global-position
* longitude
)
2100 (@ *global-position
* latitude
))
2101 (transform +geographic
+ +spherical-mercator
+)))))
2104 (set-center point-lonlat
18 nil t
))))
2105 (loop for i across
*images
* do
2108 ((has-layer-p (@ i map
) "Active Point")
2109 (new (chain *open-layers
(*lon-lat
2110 (@ i photo-parameters m
)
2111 (@ i photo-parameters n
)))))
2112 ((has-layer-p (@ i map
) "Estimated Position")
2113 (@ i estimated-position-lonlat
))
2116 (chain i map
(set-center point-lonlat
4 nil t
)))))))
2118 (defun initialize-image (image-index)
2119 "Create an image usable for displaying photos at position
2120 image-index in array *images*."
2121 (setf (aref *images
* image-index
) (new *image
))
2122 (setf (@ (aref *images
* image-index
) usable-id
)
2123 (+ "image-" image-index
"-usable"))
2124 (hide-element-with-id (+ "image-" image-index
"-usable"))
2125 (setf (@ (aref *images
* image-index
) trigger-time-div
)
2128 (get-element-by-id (+ "image-" image-index
"-trigger-time"))))
2129 (setf (@ (aref *images
* image-index
) image-click-action
)
2130 (image-click-action (aref *images
* image-index
)))
2131 (setf (@ (aref *images
* image-index
) click
)
2132 (new (*click-control
*
2133 (create :trigger
(@ (aref *images
* image-index
)
2134 image-click-action
)))))
2135 (chain (aref *images
* image-index
)
2138 (@ (aref *images
* image-index
) click
)))
2139 (chain (aref *images
* image-index
) click
(activate))
2140 ;;(chain (aref *images* image-index)
2143 ;; (new (chain *open-layers
2149 ;; (get-element-by-id
2150 ;; (+ "image-" image-index "-zoom")))))))))
2151 (chain (aref *images
* image-index
)
2154 (new (chain *open-layers
2161 (+ "image-" image-index
"-layer-switcher")))
2162 rounded-corner nil
))))))
2163 (let ((pan-west-control
2164 (new (chain *open-layers
*control
(*pan
"West"))))
2166 (new (chain *open-layers
*control
(*pan
"North"))))
2168 (new (chain *open-layers
*control
(*pan
"South"))))
2170 (new (chain *open-layers
*control
(*pan
"East"))))
2172 (new (chain *open-layers
*control
(*zoom-in
))))
2174 (new (chain *open-layers
*control
(*zoom-out
))))
2175 (zoom-to-max-extent-control
2176 (new (chain *open-layers
*control
(*zoom-to-max-extent
))))
2178 (new (chain *open-layers
2185 (+ "image-" image-index
"-zoom")))))))))
2186 (chain (aref *images
* image-index
)
2188 (add-control pan-zoom-panel
))
2189 (chain pan-zoom-panel
2190 (add-controls (array pan-west-control
2196 zoom-to-max-extent-control
))))
2197 (chain (aref *images
* image-index
)
2199 (render (chain document
2201 (+ "image-" image-index
))))))
2203 (defun user-point-selected (event)
2204 "Things to do once a user point is selected."
2205 (remove-any-layers "Active Point")
2206 (remove-any-layers "Epipolar Line")
2207 (remove-any-layers "Estimated Position")
2208 (unselect-combobox-selection "point-kind")
2209 (unselect-combobox-selection "point-description")
2210 (user-point-selection-changed))
2212 (defun user-point-unselected (event)
2213 "Things to do once a user point is unselected."
2215 (user-point-selection-changed))
2217 (defun user-point-selection-changed ()
2218 "Things to do once a user point is selected or unselected."
2219 (setf *current-user-point
*
2220 (@ *streetmap
* user-point-layer selected-features
0))
2221 (let ((selected-features-count
2222 (@ *streetmap
* user-point-layer selected-features length
)))
2223 (setf (@ *streetmap
* user-point-layer style-map
)
2224 (user-point-style-map
2225 (when (> selected-features-count
1)
2226 "${numericDescription}")))
2228 ((> selected-features-count
1)
2229 (switch-phoros-controls-to "multiple-points-viewer"))
2230 ((= selected-features-count
1)
2231 (setf (value-with-id "point-kind-input")
2232 (@ *current-user-point
* attributes kind
))
2233 (setf (value-with-id "point-description-input")
2234 (@ *current-user-point
* attributes description
))
2235 (setf (value-with-id "point-numeric-description")
2236 (@ *current-user-point
* attributes numeric-description
))
2237 (setf (inner-html-with-id "point-creation-date")
2238 (@ *current-user-point
* attributes creation-date
))
2239 (setf (inner-html-with-id "aux-numeric-list")
2241 (@ *current-user-point
* attributes aux-numeric
)
2242 +aux-numeric-labels
+))
2243 (setf (inner-html-with-id "aux-text-list")
2245 (@ *current-user-point
* attributes aux-text
)
2247 (switch-phoros-controls-to "point-editor")
2248 (if (write-permission-p
2249 (@ *current-user-point
* attributes user-name
))
2251 (setf (chain document
2252 (get-element-by-id "finish-point-button")
2254 (lambda () (finish-point #'update-point
)))
2255 (enable-element-with-id "finish-point-button")
2256 (enable-element-with-id "delete-point-button")
2257 (switch-phoros-controls-to "point-editor"))
2259 (disable-element-with-id "finish-point-button")
2260 (disable-element-with-id "delete-point-button")
2261 (switch-phoros-controls-to "point-viewer")))
2262 (setf (inner-html-with-id "creator")
2263 (if (@ *current-user-point
* attributes user-name
)
2265 (@ *current-user-point
* attributes user-name
)
2269 (reset-layers-and-controls))))
2270 (chain *streetmap
* user-point-layer
(redraw))
2271 (remove-any-layers "User Point") ;from images
2273 (chain *json-parser
*
2275 (array (chain *streetmap
*
2278 (map (lambda (x) (@ x fid
))))
2280 for i across
*images
*
2281 collect
(@ i photo-parameters
))))))
2282 (setf *user-point-in-images-response
*
2286 (create :url
(+ "/" +proxy-root
+
2287 "/lib/user-point-positions")
2289 :headers
(create "Content-type" "text/plain"
2290 "Content-length" (@ content
2292 :success draw-user-points
2293 :failure recommend-fresh-login
)))))
2295 (defun aux-point-distance-selected ()
2296 "Things to do on change of aux-point-distance select element."
2298 nearest-aux-points-select-control
2301 nearest-aux-points-select-control
2304 (elt (@ *streetmap
* nearest-aux-points-layer features
)
2305 (@ *aux-point-distance-select
*
2307 selected-index
))))))
2309 (defun enable-aux-point-selection ()
2310 "Check checkbox include-aux-data-p and act accordingly."
2311 (setf (checkbox-status-with-id "include-aux-data-p") t
)
2312 (flip-aux-data-inclusion))
2314 (defun flip-walk-mode ()
2315 "Query status of checkbox walk-p and induce first walking
2316 step if it's just been turned on. Otherwise delete our
2318 (if (checkbox-status-with-id "walk-p")
2319 (request-aux-data-linestring-for-point (@ *streetmap
*
2322 aux-data-linestring-layer
2323 (remove-all-features))))
2325 (defun flip-aux-data-inclusion ()
2326 "Query status of checkbox include-aux-data-p and act accordingly."
2327 (if (checkbox-status-with-id "include-aux-data-p")
2329 nearest-aux-points-layer
2332 nearest-aux-points-layer
2333 (set-visibility nil
))))
2335 (defun flip-nearest-aux-data-display ()
2336 "Query status of checkbox include-aux-data-p and act accordingly."
2337 (reset-layers-and-controls))
2339 (defun html-table (aux-data labels
)
2340 "Return an html-formatted table with a label column from
2341 labels and a data column from aux-data."
2345 :class
"aux-data-table"
2347 (reduce (lambda (x y i
)
2351 (:td
:class
"aux-data-label"
2358 (:td
:class
"aux-data-value"
2364 (defun nearest-aux-point-selected (event)
2365 "Things to do once a nearest auxiliary point is selected in streetmap."
2366 (setf *current-nearest-aux-point
* (@ event feature
))
2368 (@ event feature attributes aux-numeric
))
2370 (@ event feature attributes aux-text
))
2372 (@ event feature attributes distance
)))
2373 (setf (@ *aux-point-distance-select
* options selected-index
)
2374 (@ event feature fid
))
2375 (setf (inner-html-with-id "aux-numeric-list")
2376 (html-table aux-numeric
+aux-numeric-labels
+))
2377 (setf (inner-html-with-id "aux-text-list")
2378 (html-table aux-text
+aux-text-labels
+))))
2381 "Store user's current map extent and log out."
2382 (let* ((bbox (chain *streetmap
*
2384 (transform +spherical-mercator
+ +geographic
+)
2386 (href (+ "/" +proxy-root
+ "/lib/logout?bbox=" bbox
)))
2387 (when (@ *streetmap
* cursor-layer features length
)
2388 (let* ((lonlat-geographic (chain *streetmap
*
2394 (transform +spherical-mercator
+
2397 "&longitude=" (@ lonlat-geographic x
)
2398 "&latitude=" (@ lonlat-geographic y
)))))
2399 (setf (@ location href
) href
)))
2402 "Prepare user's playground."
2403 (unless +presentation-project-bbox-text
+
2404 (setf (inner-html-with-id "presentation-project-emptiness")
2410 (create projection
+geographic
+
2411 display-projection
+geographic
+
2412 controls
(array (new (chain *open-layers
2415 (new (chain *open-layers
2417 (*attribution
)))))))))
2418 (when (write-permission-p)
2419 (enable-elements-of-class "write-permission-dependent")
2420 (request-user-point-choice true
))
2421 (hide-element-with-id "no-footprints-p")
2422 (hide-element-with-id "caching-indicator")
2423 (hide-element-with-id "uniquify-buttons")
2424 (setf *aux-point-distance-select
*
2425 (chain document
(get-element-by-id "aux-point-distance")))
2426 (let ((cursor-layer-style
2429 external-graphic
(+ "/" +proxy-root
+
2430 "/lib/public_html/phoros-cursor.png"))))
2431 (setf (@ *streetmap
* cursor-layer
)
2437 style cursor-layer-style
)))))
2438 (setf (@ *streetmap
* overview-cursor-layer
)
2444 style cursor-layer-style
))))))
2445 (let ((survey-layer-style
2446 (create stroke-color
(chain *open-layers
*feature
*vector
2447 style
"default" stroke-color
)
2451 graphic-name
"circle")))
2452 (setf (@ *streetmap
* survey-layer
)
2458 strategies
(array (new (*bbox-strategy
*)))
2460 (new (*http-protocol
*
2461 (create :url
(+ "/" +proxy-root
+
2462 "/lib/points.json"))))
2463 style survey-layer-style
))))))
2464 (setf (@ *streetmap
* user-point-layer
)
2470 strategies
(array (new *bbox-strategy
*))
2472 (new (*http-protocol
*
2473 (create :url
(+ "/" +proxy-root
+ "/lib/user-points.json"))))
2474 style-map
(user-point-style-map nil
))))))
2475 (setf (@ *streetmap
* user-points-hover-control
)
2476 (new (chain *open-layers
2478 (*select-feature
(@ *streetmap
* user-point-layer
)
2479 (create render-intent
"temporary"
2481 highlight-only t
)))))
2482 (setf (@ *streetmap
* user-points-select-control
)
2483 (new (chain *open-layers
2485 (*select-feature
(@ *streetmap
* user-point-layer
)
2488 (let ((aux-layer-style
2489 (create stroke-color
"grey"
2493 graphic-name
"circle")))
2494 (setf (@ *streetmap
* aux-point-layer
)
2500 strategies
(array (new (*bbox-strategy
*)))
2502 (new (*http-protocol
*
2503 (create :url
(+ "/" +proxy-root
+
2504 "/lib/aux-points.json"))))
2505 style aux-layer-style
2506 visibility nil
))))))
2507 (let ((nearest-aux-point-layer-style-map
2508 (new (chain *open-layers
2511 (create stroke-color
"grey"
2515 graphic-name
"circle")
2517 (create stroke-color
"black"
2521 graphic-name
"circle")
2523 (create stroke-color
"grey"
2528 graphic-name
"circle")))))))
2529 (setf (@ *streetmap
* nearest-aux-points-layer
)
2530 (new (chain *open-layers
2533 "Nearest Aux Points"
2535 display-in-layer-switcher nil
2536 style-map nearest-aux-point-layer-style-map
2538 (setf (@ *streetmap
* nearest-aux-points-hover-control
)
2539 (new (chain *open-layers
2542 (@ *streetmap
* nearest-aux-points-layer
)
2543 (create render-intent
"temporary"
2545 highlight-only t
)))))
2546 (setf (@ *streetmap
* nearest-aux-points-select-control
)
2547 (new (chain *open-layers
2550 (@ *streetmap
* nearest-aux-points-layer
)))))
2551 (setf (@ *streetmap
* aux-data-linestring-layer
)
2552 (new (chain *open-layers
2555 "Aux Data Linestring"
2557 display-in-layer-switcher nil
2558 style-map nearest-aux-point-layer-style-map
2560 (setf (@ *streetmap
* google-streetmap-layer
)
2561 (new (chain *open-layers
2563 (*google
"Google Streets"
2564 (create num-zoom-levels
23)))))
2565 (setf (@ *streetmap
* osm-layer
)
2566 (new (chain *open-layers
2571 (create num-zoom-levels
23
2573 "Data CC-By-SA by openstreetmap.org")))))
2574 (setf (@ *streetmap
* overview-osm-layer
)
2575 (new (chain *open-layers
2577 (*osm
* "OpenStreetMap"))))
2578 (setf (@ *streetmap
* click-streetmap
)
2579 (new (*click-control
*
2580 (create :trigger request-photos-after-click
))))
2581 (setf (@ *streetmap
* nirvana-layer
)
2586 (create is-base-layer t
2587 projection
(@ *streetmap
* osm-layer projection
)
2588 max-extent
(@ *streetmap
* osm-layer max-extent
)
2589 max-resolution
(@ *streetmap
*
2592 units
(@ *streetmap
* osm-layer units
)
2593 num-zoom-levels
(@ *streetmap
*
2595 num-zoom-levels
))))))
2598 (new (chain *open-layers
2605 "streetmap-layer-switcher"))
2606 rounded-corner nil
))))))
2607 (let ((pan-west-control
2608 (new (chain *open-layers
*control
(*pan
"West"))))
2610 (new (chain *open-layers
*control
(*pan
"North"))))
2612 (new (chain *open-layers
*control
(*pan
"South"))))
2614 (new (chain *open-layers
*control
(*pan
"East"))))
2616 (new (chain *open-layers
*control
(*zoom-in
))))
2618 (new (chain *open-layers
*control
(*zoom-out
))))
2619 (zoom-to-max-extent-control
2625 display-class
"streetmapZoomToMaxExtent"
2629 +presentation-project-bounds
+))))))))
2631 (new (chain *open-layers
2638 "streetmap-zoom")))))))
2640 (new (chain *open-layers
2646 (@ *streetmap
* overview-osm-layer
)
2647 (@ *streetmap
* overview-cursor-layer
))
2653 "streetmap-overview")))))))
2654 (mouse-position-control
2655 (new (chain *open-layers
2658 (create div
(chain document
2660 "streetmap-mouse-position"))
2661 empty-string
"longitude, latitude")))))
2663 (new (chain *open-layers
2667 (add-control pan-zoom-panel
))
2668 (chain pan-zoom-panel
2669 (add-controls (array pan-west-control
2675 zoom-to-max-extent-control
)))
2677 (add-control (@ *streetmap
* click-streetmap
)))
2678 (chain *streetmap
* click-streetmap
(activate))
2683 (register "featureselected"
2684 (@ *streetmap
* user-point-layer
)
2685 user-point-selected
))
2689 (register "featureunselected"
2690 (@ *streetmap
* user-point-layer
)
2691 user-point-unselected
))
2693 nearest-aux-points-layer
2695 (register "featureselected"
2696 (@ *streetmap
* nearest-aux-points-layer
)
2697 nearest-aux-point-selected
))
2700 (@ *streetmap
* nearest-aux-points-hover-control
)))
2703 (@ *streetmap
* nearest-aux-points-select-control
)))
2706 (@ *streetmap
* user-points-hover-control
)))
2709 (@ *streetmap
* user-points-select-control
)))
2710 (chain *streetmap
* nearest-aux-points-hover-control
(activate))
2711 (chain *streetmap
* nearest-aux-points-select-control
(activate))
2712 (chain *streetmap
* user-points-hover-control
(activate))
2713 (chain *streetmap
* user-points-select-control
(activate))
2714 (chain *streetmap
* (add-layer (@ *streetmap
* osm-layer
)))
2715 (try (chain *streetmap
*
2716 (add-layer (@ *streetmap
* google-streetmap-layer
)))
2719 (remove-layer (@ *streetmap
*
2720 google-streetmap-layer
)))))
2721 (chain *streetmap
* (add-layer (@ *streetmap
* nirvana-layer
)))
2723 (add-layer (@ *streetmap
* nearest-aux-points-layer
)))
2724 (chain *streetmap
* (add-layer (@ *streetmap
* survey-layer
)))
2726 (add-layer (@ *streetmap
* cursor-layer
)))
2728 (add-layer (@ *streetmap
* aux-point-layer
)))
2730 (add-layer (@ *streetmap
* aux-data-linestring-layer
)))
2732 (add-layer (@ *streetmap
* user-point-layer
)))
2733 (setf (@ overview-map element
)
2734 (chain document
(get-element-by-id
2735 "streetmap-overview-element")))
2736 (chain *streetmap
* (add-control overview-map
))
2737 (chain *streetmap
* (add-control mouse-position-control
))
2738 (chain *streetmap
* (add-control scale-line-control
)))
2740 for i from
0 below
(lisp *number-of-images
*)
2741 do
(initialize-image i
))
2743 (request-restriction-select-choice)
2746 (if (lisp (stored-bbox))
2747 (new (chain *open-layers
2749 (from-string (lisp (stored-bbox)))
2750 (transform +geographic
+ +spherical-mercator
+)))
2751 +presentation-project-bounds
+)))
2752 (let ((stored-cursor (lisp (stored-cursor))))
2755 (new (chain *open-layers
2757 (from-string stored-cursor
)
2758 (transform +geographic
+
2759 +spherical-mercator
+))))))
2760 (reset-layers-and-controls)))))
2762 (pushnew (hunchentoot:create-regex-dispatcher
2763 (format nil
"/phoros/lib/phoros-~A-\\S*-\\S*\.js"
2766 hunchentoot
:*dispatch-table
*)