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
"Phoros version.")
63 (:p
"In a version string A.B.C, changes in A denote
64 incompatible changes in data (you can't access a database
65 set up by a different version of Phoros); changes in B mean
66 user-visible changes in feature set; changes in C denote
67 bug fixes and minor improvements."))
70 (:p
"Current action."))
71 :multiple-points-viewer
73 (:p
"Try reading the text under mouse pointer."))
76 (:p
"Delete current point."))
79 (:p
"Store user point with its attributes kind,
80 numeric-description and description, and with its auxiliary
81 data into database; warn if the given set of attributes
83 :suggest-unique-button
85 (:h3
"Non-unique set of user point attributes")
86 (:p
"Recommend a set of user point attributes that is
87 unique among the currently defined user points, preferably
88 by incrementing a portion of attribute numeric-description
89 that looks like a number."))
90 :force-duplicate-button
92 (:h3
"Non-unique set of user point attributes")
93 (:p
"Store user point with its attributes kind,
94 numeric-description and description, and with its auxiliary
95 data into database; don't care whether the given set of
96 attributes is unique."))
97 :download-user-points-button
99 (:p
"Download all user points as GeoJSON-fomatted text
100 file. Do this regularly if you don't want to lose your
101 work due to server crashes or major Phoros updates.")
102 (:p
"Points saved this way can be fed back into your
103 project using the command line interface (on server or on
104 any other host where the database is reachable)."))
108 (:p
"The standard ones, polygon, polyline, and solitary, are
109 rendered as asterisk, square, and triangle respectively.
110 The numbers 0 to 9, if used as values, are mapped to an
111 alternative set of distinct symbols. Anything else is
115 (:h3
"\"description\"")
116 (:p
"Optional textual description of the set of user points
117 the current point belongs to."))
118 :point-numeric-description
120 (:h3
"\"numeric-description\"")
121 (:p
"Optional description of the current user point. It is
122 occasionally used to label representations of this point in
123 streetmap and in images.")
124 (:p
"It should contain a numeric part, possibly with
125 leading zeros, which will be incremented automatically to
126 make the attribute sets of points with otherwise identical
127 attributes unique."))
130 (:p
"Creation date of current user point. Will be updated
131 when you change this point."))
134 (:p
"Check this if the user point being created is to
135 include auxiliary data."))
136 :display-nearest-aux-data
138 (:p
"Check this to see auxiliary data near streetmap
140 (:p
"You need to uncheck this before you can select user
141 points in streetmap."))
144 (:p
"Select a set of auxiliary data by its distance (in
145 metres) from the current estimated position if any, or its
146 distance from streetmap cursor otherwise.")
147 (:p
"Alternatively, a set of auxiliary data is also
148 selectable by clicking its representation in streetmap."))
151 (:p
"Auxiliary data connected to this presentation project;
152 all the numeric values followed by all the text values if
156 (:p
"Creator of current user point. Will be updated when
157 you change this point."))
158 :remove-work-layers-button
160 (:p
"Discard the current, unstored user point or unselect
161 any selected user points. Zoom out all images. Keep
162 the rest of the workspace untouched."))
165 (:p
"View some info about Phoros."))
168 (:p
"Finish this session after storing current streetmap
169 zoom status and your cursor position.")
170 (:p
"Fresh login is required to continue."))
173 (:p
"Clicking into the streetmap fetches images which most
174 probably feature the clicked point.")
175 (:p
"To pan the map, drag the mouse. To zoom, spin the
176 mouse wheel, or hold shift down whilst dragging a box, or
177 double-click (shift double-click for larger zoom steps) a
178 point of interest."))
181 (:p
"Clicking into an image sets or resets the active point
182 there. Once a feature is marked by active points in more
183 than one image, the estimated position is calculated.")
184 (:p
"To pan an image, drag the mouse. To zoom, spin the
185 mouse wheel, or hold shift down whilst dragging a box, or
186 double-click (shift double-click for larger zoom steps) a
187 point of interest."))
188 ol-Control-Pan-West-Item-Inactive
190 (:p
"Move viewport left."))
191 ol-Control-Pan-East-Item-Inactive
193 (:p
"Move viewport right."))
194 ol-Control-Pan-North-Item-Inactive
196 (:p
"Move viewport up."))
197 ol-Control-Pan-South-Item-Inactive
199 (:p
"Move viewport down."))
200 ol-Control-Zoom-In-Item-Inactive
203 ol-Control-Zoom-Out-Item-Inactive
206 streetmap-Zoom-To-Max-Extent-Item-Inactive
208 (:p
"Zoom to the extent of presentation project."))
209 ol-Control-Zoom-To-Max-Extent-Item-Inactive
211 (:p
"Zoom out completely, restoring the original view."))
212 :zoom-images-to-max-extent
214 (:p
"Zoom all images out completely, restoring the original
218 (:p
"I haven't been able to display a set of images that
219 cover a common area because I couldn't find the necessary
220 information. As a fallback, I'm displaying a set of images
221 with points of view close to the point you selected.")
222 (:p
"The server is probably trying to remedy this problem
223 but this may take some time."))
227 (:p
"Check this to automatically zoom into images once they
228 get an estimated position."))
231 (:p
"Check this to have underexposed images brightened up.")
232 (:p
"Brightening starts with the next set of images and may
233 slow things down a bit."))
236 (:p
"Check this to snap your current position onto a line
237 along points of auxiliary data, and to keep streetmap
238 centered around current position."))
241 (:p
"Decrease step size. Double-click to decrease harder."))
244 (:p
"Step size in metres. Click to increase; double-click
245 to increase harder."))
248 (:p
"Increase step size. Double-click to increase harder."))
251 (:p
"Move your position by one step on a line along points
252 of auxiliary data. Double-click to change direction."))
253 :image-layer-switcher
255 (:p
"Toggle display of image."))
258 (:p
"No photogrammetric survey possible as there isn't any
259 usable calibration data available for this image.")
260 (:p
"This means no image footprints can be calculated
261 either which prevents me from selecting images covering a
265 (:p
"Time this image was taken."))
268 (:p
"Choose a background streetmap."))
271 (:p
"Toggle visibility of data layers."))
272 :unselect-all-restrictions-button
274 (:h3
"Image Restrictions")
275 (:p
"Remove all image restrictions."))
278 (:h3
"Image Restrictions")
279 (:p
"Select one ore more of the restrictions in order to
280 consider only a subset of the images available. No
281 selection at all means no restriction.")
282 (:p
"Shift-click selects a range of restrictions,
283 control-click selects or unselects a particular
284 restriction, click selects a restriction unselecting
288 (:p
"Click to re-center streetmap, or drag the red
290 :streetmap-mouse-position
292 (:p
"Cursor position in geographic coordinates when cursor
296 (:p
"Hints on Phoros' displays and controls are shown here
297 while hovering over the respective elements."))))
299 (defun add-help-topic (topic element
)
300 "Add mouse events to DOM element that initiate display of a
303 (setf (@ element onmouseover
)
305 (lambda () (show-help x
)))
307 (setf (@ element onmouseout
) show-help
)))
309 (defun add-help-events ()
310 "Add mouse events to DOM elements that initiate display of a
313 (topic *help-topics
*)
314 (add-help-topic topic
(chain document
(get-element-by-id topic
)))
315 (dolist (element (chain document
(get-elements-by-class-name topic
)))
316 (add-help-topic topic element
))))
318 (defun show-help (&optional topic
)
319 "Put text on topic into help-display"
320 (setf (inner-html-with-id "help-display")
321 (let ((help-body (getprop *help-topics
* topic
)))
322 (if (undefined help-body
)
326 (defvar *click-control
*
330 (@ *open-layers
*control
)
338 (apply this arguments
))
339 (setf (@ this handler
)
340 (new (chain *open-layers
344 :click
(@ this trigger
)))))))))))
346 (defvar +unix-epoch
+ (lisp *unix-epoch
*)
347 "Seconds between Lisp epoch and UNIX epoch.")
349 (new (chain *open-layers
(*projection
"EPSG:4326"))))
350 (defvar +spherical-mercator
+
351 (new (chain *open-layers
(*projection
"EPSG:900913"))))
355 "First element of URL path; defaults to phoros but may be
356 turned into something different by an HTTP proxy
359 (defvar +user-name
+ (lisp (hunchentoot:session-value
'user-name
))
360 "User's (short) name.")
361 (defvar +user-role
+ (lisp (string-downcase (hunchentoot:session-value
363 "User's permissions.")
365 (defvar +presentation-project-bbox-text
+
366 (lisp (hunchentoot:session-value
'presentation-project-bbox
)))
368 (defvar +presentation-project-bounds
+
369 (chain (new (chain *open-layers
372 (or +presentation-project-bbox-text
+
373 "-180,-89,180,89"))))
374 (transform +geographic
+ +spherical-mercator
+))
375 "Bounding box of the entire presentation project.")
378 (lisp (hunchentoot:session-value
'aux-data-p
)))
380 (defvar +aux-numeric-labels
+
381 (lisp (when *aux-numeric-labels
*
382 (coerce *aux-numeric-labels
* 'vector
))))
384 (defvar +aux-text-labels
+
385 (lisp (when *aux-text-labels
*
386 (coerce *aux-text-labels
* 'vector
))))
388 (defvar *images
* (array) "Collection of the photos currently shown.")
390 (defvar *streetmap
* undefined
391 "The streetmap shown to the user.")
393 (defvar *aux-point-distance-select
* undefined
394 "The HTML element for selecting one of a few nearest
397 (defvar *global-position
* undefined
398 "Coordinates of the current estimated position")
400 (defvar *linestring-step-ratio
* 4
401 "Look for auxiliary points to include into linestring within
402 a radius of *linestring-step-ratio* multilied by multiplied by
405 (defvar *current-nearest-aux-point
*
406 (create attributes
(create aux-numeric undefined
408 "Attributes of currently selected point of auxiliary data.")
410 (defvar *bbox-strategy
* (@ *open-layers
*strategy
*bbox
*))
411 (setf (@ *bbox-strategy
* prototype ratio
) 1.5)
412 (setf (@ *bbox-strategy
* prototype res-factor
) 1.5)
414 (defvar *json-parser
* (new (chain *open-layers
*format
*json
*)))
416 (defvar *geojson-parser
* (new (chain *open-layers
*format
*geo-j-s-o-n
)))
418 (defvar *geojson-format
* (chain *open-layers
*format
*geo-j-s-o-n
))
419 (setf (@ *geojson-format
* prototype ignore-extra-dims
)
420 t
) ;doesn't handle height anyway
421 (setf (@ *geojson-format
* prototype external-projection
)
423 (setf (@ *geojson-format
* prototype internal-projection
)
427 (new (chain *open-layers
430 (create external-projection
+geographic
+
431 internal-projection
+spherical-mercator
+)))))
433 (defvar *http-protocol
* (chain *open-layers
*protocol
*http
*))
434 (setf (chain *http-protocol
* prototype format
) (new *geojson-format
*))
436 (defvar *pristine-images-p
* t
437 "T if none of the current images has been clicked into yet.")
439 (defvar *current-user-point
* undefined
440 "The currently selected user-point.")
442 (defun write-permission-p (&optional
(current-owner +user-name
+))
443 "Nil if current user can't edit stuff created by
444 current-owner or, without arguments, new stuff."
445 (or (equal +user-role
+ "admin")
446 (and (equal +user-role
+ "write")
447 (or (equal +user-name
+ current-owner
)
448 (not current-owner
)))))
451 "Anything necessary to deal with a photo."
457 (create projection
+spherical-mercator
+
459 controls
(array (new (chain *open-layers
461 (*navigation
)))))))))
462 (setf (@ this dummy
) false
) ;TODO why? (omitting splices map components directly into *image)
465 (setf (@ *image prototype delete-photo
)
467 (setf (@ *image prototype photop
)
469 (setf (@ *image prototype show-photo
)
471 (setf (@ *image prototype draw-epipolar-line
)
473 (setf (@ *image prototype draw-active-point
)
475 (setf (@ *image prototype draw-estimated-positions
)
476 draw-estimated-positions
)
478 (defun photo-path (photo-parameters)
479 "Create from stuff found in photo-parameters and in checkbox
480 brighten-images-p a path with parameters for use in an image
484 (@ photo-parameters directory
) "/"
485 (@ photo-parameters filename
) "/"
486 (@ photo-parameters byte-position
) ".png"
487 "?mounting-angle=" (@ photo-parameters mounting-angle
)
488 "&bayer-pattern=" (@ photo-parameters bayer-pattern
)
489 "&color-raiser=" (@ photo-parameters color-raiser
)
490 (if (checkbox-status-with-id "brighten-images-p")
494 (defun has-layer-p (map layer-name
)
495 "False if map doesn't have a layer called layer-name."
496 (chain map
(get-layers-by-name layer-name
) length
))
498 (defun some-active-point-p ()
499 "False if no image in *images* has an Active Point."
501 for i across
*images
*
502 sum
(has-layer-p (@ i map
) "Active Point")))
504 (defun remove-layer (map layer-name
)
505 "Destroy layer layer-name in map."
506 (when (has-layer-p map layer-name
)
507 (chain map
(get-layers-by-name layer-name
) 0 (destroy))))
509 (defun remove-any-layers (layer-name)
510 "Destroy in all *images* and in *streetmap* the layer named layer-name."
512 for i across
*images
* do
513 (remove-layer (@ i map
) layer-name
))
514 (remove-layer *streetmap
* layer-name
))
516 (defun reset-controls ()
517 (disable-element-with-id "finish-point-button")
518 (disable-element-with-id "delete-point-button")
519 (disable-element-with-id "remove-work-layers-button")
520 (setf (inner-html-with-id "creator") nil
)
521 (setf (inner-html-with-id "point-creation-date") nil
)
522 (hide-aux-data-choice)
523 (setf (inner-html-with-id "aux-numeric-list") nil
)
524 (setf (inner-html-with-id "aux-text-list") nil
))
526 (defun disable-streetmap-nearest-aux-points-layer ()
527 "Get (@ *streetmap* nearest-aux-points-layer) out of the way,
528 i.e., remove features and disable feature select control so
529 it won't shadow any other control."
530 (chain *streetmap
* nearest-aux-points-layer
(remove-all-features))
531 (chain *streetmap
* nearest-aux-points-select-control
(deactivate))
532 (chain *streetmap
* user-points-select-control
(activate)))
534 (defun reset-layers-and-controls ()
535 "Destroy user-generated layers in *streetmap* and in all
536 *images*, and put controls into pristine state."
537 (remove-any-layers "Epipolar Line")
538 (remove-any-layers "Active Point")
539 (remove-any-layers "Estimated Position")
540 (remove-any-layers "User Point")
541 (chain *streetmap
* user-points-select-control
(unselect-all))
542 (when (and (not (equal undefined
*current-user-point
*))
543 (@ *current-user-point
* layer
))
545 user-points-select-control
546 (unselect *current-user-point
*)))
549 (switch-phoros-controls-to "aux-data-viewer")
550 (switch-phoros-controls-to "point-creator"))
551 (setf *pristine-images-p
* t
)
552 (if (and +aux-data-p
+
553 (checkbox-status-with-id "display-nearest-aux-data-p"))
554 (request-aux-points-near-cursor 30)
555 (disable-streetmap-nearest-aux-points-layer))
556 (zoom-images-to-max-extent))
558 (defun enable-element-with-id (id)
559 "Activate HTML element with id=\"id\". Return t if element
560 was greyed out before."
562 (chain document
(get-element-by-id id
) disabled
)
563 (setf (chain document
(get-element-by-id id
) disabled
) nil
)))
565 (defun enable-elements-of-class (class-name)
566 "Activate HTML elements with class=\"class\"."
568 for element in
(chain document
569 (get-elements-by-class-name class-name
))
570 do
(setf (@ element disabled
) nil
)))
572 (defun disable-element-with-id (id)
573 "Grey out HTML element with id=\"id\". Return t if element
576 (not (chain document
(get-element-by-id id
) disabled
))
577 (setf (chain document
(get-element-by-id id
) disabled
) t
)))
579 (defun hide-element-with-id (id)
580 "Hide HTML element with id=\"id\"."
581 (setf (chain document
(get-element-by-id id
) style display
)
584 (defun hide-elements-of-class (class-name)
585 "Hide HTML elements with class=\"class\"."
587 for element in
(chain document
588 (get-elements-by-class-name class-name
))
589 do
(setf (@ element style display
) "none")))
591 (defun reveal-element-with-id (id)
592 "Reveal HTML element with id=\"id\"."
593 (setf (chain document
(get-element-by-id id
) style display
)
596 (defun reveal-elements-of-class (class-name)
597 "Reveal HTML elements with class=\"class\"."
599 for element in
(chain document
600 (get-elements-by-class-name class-name
))
601 do
(setf (@ element style display
) "")))
603 (defun switch-phoros-controls-to (class-name)
604 "Reveal elements of class class-name; hide anything else.
605 Unless there is auxiliary data available, hide the related
607 (let ((phoros-controls-classes
608 '("point-creator" "point-editor" "point-viewer"
609 "multiple-points-viewer" "aux-data-viewer")))
610 (dolist (c phoros-controls-classes
)
611 (unless (equal c class-name
) (hide-elements-of-class c
))))
612 (reveal-elements-of-class class-name
)
614 (hide-elements-of-class "aux-data-dependent")))
616 (defun hide-aux-data-choice ()
617 "Disable selector for auxiliary data."
618 (hide-element-with-id "include-aux-data")
619 (hide-element-with-id "aux-point-distance")
620 (setf (chain document
621 (get-element-by-id "aux-point-distance")
626 (defun refresh-layer (layer)
627 "Have layer re-request and redraw features."
628 (chain layer
(refresh (create :force t
))))
630 (defun present-photos ()
631 "Handle the response triggered by request-photos-for-point."
632 (let ((photo-parameters
635 photo-request-response response-text
)))))
637 for i across
*images
*
638 do
(chain i
(delete-photo)))
639 (if (@ photo-parameters
0 footprintp
)
640 (hide-element-with-id "no-footprints-p")
641 (reveal-element-with-id "no-footprints-p"))
643 for p across photo-parameters
644 for i across
*images
*
646 (setf (@ i photo-parameters
) p
)
647 (chain i
(show-photo)))))
649 (defun recommend-fresh-login ()
650 "Notify user about invalid authentication."
651 (setf (inner-html-with-id "recommend-fresh-login")
652 "(not authenticated)")
653 (disable-element-with-id "download-user-points-button")
654 (disable-element-with-id "blurb-button")
655 (hide-element-with-id "phoros-controls")
656 (hide-element-with-id "images"))
658 (defun consolidate-combobox (combobox-id)
659 "Help faking a combobox: copy selected option into input."
660 (let* ((combobox-select (+ combobox-id
"-select"))
661 (combobox-input (+ combobox-id
"-input"))
662 (combobox-selected-index
664 (get-element-by-id combobox-select
)
666 (when (< -
1 combobox-selected-index
)
667 (setf (value-with-id combobox-input
)
668 (getprop (chain document
669 (get-element-by-id combobox-select
)
671 combobox-selected-index
674 (get-element-by-id combobox-input
)
677 (defun unselect-combobox-selection (combobox-id)
678 "Help faking a combobox: unset selected option so any
679 selection there will trigger an onchange event."
680 (let ((combobox-select (+ combobox-id
"-select")))
681 (setf (chain document
682 (get-element-by-id combobox-select
)
686 (defun stuff-combobox (combobox-id values
&optional
(selection -
1))
687 "Stuff combobox with values. If selection is a non-negative
688 integer, select the respective item."
689 (let ((combobox-select (+ combobox-id
"-select"))
690 (combobox-input (+ combobox-id
"-input")))
691 (setf (chain document
692 (get-element-by-id combobox-select
)
697 (loop for i in values do
699 (chain document
(create-element "option")))
700 (setf (@ combobox-item text
) i
)
702 (get-element-by-id combobox-select
)
703 (add combobox-item null
)))
704 (setf (chain document
705 (get-element-by-id combobox-select
)
708 (consolidate-combobox combobox-id
)))
710 (defun stuff-user-point-comboboxes (&optional selectp
)
711 "Stuff user point attribute comboboxes with sensible values.
712 If selectp it t, select the most frequently used one."
716 user-point-choice-response response-text
))))
718 (chain response kinds
(map (lambda (x)
721 (chain response descriptions
(map (lambda (x)
722 (@ x description
)))))
724 (best-used-description -
1))
728 for i across
(@ response descriptions
)
730 do
(when (< maximum
(@ i count
))
731 (setf maximum
(@ i count
))
732 (setf best-used-description k
)))
735 for i across
(@ response kinds
)
737 do
(when (< maximum
(@ i count
))
738 (setf maximum
(@ i count
))
739 (setf best-used-kind k
))))
741 "point-kind" kinds best-used-kind
)
743 "point-description" descriptions best-used-description
)))
745 (defun request-user-point-choice (&optional selectp
)
746 "Stuff user point attribute comboboxes with sensible values.
747 If selectp it t, select the most frequently used one."
748 (setf (@ *streetmap
* user-point-choice-response
)
753 (create :url
(+ "/" +proxy-root
+
754 "/lib/user-point-attributes.json")
756 :headers
(create "Content-type" "text/plain")
758 (stuff-user-point-comboboxes selectp
))
759 :failure recommend-fresh-login
)))))
761 (defun stuff-restriction-select ()
762 "Stuff available restriction IDs into restriction-select."
766 restriction-select-choice-response
768 (restriction-select-options
770 (get-element-by-id "restriction-select")
773 for restriction in response
775 do
(setf (elt restriction-select-options i
)
776 (new (chain (*option restriction
)))))))
778 (defun request-restriction-select-choice ()
779 "Stuff available restriction IDs into restriction-select."
780 (setf (@ *streetmap
* restriction-select-choice-response
)
785 (create :url
(+ "/" +proxy-root
+
786 "/lib/selectable-restrictions.json")
788 :headers
(create "Content-type" "text/plain")
789 :success stuff-restriction-select
790 :failure recommend-fresh-login
)))))
792 (defun selected-restrictions ()
793 "Return list of restriction IDs selected by user."
794 (let ((restriction-select-options
796 (get-element-by-id "restriction-select")
799 for restriction in restriction-select-options
800 when
(@ restriction selected
)
801 collect
(@ restriction text
))))
803 (defun unselect-all-restrictions ()
804 "Clear any selected restrictions."
806 for option across
(chain document
807 (get-element-by-id "restriction-select")
809 do
(setf (@ option selected
) f
))
812 (defun request-photos-after-click (event)
813 "Handle the response to a click into *streetmap*; fetch photo
814 data. Set or update streetmap cursor."
815 (request-photos (chain *streetmap
*
816 (get-lon-lat-from-pixel (@ event xy
)))))
818 (defun request-photos (&optional lonlat
)
819 "Set streetmap cursor to lonlat if provided. Fetch photo
820 data for a point near streetmap cursor."
822 (setf (@ *streetmap
* clicked-lonlat
) lonlat
))
823 (if (checkbox-status-with-id "walk-p")
824 (request-aux-data-linestring-for-point
825 (@ *streetmap
* clicked-lonlat
))
826 (request-photos-for-point)))
828 (defun request-aux-data-linestring-for-point (lonlat-spherical-mercator)
829 "Fetch a linestring along auxiliary points near
830 lonlat-spherical-mercator."
831 (let ((lonlat-geographic
832 (chain lonlat-spherical-mercator
834 (transform +spherical-mercator
+ +geographic
+))))
835 (request-aux-data-linestring (@ lonlat-geographic lon
)
836 (@ lonlat-geographic lat
)
837 (* *linestring-step-ratio
*
839 (step-size-degrees))))
841 (defun request-photos-for-point ()
842 "Fetch photo data near (@ *streetmap* clicked-lonlat); set or
843 update streetmap cursor."
844 (remove-any-layers "Estimated Position")
845 (disable-streetmap-nearest-aux-points-layer)
846 (reset-layers-and-controls)
847 (let* ((lonlat-spherical-mercator
848 (@ *streetmap
* clicked-lonlat
))
850 (chain lonlat-spherical-mercator
852 (transform +spherical-mercator
+ +geographic
+)))
856 (create :longitude
(@ lonlat-geographic lon
)
857 :latitude
(@ lonlat-geographic lat
)
858 :zoom
(chain *streetmap
* (get-zoom))
859 :count
(lisp *number-of-images
*)
860 :selected-restriction-ids
861 (selected-restrictions))))))
864 (remove-all-features))
868 (new (chain *open-layers
874 (*point
(@ lonlat-spherical-mercator
876 (@ lonlat-spherical-mercator
879 overview-cursor-layer
880 (remove-all-features))
882 overview-cursor-layer
884 (new (chain *open-layers
890 (*point
(@ lonlat-spherical-mercator
892 (@ lonlat-spherical-mercator
894 (setf (@ *streetmap
* photo-request-response
)
900 :url
(+ "/" +proxy-root
+ "/lib/nearest-image-data")
902 :headers
(create "Content-type" "text/plain"
903 "Content-length" (@ content length
))
904 :success present-photos
905 :failure recommend-fresh-login
))))))
907 (defun draw-epipolar-line ()
908 "Draw an epipolar line from response triggered by clicking
909 into a (first) photo."
910 (disable-streetmap-nearest-aux-points-layer)
911 (enable-element-with-id "remove-work-layers-button")
912 (switch-phoros-controls-to "point-creator")
913 (let* ((epipolar-line
916 (@ this epipolar-request-response response-text
))))
920 (new (chain *open-layers
923 (@ x
:m
) (@ x
:n
))))))))
925 (new (chain *open-layers
931 (*line-string points
))))))))
932 (setf (@ feature render-intent
) "temporary")
933 (chain this epipolar-layer
934 (add-features feature
))))
936 (defun request-aux-points-near-cursor (count)
937 "Draw into streetmap the count nearest points of auxiliary
938 data around streetmap cursor."
939 (let ((lonlat-geographic
940 (chain (@ *streetmap
* clicked-lonlat
)
942 (transform +spherical-mercator
+ +geographic
+))))
943 (request-nearest-aux-points
944 (create :longitude
(@ lonlat-geographic lon
)
945 :latitude
(@ lonlat-geographic lat
))
948 (defun request-nearest-aux-points (global-position count
)
949 "Draw into streetmap the count nearest points of auxiliary
950 data around global-position."
951 (let ((global-position-etc global-position
)
953 (setf (@ global-position-etc count
) count
)
954 (setf content
(chain *json-parser
*
955 (write global-position-etc
)))
956 (setf (@ *streetmap
* aux-local-data-request-response
)
960 (create :url
(+ "/" +proxy-root
+
961 "/lib/aux-local-data")
963 :headers
(create "Content-type" "text/plain"
966 :success draw-nearest-aux-points
967 :failure recommend-fresh-login
))))))
969 (defun request-aux-data-linestring (longitude latitude radius step-size
)
970 "Draw into streetmap a piece of linestring threaded along the
971 nearest points of auxiliary data inside radius."
972 (let* ((payload (create longitude longitude
976 azimuth
(@ *streetmap
*
977 linestring-central-azimuth
)))
978 (content (chain *json-parser
* (write payload
))))
979 (setf (@ *streetmap
* aux-data-linestring-request-response
)
983 (create :url
(+ "/" +proxy-root
+
984 "/lib/aux-local-linestring.json")
986 :headers
(create "Content-type" "text/plain"
989 :success draw-aux-data-linestring
990 :failure recommend-fresh-login
))))))
992 (defun draw-estimated-positions ()
993 "Draw into streetmap and into all images points at Estimated
994 Position. Estimated Position is the point returned so far
995 from photogrammetric calculations that are triggered by
996 clicking into another photo. Also draw into streetmap the
997 nearest auxiliary points to Estimated Position."
998 (when (write-permission-p)
999 (setf (chain document
1000 (get-element-by-id "finish-point-button")
1002 (lambda () (finish-point #'store-point
)))
1003 (enable-element-with-id "finish-point-button"))
1004 (let* ((estimated-positions-request-response
1005 (chain *json-parser
*
1008 estimated-positions-request-response
1010 (estimated-positions
1011 (aref estimated-positions-request-response
1))
1012 (estimated-position-style
1013 (create stroke-color
(chain *open-layers
1016 style
"temporary" stroke-color
)
1019 (setf *global-position
*
1020 (aref estimated-positions-request-response
0))
1027 (new (chain *open-layers
1030 (@ *global-position
* longitude
)
1031 (@ *global-position
* latitude
))))
1032 (transform +geographic
+ +spherical-mercator
+)))))))
1033 (setf (@ feature render-intent
) "temporary")
1034 (setf (@ *streetmap
* estimated-position-layer
)
1035 (new (chain *open-layers
1038 "Estimated Position"
1039 (create display-in-layer-switcher nil
)))))
1040 (setf (@ *streetmap
* estimated-position-layer style
)
1041 estimated-position-style
)
1042 (chain *streetmap
* estimated-position-layer
(add-features feature
))
1044 (add-layer (@ *streetmap
* estimated-position-layer
))))
1045 (request-nearest-aux-points *global-position
* 7)
1048 for p in estimated-positions
1050 (when p
;otherwise a photogrammetry error has occured
1051 (setf (@ i estimated-position-layer
)
1056 "Estimated Position"
1057 (create display-in-layer-switcher nil
)))))
1058 (setf (@ i estimated-position-lonlat
)
1059 (new (chain *open-layers
(*lon-lat
(@ p m
)
1061 (setf (@ i estimated-position-layer style
)
1062 estimated-position-style
)
1065 (chain *open-layers
*geometry
(*point
(@ p m
)
1069 (chain *open-layers
*feature
(*vector point
)))))
1071 (add-layer (@ i estimated-position-layer
)))
1072 (chain i estimated-position-layer
1073 (add-features feature
))))))
1074 (zoom-anything-to-point)
1076 (get-element-by-id "finish-point-button")
1079 (defun draw-nearest-aux-points ()
1080 "Draw a few auxiliary points into streetmap."
1082 (chain *json-parser
*
1085 aux-local-data-request-response
1088 (disable-streetmap-nearest-aux-points-layer)
1089 (chain *streetmap
* user-points-select-control
(deactivate))
1090 (chain *streetmap
* nearest-aux-points-select-control
(activate))
1091 (chain *streetmap
* nearest-aux-points-hover-control
(activate))
1092 (setf (@ *aux-point-distance-select
* options length
)
1102 (*point
(@ i geometry coordinates
0)
1103 (@ i geometry coordinates
1))))
1104 (transform +geographic
+ +spherical-mercator
+)))
1107 (chain *open-layers
*feature
(*vector point
)))))
1108 (setf (@ feature attributes
)
1110 (setf (@ feature fid
) ;this is supposed to correspond to
1111 n
) ; option of *aux-point-distance-select*
1113 nearest-aux-points-layer
1114 (add-features feature
))
1115 (setf aux-point-distance-item
1116 (chain document
(create-element "option")))
1117 (setf (@ aux-point-distance-item text
)
1120 n
;let's hope add-features alway stores features in order of arrival
1124 (format (@ i properties distance
) 3 ""))))
1125 (chain *aux-point-distance-select
*
1126 (add aux-point-distance-item null
))))
1128 nearest-aux-points-select-control
1131 (elt (@ *streetmap
* nearest-aux-points-layer features
)
1133 (enable-element-with-id "aux-point-distance")))
1135 (defun draw-aux-data-linestring ()
1136 "Draw a piece of linestring along a few auxiliary points into
1137 streetmap. Pan streetmap accordingly."
1140 aux-data-linestring-request-response
1143 (chain *json-parser
* (read data
) linestring
))
1145 (chain *json-parser
* (read data
) current-point
))
1147 (chain *json-parser
* (read data
) previous-point
))
1149 (chain *json-parser
* (read data
) next-point
))
1151 (chain *json-parser
* (read data
) azimuth
))
1153 (chain *wkt-parser
* (read linestring-wkt
)))
1155 (chain *wkt-parser
* (read current-point-wkt
)))
1157 (chain *wkt-parser
* (read previous-point-wkt
)))
1159 (chain *wkt-parser
* (read next-point-wkt
)))
1160 (current-point-lonlat
1161 (new (chain *open-layers
1162 (*lon-lat
(@ current-point geometry x
)
1163 (@ current-point geometry y
))))))
1164 (chain *streetmap
* (pan-to current-point-lonlat
))
1165 (setf (@ *streetmap
* clicked-lonlat
) current-point-lonlat
)
1166 (setf (@ *streetmap
* linestring-central-azimuth
) azimuth
)
1167 (request-photos-for-point)
1168 (setf (@ *streetmap
* step-back-point
) previous-point
)
1169 (setf (@ *streetmap
* step-forward-point
) next-point
)
1170 (chain *streetmap
* aux-data-linestring-layer
(remove-all-features))
1172 aux-data-linestring-layer
1173 (add-features linestring
))))
1175 (defun step (&optional back-p
)
1176 "Enable walk-mode if necessary, and do a step along
1177 aux-data-linestring."
1178 (if (checkbox-status-with-id "walk-p")
1179 (let ((next-point-geometry
1182 (if (< (- (@ *streetmap
* linestring-central-azimuth
) pi
) 0)
1183 (setf (@ *streetmap
* linestring-central-azimuth
)
1184 (+ (@ *streetmap
* linestring-central-azimuth
) pi
))
1185 (setf (@ *streetmap
* linestring-central-azimuth
)
1186 (- (@ *streetmap
* linestring-central-azimuth
) pi
)))
1191 (transform +spherical-mercator
+ +geographic
+)))
1196 (transform +spherical-mercator
+ +geographic
+)))))
1197 (request-aux-data-linestring (@ next-point-geometry x
)
1198 (@ next-point-geometry y
)
1199 (* *linestring-step-ratio
*
1200 (step-size-degrees))
1201 (step-size-degrees)))
1203 (setf (checkbox-status-with-id "walk-p") t
) ;doesn't seem to trigger event
1204 (flip-walk-mode)))) ; so we have to do it explicitly
1206 (defun step-size-degrees ()
1207 "Return inner-html of element step-size (metres) converted
1208 into map units (degrees). You should be close to the
1210 (/ (inner-html-with-id "step-size") 1855.325 60))
1212 (defun decrease-step-size ()
1213 (when (> (inner-html-with-id "step-size") 0.5)
1214 (setf (inner-html-with-id "step-size")
1215 (/ (inner-html-with-id "step-size") 2))))
1217 (defun increase-step-size ()
1218 (when (< (inner-html-with-id "step-size") 100)
1219 (setf (inner-html-with-id "step-size")
1220 (* (inner-html-with-id "step-size") 2))))
1222 (defun user-point-style-map (label-property)
1223 "Create a style map where styles dispatch on feature property
1224 \"kind\" and features are labelled after feature
1225 property label-property."
1226 (let* ((symbolizer-property "kind")
1228 (new (chain *open-layers
1230 (*comparison
(create type
(chain *open-layers
1234 property symbolizer-property
1235 value
"solitary")))))
1237 (new (chain *open-layers
1239 (*comparison
(create type
(chain *open-layers
1243 property symbolizer-property
1244 value
"polyline")))))
1246 (new (chain *open-layers
1248 (*comparison
(create type
(chain *open-layers
1252 property symbolizer-property
1253 value
"polygon")))))
1255 (new (chain *open-layers
1257 (*comparison
(create type
(chain *open-layers
1261 property symbolizer-property
1264 (new (chain *open-layers
1266 (*comparison
(create type
(chain *open-layers
1270 property symbolizer-property
1273 (new (chain *open-layers
1275 (*comparison
(create type
(chain *open-layers
1279 property symbolizer-property
1282 (new (chain *open-layers
1284 (*comparison
(create type
(chain *open-layers
1288 property symbolizer-property
1291 (new (chain *open-layers
1293 (*comparison
(create type
(chain *open-layers
1297 property symbolizer-property
1300 (new (chain *open-layers
1302 (*comparison
(create type
(chain *open-layers
1306 property symbolizer-property
1309 (new (chain *open-layers
1311 (*comparison
(create type
(chain *open-layers
1315 property symbolizer-property
1318 (new (chain *open-layers
1320 (*comparison
(create type
(chain *open-layers
1324 property symbolizer-property
1327 (new (chain *open-layers
1329 (*comparison
(create type
(chain *open-layers
1333 property symbolizer-property
1336 (new (chain *open-layers
1338 (*comparison
(create type
(chain *open-layers
1342 property symbolizer-property
1345 (new (chain *open-layers
1347 filter solitary-filter
1349 graphic-name
"triangle"))))))
1351 (new (chain *open-layers
1353 filter polyline-filter
1355 graphic-name
"square"
1356 point-radius
4))))))
1358 (new (chain *open-layers
1360 filter polygon-filter
1362 graphic-name
"star"))))))
1364 (new (chain *open-layers
1368 graphic-name
"circle"))))))
1370 (new (chain *open-layers
1374 graphic-name
"cross"))))))
1376 (new (chain *open-layers
1380 graphic-name
"x"))))))
1382 (new (chain *open-layers
1386 graphic-name
"triangle"))))))
1388 (new (chain *open-layers
1392 graphic-name
"square"))))))
1394 (new (chain *open-layers
1398 graphic-name
"star"))))))
1400 (new (chain *open-layers
1405 graphic-name
"circle"))))))
1407 (new (chain *open-layers
1412 graphic-name
"triangle"))))))
1414 (new (chain *open-layers
1419 graphic-name
"square"))))))
1421 (new (chain *open-layers
1426 graphic-name
"star"))))))
1428 (new (chain *open-layers
1432 graphic-name
"x"))))))
1433 (user-point-default-style
1436 (*style
(create stroke-color
"OrangeRed"
1437 fill-color
"OrangeRed"
1440 font-color
"OrangeRed"
1441 font-family
"'andale mono', 'lucida console', monospace"
1446 (create rules
(array solitary-rule
1460 (user-point-select-style
1463 (*style
(create stroke-opacity
1
1464 label label-property
)
1465 (create rules
(array solitary-rule
1478 (user-point-temporary-style
1481 (*style
(create fill-opacity
.5)
1482 (create rules
(array solitary-rule
1495 (new (chain *open-layers
1497 (create "default" user-point-default-style
1498 "temporary" user-point-temporary-style
1499 "select" user-point-select-style
))))))
1501 (defun draw-user-points ()
1502 "Draw currently selected user points into all images."
1503 (let* ((user-point-positions-response
1504 (chain *json-parser
*
1506 (@ *user-point-in-images-response
* response-text
))))
1507 (user-point-collections
1508 (chain user-point-positions-response image-points
))
1510 (chain user-point-positions-response user-point-count
))
1512 (when (> user-point-count
1) "${numericDescription}")))
1515 for user-point-collection in user-point-collections
1517 (when i
;otherwise a photogrammetry error has occured
1521 (@ user-point-collection features
)
1524 (@ raw-feature geometry coordinates
0))
1526 (@ raw-feature geometry coordinates
1))
1528 (new (chain *open-layers
1534 (@ raw-feature properties
))
1536 (new (chain *open-layers
1538 (*vector point attributes
)))))
1539 (setf (@ feature fid
) fid
)
1540 (setf (@ feature render-intent
) "select")
1543 (@ i user-point-layer
)
1544 (new (chain *open-layers
1548 (create display-in-layer-switcher nil
1549 style-map
(user-point-style-map
1551 (chain i map
(add-layer (@ i user-point-layer
)))
1552 (chain i user-point-layer
(add-features features
)))))))
1554 (defun finish-point (database-writer)
1555 "Try, with some user interaction, to uniquify user-point
1556 attributes and call database-writer."
1558 (create user-point-id
(if (defined *current-user-point
*)
1559 (@ *current-user-point
* fid
)
1562 (value-with-id "point-kind-input")
1564 (value-with-id "point-description-input")
1566 (value-with-id "point-numeric-description")))
1568 (chain *json-parser
*
1569 (write point-data
)))
1570 (delete-point-button-active-p
1571 (disable-element-with-id "delete-point-button")))
1572 (disable-element-with-id "finish-point-button")
1573 (setf *uniquify-point-attributes-response
* nil
)
1574 (setf *uniquify-point-attributes-response
*
1580 :url
(+ "/" +proxy-root
+ "/lib/uniquify-point-attributes")
1582 :headers
(create "Content-type" "text/plain"
1583 "Content-length" (@ content
1587 (enable-element-with-id "finish-point-button")
1588 (when delete-point-button-active-p
1589 (enable-element-with-id "delete-point-button"))
1594 (@ *uniquify-point-attributes-response
*
1596 (if (equal null response
)
1602 "force-duplicate-button")
1605 (hide-element-with-id "uniquify-buttons")
1606 (reveal-element-with-id "finish-point-button")
1608 (hide-element-with-id "finish-point-button")
1609 (reveal-element-with-id "uniquify-buttons")))))
1610 :failure recommend-fresh-login
))))))
1612 (defun insert-unique-suggestion ()
1613 "Insert previously received set of unique user-point
1614 attributes into their respective input elements; switch
1615 buttons accordingly."
1617 (create user-point-id
(if (defined *current-user-point
*)
1618 (@ *current-user-point
* fid
)
1621 (value-with-id "point-kind-input")
1623 (value-with-id "point-description-input")
1625 (value-with-id "point-numeric-description")))
1627 (chain *json-parser
*
1628 (write point-data
)))
1629 (delete-point-button-active-p
1630 (disable-element-with-id "delete-point-button")))
1631 (disable-element-with-id "finish-point-button")
1632 (hide-element-with-id "uniquify-buttons")
1633 (reveal-element-with-id "finish-point-button")
1634 (setf *uniquify-point-attributes-response
* nil
)
1635 (setf *uniquify-point-attributes-response
*
1642 "/lib/uniquify-point-attributes")
1644 :headers
(create "Content-type" "text/plain"
1645 "Content-length" (@ content
1649 (enable-element-with-id "finish-point-button")
1650 (when delete-point-button-active-p
1651 (enable-element-with-id "delete-point-button"))
1656 (@ *uniquify-point-attributes-response
*
1658 (unless (equal null response
)
1659 (setf (value-with-id
1660 "point-numeric-description")
1661 (@ response numeric-description
)))))
1662 :failure recommend-fresh-login
))))))
1664 (defun store-point ()
1665 "Send freshly created user point to the database."
1666 (let ((global-position-etc *global-position
*))
1667 (setf (@ global-position-etc kind
)
1668 (value-with-id "point-kind-input"))
1669 (setf (@ global-position-etc description
)
1670 (value-with-id "point-description-input"))
1671 (setf (@ global-position-etc numeric-description
)
1672 (value-with-id "point-numeric-description"))
1673 (when (checkbox-status-with-id "include-aux-data-p")
1674 (setf (@ global-position-etc aux-numeric
)
1675 (@ *current-nearest-aux-point
*
1678 (setf (@ global-position-etc aux-text
)
1679 (@ *current-nearest-aux-point
*
1683 (chain *json-parser
*
1684 (write global-position-etc
))))
1685 (disable-element-with-id "finish-point-button")
1690 (create :url
(+ "/" +proxy-root
+ "/lib/store-point")
1692 :headers
(create "Content-type" "text/plain"
1693 "Content-length" (@ content length
))
1696 (@ *streetmap
* user-point-layer
))
1697 (reset-layers-and-controls)
1698 (request-user-point-choice))
1699 :failure recommend-fresh-login
))))))
1701 (defun update-point ()
1702 "Send changes to currently selected user point to database."
1704 (create user-point-id
(@ *current-user-point
* fid
)
1706 (value-with-id "point-kind-input")
1708 (value-with-id "point-description-input")
1710 (value-with-id "point-numeric-description")))
1712 (chain *json-parser
*
1713 (write point-data
))))
1714 (disable-element-with-id "finish-point-button")
1715 (disable-element-with-id "delete-point-button")
1719 (create :url
(+ "/" +proxy-root
+ "/lib/update-point")
1721 :headers
(create "Content-type" "text/plain"
1722 "Content-length" (@ content
1726 (@ *streetmap
* user-point-layer
))
1727 (reset-layers-and-controls)
1728 (request-user-point-choice))
1729 :failure recommend-fresh-login
)))))
1731 (defun delete-point ()
1732 "Purge currently selected user point from database."
1733 (let* ((user-point-id (@ *current-user-point
* fid
))
1735 (chain *json-parser
*
1736 (write user-point-id
))))
1737 (disable-element-with-id "finish-point-button")
1738 (disable-element-with-id "delete-point-button")
1742 (create :url
(+ "/" +proxy-root
+ "/lib/delete-point")
1744 :headers
(create "Content-type" "text/plain"
1745 "Content-length" (@ content
1749 (@ *streetmap
* user-point-layer
))
1750 (reset-layers-and-controls)
1751 (request-user-point-choice true
))
1752 :failure recommend-fresh-login
)))))
1754 (defun draw-active-point ()
1755 "Draw an Active Point, i.e. a point used in subsequent
1756 photogrammetric calculations."
1760 (new (chain *open-layers
1763 (new (chain *open-layers
1766 (@ this photo-parameters m
)
1767 (@ this photo-parameters n
))))))))))
1769 (defun image-click-action (clicked-image)
1771 "Do appropriate things when an image is clicked into."
1773 (chain clicked-image map
(get-lon-lat-from-view-port-px
1776 (@ clicked-image photo-parameters
))
1777 pristine-image-p content request
)
1778 (when (and (@ photo-parameters usable
)
1779 (chain clicked-image
(photop)))
1780 (setf (@ photo-parameters m
) (@ lonlat lon
)
1781 (@ photo-parameters n
) (@ lonlat lat
))
1782 (remove-layer (@ clicked-image map
) "Active Point")
1783 (remove-any-layers "Epipolar Line")
1784 (setf *pristine-images-p
* (not (some-active-point-p)))
1785 (setf (@ clicked-image active-point-layer
)
1786 (new (chain *open-layers
1788 (*vector
"Active Point"
1789 (create display-in-layer-switcher
1791 (chain clicked-image
1793 (add-layer (@ clicked-image active-point-layer
)))
1794 (chain clicked-image
(draw-active-point))
1799 (remove-any-layers "User Point") ;from images
1801 ;; There's something in the following line that
1802 ;; restores layer "User Point" and removes layer
1803 ;; "Active Point" when coming from directly a
1804 ;; point-editor situation.
1805 (chain *streetmap
* user-points-select-control
(unselect-all))
1807 for i across
*images
* do
1808 (when (and (not (equal i clicked-image
))
1811 (@ i epipolar-layer
)
1812 (new (chain *open-layers
1814 (*vector
"Epipolar Line"
1816 display-in-layer-switcher nil
))))
1817 content
(chain *json-parser
*
1819 (append (array photo-parameters
)
1820 (@ i photo-parameters
))))
1821 (@ i epipolar-request-response
)
1825 (create :url
(+ "/" +proxy-root
+
1826 "/lib/epipolar-line")
1829 "Content-type" "text/plain"
1832 :success
(@ i draw-epipolar-line
)
1833 :failure recommend-fresh-login
1837 (add-layer (@ i epipolar-layer
))))))
1839 (remove-any-layers "Epipolar Line")
1840 (remove-any-layers "Estimated Position")
1841 (let* ((active-pointed-photo-parameters
1843 for i across
*images
*
1844 when
(has-layer-p (@ i map
) "Active Point")
1845 collect
(@ i photo-parameters
)))
1847 (chain *json-parser
*
1849 (list active-pointed-photo-parameters
1854 photo-parameters
)))))))))
1855 (setf (@ clicked-image estimated-positions-request-response
)
1859 (create :url
(+ "/" +proxy-root
+
1860 "/lib/estimated-positions")
1863 "Content-type" "text/plain"
1866 :success
(@ clicked-image
1867 draw-estimated-positions
)
1868 :failure recommend-fresh-login
1869 :scope clicked-image
)))))))))))
1871 (defun iso-time-string (lisp-time)
1872 "Return Lisp universal time formatted as ISO time string"
1873 (let* ((unix-time (- lisp-time
+unix-epoch
+))
1874 (js-date (new (*date
(* 1000 unix-time
)))))
1875 (chain *open-layers
*date
(to-i-s-o-string js-date
))))
1877 (defun delete-photo ()
1878 "Delete this object's photo."
1880 repeat
(chain this map
(get-num-layers))
1881 do
(chain this map layers
0 (destroy)))
1882 (hide-element-with-id (@ this usable-id
))
1883 (setf (@ this trigger-time-div inner-h-t-m-l
) nil
))
1886 "Check if this object contains a photo."
1887 (@ this trigger-time-div inner-h-t-m-l
))
1889 (defun show-photo ()
1890 "Show the photo described in this object's photo-parameters."
1891 (let ((image-div-width
1892 (parse-int (chain (get-computed-style (@ this map div
) nil
)
1895 (parse-int (chain (get-computed-style (@ this map div
) nil
)
1898 (@ this photo-parameters sensor-width-pix
))
1900 (@ this photo-parameters sensor-height-pix
)))
1910 (photo-path (@ this photo-parameters
))
1911 (new (chain *open-layers
1914 (+ image-width
.5) (+ image-height
.5))))
1915 (new (chain *open-layers
1916 (*size image-div-width
1919 max-resolution
(chain
1922 (/ image-width image-div-width
)
1923 (/ image-height image-div-height
)))))))))
1924 (when (@ this photo-parameters rendered-footprint
)
1925 (setf (@ this footprint-layer
)
1929 (*vector
"Footprint"
1930 (create display-in-layer-switcher nil
1931 style
(create stroke-color
"yellow"
1933 stroke-opacity
.3))))))
1937 (chain *geojson-parser
*
1940 rendered-footprint
)))))
1943 (add-layer (@ this footprint-layer
))))
1944 (chain this map
(zoom-to-max-extent))
1945 (if (@ this photo-parameters usable
)
1946 (hide-element-with-id (@ this usable-id
))
1947 (reveal-element-with-id (@ this usable-id
)))
1948 (setf (@ this trigger-time-div inner-h-t-m-l
)
1949 (iso-time-string (@ this photo-parameters trigger-time
)))))
1951 (defun zoom-images-to-max-extent ()
1952 "Zoom out all images."
1954 for i across
*images
*
1955 do
(when (> (@ i map layers length
) 0)
1956 (chain i map
(zoom-to-max-extent)))))
1958 (defun zoom-anything-to-point ()
1959 "For streetmap and for images that have an Active Point or an
1960 Estimated Position, zoom in and recenter."
1961 (when (checkbox-status-with-id "zoom-to-point-p")
1963 (new (chain *open-layers
1964 (*lon-lat
(@ *global-position
* longitude
)
1965 (@ *global-position
* latitude
))
1966 (transform +geographic
+ +spherical-mercator
+)))))
1969 (set-center point-lonlat
18 nil t
))))
1970 (loop for i across
*images
* do
1973 ((has-layer-p (@ i map
) "Active Point")
1974 (new (chain *open-layers
(*lon-lat
1975 (@ i photo-parameters m
)
1976 (@ i photo-parameters n
)))))
1977 ((has-layer-p (@ i map
) "Estimated Position")
1978 (@ i estimated-position-lonlat
))
1981 (chain i map
(set-center point-lonlat
4 nil t
)))))))
1983 (defun initialize-image (image-index)
1984 "Create an image usable for displaying photos at position
1985 image-index in array *images*."
1986 (setf (aref *images
* image-index
) (new *image
))
1987 (setf (@ (aref *images
* image-index
) usable-id
)
1988 (+ "image-" image-index
"-usable"))
1989 (hide-element-with-id (+ "image-" image-index
"-usable"))
1990 (setf (@ (aref *images
* image-index
) trigger-time-div
)
1993 (get-element-by-id (+ "image-" image-index
"-trigger-time"))))
1994 (setf (@ (aref *images
* image-index
) image-click-action
)
1995 (image-click-action (aref *images
* image-index
)))
1996 (setf (@ (aref *images
* image-index
) click
)
1997 (new (*click-control
*
1998 (create :trigger
(@ (aref *images
* image-index
)
1999 image-click-action
)))))
2000 (chain (aref *images
* image-index
)
2003 (@ (aref *images
* image-index
) click
)))
2004 (chain (aref *images
* image-index
) click
(activate))
2005 ;;(chain (aref *images* image-index)
2008 ;; (new (chain *open-layers
2014 ;; (get-element-by-id
2015 ;; (+ "image-" image-index "-zoom")))))))))
2016 (chain (aref *images
* image-index
)
2019 (new (chain *open-layers
2026 (+ "image-" image-index
"-layer-switcher")))
2027 rounded-corner nil
))))))
2028 (let ((pan-west-control
2029 (new (chain *open-layers
*control
(*pan
"West"))))
2031 (new (chain *open-layers
*control
(*pan
"North"))))
2033 (new (chain *open-layers
*control
(*pan
"South"))))
2035 (new (chain *open-layers
*control
(*pan
"East"))))
2037 (new (chain *open-layers
*control
(*zoom-in
))))
2039 (new (chain *open-layers
*control
(*zoom-out
))))
2040 (zoom-to-max-extent-control
2041 (new (chain *open-layers
*control
(*zoom-to-max-extent
))))
2043 (new (chain *open-layers
2050 (+ "image-" image-index
"-zoom")))))))))
2051 (chain (aref *images
* image-index
)
2053 (add-control pan-zoom-panel
))
2054 (chain pan-zoom-panel
2055 (add-controls (array pan-west-control
2061 zoom-to-max-extent-control
))))
2062 (chain (aref *images
* image-index
)
2064 (render (chain document
2066 (+ "image-" image-index
))))))
2068 (defun user-point-selected (event)
2069 "Things to do once a user point is selected."
2070 (remove-any-layers "Active Point")
2071 (remove-any-layers "Epipolar Line")
2072 (remove-any-layers "Estimated Position")
2073 (unselect-combobox-selection "point-kind")
2074 (unselect-combobox-selection "point-description")
2075 (user-point-selection-changed))
2077 (defun user-point-unselected (event)
2078 "Things to do once a user point is unselected."
2080 (user-point-selection-changed))
2082 (defun user-point-selection-changed ()
2083 "Things to do once a user point is selected or unselected."
2084 (setf *current-user-point
*
2085 (@ *streetmap
* user-point-layer selected-features
0))
2086 (let ((selected-features-count
2087 (@ *streetmap
* user-point-layer selected-features length
)))
2088 (setf (@ *streetmap
* user-point-layer style-map
)
2089 (user-point-style-map
2090 (when (> selected-features-count
1)
2091 "${numericDescription}")))
2093 ((> selected-features-count
1)
2094 (switch-phoros-controls-to "multiple-points-viewer"))
2095 ((= selected-features-count
1)
2096 (setf (value-with-id "point-kind-input")
2097 (@ *current-user-point
* attributes kind
))
2098 (setf (value-with-id "point-description-input")
2099 (@ *current-user-point
* attributes description
))
2100 (setf (value-with-id "point-numeric-description")
2101 (@ *current-user-point
* attributes numeric-description
))
2102 (setf (inner-html-with-id "point-creation-date")
2103 (@ *current-user-point
* attributes creation-date
))
2104 (setf (inner-html-with-id "aux-numeric-list")
2106 (@ *current-user-point
* attributes aux-numeric
)
2107 +aux-numeric-labels
+))
2108 (setf (inner-html-with-id "aux-text-list")
2110 (@ *current-user-point
* attributes aux-text
)
2112 (switch-phoros-controls-to "point-editor")
2113 (if (write-permission-p
2114 (@ *current-user-point
* attributes user-name
))
2116 (setf (chain document
2117 (get-element-by-id "finish-point-button")
2119 (lambda () (finish-point #'update-point
)))
2120 (enable-element-with-id "finish-point-button")
2121 (enable-element-with-id "delete-point-button")
2122 (switch-phoros-controls-to "point-editor"))
2124 (disable-element-with-id "finish-point-button")
2125 (disable-element-with-id "delete-point-button")
2126 (switch-phoros-controls-to "point-viewer")))
2127 (setf (inner-html-with-id "creator")
2128 (if (@ *current-user-point
* attributes user-name
)
2130 (@ *current-user-point
* attributes user-name
)
2134 (reset-layers-and-controls))))
2135 (chain *streetmap
* user-point-layer
(redraw))
2136 (remove-any-layers "User Point") ;from images
2138 (chain *json-parser
*
2140 (array (chain *streetmap
*
2143 (map (lambda (x) (@ x fid
))))
2145 for i across
*images
*
2146 collect
(@ i photo-parameters
))))))
2147 (setf *user-point-in-images-response
*
2151 (create :url
(+ "/" +proxy-root
+
2152 "/lib/user-point-positions")
2154 :headers
(create "Content-type" "text/plain"
2155 "Content-length" (@ content
2157 :success draw-user-points
2158 :failure recommend-fresh-login
)))))
2160 (defun aux-point-distance-selected ()
2161 "Things to do on change of aux-point-distance select element."
2163 nearest-aux-points-select-control
2166 nearest-aux-points-select-control
2169 (elt (@ *streetmap
* nearest-aux-points-layer features
)
2170 (@ *aux-point-distance-select
*
2172 selected-index
))))))
2174 (defun enable-aux-point-selection ()
2175 "Check checkbox include-aux-data-p and act accordingly."
2176 (setf (checkbox-status-with-id "include-aux-data-p") t
)
2177 (flip-aux-data-inclusion))
2179 (defun flip-walk-mode ()
2180 "Query status of checkbox walk-p and induce first walking
2181 step if it's just been turned on. Otherwise delete our
2183 (if (checkbox-status-with-id "walk-p")
2184 (request-aux-data-linestring-for-point (@ *streetmap
*
2187 aux-data-linestring-layer
2188 (remove-all-features))))
2190 (defun flip-aux-data-inclusion ()
2191 "Query status of checkbox include-aux-data-p and act accordingly."
2192 (if (checkbox-status-with-id "include-aux-data-p")
2194 nearest-aux-points-layer
2197 nearest-aux-points-layer
2198 (set-visibility nil
))))
2200 (defun flip-nearest-aux-data-display ()
2201 "Query status of checkbox include-aux-data-p and act accordingly."
2202 (reset-layers-and-controls))
2204 (defun html-table (aux-data labels
)
2205 "Return an html-formatted table with a label column from
2206 labels and a data column from aux-data."
2210 :class
"aux-data-table"
2212 (reduce (lambda (x y i
)
2216 (:td
:class
"aux-data-label"
2223 (:td
:class
"aux-data-value"
2229 (defun nearest-aux-point-selected (event)
2230 "Things to do once a nearest auxiliary point is selected in streetmap."
2231 (setf *current-nearest-aux-point
* (@ event feature
))
2233 (@ event feature attributes aux-numeric
))
2235 (@ event feature attributes aux-text
))
2237 (@ event feature attributes distance
)))
2238 (setf (@ *aux-point-distance-select
* options selected-index
)
2239 (@ event feature fid
))
2240 (setf (inner-html-with-id "aux-numeric-list")
2241 (html-table aux-numeric
+aux-numeric-labels
+))
2242 (setf (inner-html-with-id "aux-text-list")
2243 (html-table aux-text
+aux-text-labels
+))))
2246 "Store user's current map extent and log out."
2247 (let* ((bbox (chain *streetmap
*
2249 (transform +spherical-mercator
+ +geographic
+)
2251 (href (+ "/" +proxy-root
+ "/lib/logout?bbox=" bbox
)))
2252 (when (@ *streetmap
* cursor-layer features length
)
2253 (let* ((lonlat-geographic (chain *streetmap
*
2259 (transform +spherical-mercator
+
2262 "&longitude=" (@ lonlat-geographic x
)
2263 "&latitude=" (@ lonlat-geographic y
)))))
2264 (setf (@ location href
) href
)))
2267 "Prepare user's playground."
2268 (unless +presentation-project-bbox-text
+
2269 (setf (inner-html-with-id "presentation-project-emptiness")
2275 (create projection
+geographic
+
2276 display-projection
+geographic
+
2277 controls
(array (new (chain *open-layers
2280 (new (chain *open-layers
2282 (*attribution
)))))))))
2283 (when (write-permission-p)
2284 (enable-elements-of-class "write-permission-dependent")
2285 (request-user-point-choice true
))
2286 (hide-element-with-id "no-footprints-p")
2287 (hide-element-with-id "uniquify-buttons")
2288 (setf *aux-point-distance-select
*
2289 (chain document
(get-element-by-id "aux-point-distance")))
2290 (let ((cursor-layer-style
2293 external-graphic
(+ "/" +proxy-root
+
2294 "/lib/public_html/phoros-cursor.png"))))
2295 (setf (@ *streetmap
* cursor-layer
)
2301 style cursor-layer-style
)))))
2302 (setf (@ *streetmap
* overview-cursor-layer
)
2308 style cursor-layer-style
))))))
2309 (let ((survey-layer-style
2310 (create stroke-color
(chain *open-layers
*feature
*vector
2311 style
"default" stroke-color
)
2315 graphic-name
"circle")))
2316 (setf (@ *streetmap
* survey-layer
)
2322 strategies
(array (new (*bbox-strategy
*)))
2324 (new (*http-protocol
*
2325 (create :url
(+ "/" +proxy-root
+
2326 "/lib/points.json"))))
2327 style survey-layer-style
))))))
2328 (setf (@ *streetmap
* user-point-layer
)
2334 strategies
(array (new *bbox-strategy
*))
2336 (new (*http-protocol
*
2337 (create :url
(+ "/" +proxy-root
+ "/lib/user-points.json"))))
2338 style-map
(user-point-style-map nil
))))))
2339 (setf (@ *streetmap
* user-points-hover-control
)
2340 (new (chain *open-layers
2342 (*select-feature
(@ *streetmap
* user-point-layer
)
2343 (create render-intent
"temporary"
2345 highlight-only t
)))))
2346 (setf (@ *streetmap
* user-points-select-control
)
2347 (new (chain *open-layers
2349 (*select-feature
(@ *streetmap
* user-point-layer
)
2352 (let ((aux-layer-style
2353 (create stroke-color
"grey"
2357 graphic-name
"circle")))
2358 (setf (@ *streetmap
* aux-point-layer
)
2364 strategies
(array (new (*bbox-strategy
*)))
2366 (new (*http-protocol
*
2367 (create :url
(+ "/" +proxy-root
+
2368 "/lib/aux-points.json"))))
2369 style aux-layer-style
2370 visibility nil
))))))
2371 (let ((nearest-aux-point-layer-style-map
2372 (new (chain *open-layers
2375 (create stroke-color
"grey"
2379 graphic-name
"circle")
2381 (create stroke-color
"black"
2385 graphic-name
"circle")
2387 (create stroke-color
"grey"
2392 graphic-name
"circle")))))))
2393 (setf (@ *streetmap
* nearest-aux-points-layer
)
2394 (new (chain *open-layers
2397 "Nearest Aux Points"
2399 display-in-layer-switcher nil
2400 style-map nearest-aux-point-layer-style-map
2402 (setf (@ *streetmap
* nearest-aux-points-hover-control
)
2403 (new (chain *open-layers
2406 (@ *streetmap
* nearest-aux-points-layer
)
2407 (create render-intent
"temporary"
2409 highlight-only t
)))))
2410 (setf (@ *streetmap
* nearest-aux-points-select-control
)
2411 (new (chain *open-layers
2414 (@ *streetmap
* nearest-aux-points-layer
)))))
2415 (setf (@ *streetmap
* aux-data-linestring-layer
)
2416 (new (chain *open-layers
2419 "Aux Data Linestring"
2421 display-in-layer-switcher nil
2422 style-map nearest-aux-point-layer-style-map
2424 (setf (@ *streetmap
* google-streetmap-layer
)
2425 (new (chain *open-layers
2427 (*google
"Google Streets"
2428 (create num-zoom-levels
23)))))
2429 (setf (@ *streetmap
* osm-layer
)
2430 (new (chain *open-layers
2435 (create num-zoom-levels
23
2437 "Data CC-By-SA by openstreetmap.org")))))
2438 (setf (@ *streetmap
* overview-osm-layer
)
2439 (new (chain *open-layers
2441 (*osm
* "OpenStreetMap"))))
2442 (setf (@ *streetmap
* click-streetmap
)
2443 (new (*click-control
*
2444 (create :trigger request-photos-after-click
))))
2445 (setf (@ *streetmap
* nirvana-layer
)
2450 (create is-base-layer t
2451 projection
(@ *streetmap
* osm-layer projection
)
2452 max-extent
(@ *streetmap
* osm-layer max-extent
)
2453 max-resolution
(@ *streetmap
*
2456 units
(@ *streetmap
* osm-layer units
)
2457 num-zoom-levels
(@ *streetmap
*
2459 num-zoom-levels
))))))
2462 (new (chain *open-layers
2469 "streetmap-layer-switcher"))
2470 rounded-corner nil
))))))
2471 (let ((pan-west-control
2472 (new (chain *open-layers
*control
(*pan
"West"))))
2474 (new (chain *open-layers
*control
(*pan
"North"))))
2476 (new (chain *open-layers
*control
(*pan
"South"))))
2478 (new (chain *open-layers
*control
(*pan
"East"))))
2480 (new (chain *open-layers
*control
(*zoom-in
))))
2482 (new (chain *open-layers
*control
(*zoom-out
))))
2483 (zoom-to-max-extent-control
2489 display-class
"streetmapZoomToMaxExtent"
2493 +presentation-project-bounds
+))))))))
2495 (new (chain *open-layers
2502 "streetmap-zoom")))))))
2504 (new (chain *open-layers
2510 (@ *streetmap
* overview-osm-layer
)
2511 (@ *streetmap
* overview-cursor-layer
))
2517 "streetmap-overview")))))))
2518 (mouse-position-control
2519 (new (chain *open-layers
2522 (create div
(chain document
2524 "streetmap-mouse-position"))
2525 empty-string
"longitude, latitude")))))
2527 (new (chain *open-layers
2531 (add-control pan-zoom-panel
))
2532 (chain pan-zoom-panel
2533 (add-controls (array pan-west-control
2539 zoom-to-max-extent-control
)))
2541 (add-control (@ *streetmap
* click-streetmap
)))
2542 (chain *streetmap
* click-streetmap
(activate))
2547 (register "featureselected"
2548 (@ *streetmap
* user-point-layer
)
2549 user-point-selected
))
2553 (register "featureunselected"
2554 (@ *streetmap
* user-point-layer
)
2555 user-point-unselected
))
2557 nearest-aux-points-layer
2559 (register "featureselected"
2560 (@ *streetmap
* nearest-aux-points-layer
)
2561 nearest-aux-point-selected
))
2564 (@ *streetmap
* nearest-aux-points-hover-control
)))
2567 (@ *streetmap
* nearest-aux-points-select-control
)))
2570 (@ *streetmap
* user-points-hover-control
)))
2573 (@ *streetmap
* user-points-select-control
)))
2574 (chain *streetmap
* nearest-aux-points-hover-control
(activate))
2575 (chain *streetmap
* nearest-aux-points-select-control
(activate))
2576 (chain *streetmap
* user-points-hover-control
(activate))
2577 (chain *streetmap
* user-points-select-control
(activate))
2578 (chain *streetmap
* (add-layer (@ *streetmap
* osm-layer
)))
2579 (try (chain *streetmap
*
2580 (add-layer (@ *streetmap
* google-streetmap-layer
)))
2583 (remove-layer (@ *streetmap
*
2584 google-streetmap-layer
)))))
2585 (chain *streetmap
* (add-layer (@ *streetmap
* nirvana-layer
)))
2587 (add-layer (@ *streetmap
* nearest-aux-points-layer
)))
2588 (chain *streetmap
* (add-layer (@ *streetmap
* survey-layer
)))
2590 (add-layer (@ *streetmap
* cursor-layer
)))
2592 (add-layer (@ *streetmap
* aux-point-layer
)))
2594 (add-layer (@ *streetmap
* aux-data-linestring-layer
)))
2596 (add-layer (@ *streetmap
* user-point-layer
)))
2597 (setf (@ overview-map element
)
2598 (chain document
(get-element-by-id
2599 "streetmap-overview-element")))
2600 (chain *streetmap
* (add-control overview-map
))
2601 (chain *streetmap
* (add-control mouse-position-control
))
2602 (chain *streetmap
* (add-control scale-line-control
)))
2604 for i from
0 below
(lisp *number-of-images
*)
2605 do
(initialize-image i
))
2607 (request-restriction-select-choice)
2610 (if (lisp (stored-bbox))
2611 (new (chain *open-layers
2613 (from-string (lisp (stored-bbox)))
2614 (transform +geographic
+ +spherical-mercator
+)))
2615 +presentation-project-bounds
+)))
2616 (let ((stored-cursor (lisp (stored-cursor))))
2619 (new (chain *open-layers
2621 (from-string stored-cursor
)
2622 (transform +geographic
+
2623 +spherical-mercator
+))))))
2624 (reset-layers-and-controls)))))
2626 (pushnew (hunchentoot:create-regex-dispatcher
2627 (format nil
"/phoros/lib/phoros-~A-\\S*-\\S*\.js"
2630 hunchentoot
:*dispatch-table
*)