1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011 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 (when (hunchentoot:session-value
'authenticated-p
)
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 delete their own
45 ones. \"Admin\" may write user points and delete points
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
56 (:p
"Phoros version.")
57 (:p
"In a version string A.B.C, changes in A denote
58 incompatible changes in data (you can't access a database
59 set up by a different version of Phoros); changes in B mean
60 user-visible changes in feature set; changes in C denote
61 bug fixes and minor improvements."))
64 (:p
"Current action."))
65 :multiple-points-phoros-controls
67 (:p
"Try reading the text under mouse pointer."))
70 (:p
"Store user point with its attribute,
71 numeric-description, description, and auxiliary data into
75 (:p
"Delete current point."))
76 :download-user-points-button
78 (:p
"Download all user points as GeoJSON-fomatted text
79 file. Do this regularly if you don't want to lose your
80 work due to server crashes or major Phoros updates.")
81 (:p
"Points saved this way can be fed back into your
82 project using the command line interface (on server or on
83 any other host where the database is reachable)."))
87 (:p
"The standard ones, polygon, polyline, and solitary are
88 rendered as asterisk, square, and triangle
89 respectively. Anything else is rendered as an X."))
92 (:h3
"\"description\"")
93 (:p
"Optional textual description of user point."))
94 :point-numeric-description
96 (:h3
"\"numeric-description\"")
97 (:p
"Optional additional description of user point. It is
98 occasionally used to label representions of this
99 point in streetmap and in images.")
100 (:p
"If parts of it look like numbers, the leftmost such
101 part is automatically incremented during first click into
105 (:p
"Creation date of current user point. Will be updated
106 when you change this point."))
109 (:p
"Check this if the user point being created is to
110 include auxiliary data."))
113 (:p
"Select a set of auxiliary data, either by its distance
114 (in metres) from the current estimated position, or by
115 clicking its representation in streetmap."))
118 (:p
"Auxiliary data connected to this presentation project;
119 all the numeric values followed by all the text values if
123 (:p
"Creator of current user point. Will be updated when
124 you change this point."))
125 :remove-work-layers-button
127 (:p
"Discard the current, unstored user point or unselect
128 any selected user points. Zoom out all images. Keep
129 the rest of the workspace untouched."))
132 (:p
"View some info about Phoros."))
135 (:p
"Finish this session after storing current streetmap
136 zoom status and your cursor position.")
137 (:p
"Fresh login is required to continue."))
140 (:p
"Clicking into the streetmap fetches images which most
141 probably feature the clicked point.")
142 (:p
"TODO: This is not quite so. Currently images taken
143 from points nearest to the clicked one are displayed.")
144 (:p
"To pan the map, drag the mouse. To zoom, spin the
145 mouse wheel, or hold shift down whilst dragging a box, or
146 double-click (shift double-click for larger zoom steps) a
147 point of interest."))
150 (:p
"Clicking into an image sets or resets the active point
151 there. Once a feature is marked by active points in more
152 than one image, the estimated position is calculated.")
153 (:p
"To pan an image, drag the mouse. To zoom, spin the
154 mouse wheel, or hold shift down whilst dragging a box, or
155 double-click (shift double-click for larger zoom steps) a
156 point of interest."))
157 ol-Control-Pan-West-Item-Inactive
159 (:p
"Move viewport left."))
160 ol-Control-Pan-East-Item-Inactive
162 (:p
"Move viewport right."))
163 ol-Control-Pan-North-Item-Inactive
165 (:p
"Move viewport up."))
166 ol-Control-Pan-South-Item-Inactive
168 (:p
"Move viewport down."))
169 ol-Control-Zoom-In-Item-Inactive
172 ol-Control-Zoom-Out-Item-Inactive
175 streetmap-Zoom-To-Max-Extent-Item-Inactive
177 (:p
"Zoom to the extent of presentation project."))
178 ol-Control-Zoom-To-Max-Extent-Item-Inactive
180 (:p
"Zoom out completely, restoring the original view."))
181 :zoom-images-to-max-extent
183 (:p
"Zoom all images out completely, restoring the original
187 (:p
"Check this to automatically zoom into images once they
188 get an estimated position."))
191 (:p
"Check this to snap your current position onto a line
192 along points of auxiliary data, and to keep streetmap
193 centered around current position."))
196 (:p
"Decrease step size. Double-click to decrease harder."))
199 (:p
"Step size in metres. Click to increase; double-click
200 to increase harder."))
203 (:p
"Increase step size. Double-click to increase harder."))
206 (:p
"Move your position by one step on a line along points
207 of auxiliary data. Double-click to change direction."))
208 :image-layer-switcher
210 (:p
"Toggle display of image."))
213 (:p
"No photogrammetric survey possible as there isn't any
214 usable calibration data available for this image."))
217 (:p
"Time this image was taken."))
220 (:p
"Choose a background streetmap."))
223 (:p
"Toggle visibility of data layers."))
226 (:p
"Click to re-center streetmap, or drag the red
228 :streetmap-mouse-position
230 (:p
"Cursor position in geographic coordinates when cursor
234 (:p
"Hints on Phoros' displays and controls are shown here
235 while hovering over the respective elements."))))
237 (defun add-help-topic (topic element
)
238 "Add mouse events to DOM element that initiate display of a
241 (setf (@ element onmouseover
)
243 (lambda () (show-help x
)))
245 (setf (@ element onmouseout
) show-help
)))
247 (defun add-help-events ()
248 "Add mouse events to DOM elements that initiate display of a
251 (topic *help-topics
*)
252 (add-help-topic topic
(chain document
(get-element-by-id topic
)))
253 (dolist (element (chain document
(get-elements-by-class-name topic
)))
254 (add-help-topic topic element
))))
256 (defun show-help (&optional topic
)
257 "Put text on topic into help-display"
258 (setf (inner-html-with-id "help-display")
259 (let ((help-body (getprop *help-topics
* topic
)))
260 (if (undefined help-body
)
264 (defvar *click-control
*
268 (@ *open-layers
*control
)
276 (apply this arguments
))
277 (setf (@ this handler
)
278 (new (chain *open-layers
282 :click
(@ this trigger
)))))))))))
284 (defvar +unix-epoch
+ (lisp *unix-epoch
*)
285 "Seconds between Lisp epoch and UNIX epoch.")
287 (new (chain *open-layers
(*projection
"EPSG:4326"))))
288 (defvar +spherical-mercator
+
289 (new (chain *open-layers
(*projection
"EPSG:900913"))))
291 (defvar +user-name
+ (lisp (hunchentoot:session-value
'user-name
))
292 "User's (short) name.")
293 (defvar +user-role
+ (lisp (string-downcase (hunchentoot:session-value
295 "User's permissions.")
297 (defvar +presentation-project-bbox-text
+
298 (lisp (hunchentoot:session-value
'presentation-project-bbox
)))
300 (defvar +presentation-project-bounds
+
301 (chain (new (chain *open-layers
304 (or +presentation-project-bbox-text
+
305 "-180,-89,180,89"))))
306 (transform +geographic
+ +spherical-mercator
+))
307 "Bounding box of the entire presentation project.")
310 (lisp (hunchentoot:session-value
'aux-data-p
)))
312 (defvar *images
* (array) "Collection of the photos currently shown.")
314 (defvar *streetmap
* undefined
315 "The streetmap shown to the user.")
317 (defvar *point-attributes-select
* undefined
318 "The HTML element for selecting user point attributes.")
320 (defvar *aux-point-distance-select
* undefined
321 "The HTML element for selecting one of a few nearest
324 (defvar *global-position
* undefined
325 "Coordinates of the current estimated position")
327 (defvar *linestring-step-ratio
* 4
328 "Look for auxiliary points to include into linestring within
329 a radius of *linestring-step-ratio* multilied by multiplied by
332 (defvar *current-nearest-aux-point
*
333 (create attributes
(create aux-numeric undefined
335 "Attributes of currently selected point of auxiliary data.")
338 (defvar *bbox-strategy
* (@ *open-layers
*strategy
*bbox
*))
339 (setf (@ *bbox-strategy
* prototype ratio
) 1.5)
340 (setf (@ *bbox-strategy
* prototype res-factor
) 1.5)
342 (defvar *json-parser
* (new (chain *open-layers
*format
*json
*)))
344 (defvar *geojson-format
* (chain *open-layers
*format
*geo-j-s-o-n
))
345 (setf (@ *geojson-format
* prototype ignore-extra-dims
)
346 t
) ;doesn't handle height anyway
347 (setf (@ *geojson-format
* prototype external-projection
)
349 (setf (@ *geojson-format
* prototype internal-projection
)
353 (new (chain *open-layers
356 (create external-projection
+geographic
+
357 internal-projection
+spherical-mercator
+)))))
359 (defvar *http-protocol
* (chain *open-layers
*protocol
*http
*))
360 (setf (chain *http-protocol
* prototype format
) (new *geojson-format
*))
362 (defvar *pristine-images-p
* t
363 "T if none of the current images has been clicked into yet.")
365 (defvar *current-user-point
* undefined
366 "The currently selected user-point.")
368 (defun write-permission-p (&optional
(current-owner +user-name
+))
369 "Nil if current user can't edit stuff created by
370 current-owner or, without arguments, new stuff."
371 (or (equal +user-role
+ "admin")
372 (and (equal +user-role
+ "write")
373 (equal +user-name
+ current-owner
))))
376 "Anything necessary to deal with a photo."
377 (setf (getprop this
'map
)
378 (new ((getprop *open-layers
'*map
)
379 (create projection
+spherical-mercator
+
381 controls
(array (new (chain *open-layers
384 (setf (getprop this
'dummy
) false
) ;TODO why? (omitting splices map components directly into *image)
387 (setf (getprop *image
'prototype
'show-photo
)
389 (setf (getprop *image
'prototype
'draw-epipolar-line
)
391 (setf (getprop *image
'prototype
'draw-active-point
)
393 (setf (getprop *image
'prototype
'draw-estimated-positions
)
394 draw-estimated-positions
)
396 (defun photo-path (photo-parameters)
397 "Create from stuff found in photo-parameters a path for use in
399 (+ "/phoros/lib/photo/" (@ photo-parameters directory
) "/"
400 (@ photo-parameters filename
) "/"
401 (@ photo-parameters byte-position
) ".png"
402 "?mounting-angle=" (@ photo-parameters mounting-angle
)
403 "&bayer-pattern=" (@ photo-parameters bayer-pattern
)
404 "&color-raiser=" (@ photo-parameters color-raiser
)))
406 (defun has-layer-p (map layer-name
)
407 "False if map doesn't have a layer called layer-name."
408 (chain map
(get-layers-by-name layer-name
) length
))
410 (defun some-active-point-p ()
411 "False if no image in *images* has an Active Point."
413 for i across
*images
*
414 sum
(has-layer-p (getprop i
'map
) "Active Point")))
416 (defun remove-layer (map layer-name
)
417 "Destroy layer layer-name in map."
418 (when (has-layer-p map layer-name
)
419 (chain map
(get-layers-by-name layer-name
) 0 (destroy))))
421 (defun remove-any-layers (layer-name)
422 "Destroy in all *images* and in *streetmap* the layer named layer-name."
424 for i across
*images
* do
425 (remove-layer (getprop i
'map
) layer-name
))
426 (remove-layer *streetmap
* layer-name
))
428 (defun reset-controls ()
429 (reveal-element-with-id "real-phoros-controls")
430 (hide-element-with-id "multiple-points-phoros-controls")
431 (disable-element-with-id "finish-point-button")
432 (disable-element-with-id "delete-point-button")
433 (disable-element-with-id "remove-work-layers-button")
434 (setf (inner-html-with-id "h2-controls") "Create Point")
435 (setf (inner-html-with-id "creator") nil
)
436 (setf (inner-html-with-id "point-creation-date") nil
)
437 (hide-aux-data-choice)
438 (setf (inner-html-with-id "aux-numeric-list") nil
)
439 (setf (inner-html-with-id "aux-text-list") nil
))
441 (defun disable-streetmap-nearest-aux-points-layer ()
442 "Get (@ *streetmap* nearest-aux-points-layer) out of the way,
443 I.e., remove features and disable feature select control so it won't
444 shadow any other control."
445 (chain *streetmap
* nearest-aux-points-layer
(remove-all-features))
446 (chain *streetmap
* nearest-aux-points-select-control
(deactivate))
447 (chain *streetmap
* user-points-select-control
(activate)))
449 (defun reset-layers-and-controls ()
450 "Destroy user-generated layers in *streetmap* and in all
451 *images*, and put controls into pristine state."
452 (remove-any-layers "Epipolar Line")
453 (remove-any-layers "Active Point")
454 (remove-any-layers "Estimated Position")
455 (remove-any-layers "User Point")
456 (chain *streetmap
* user-points-select-control
(unselect-all))
457 (disable-streetmap-nearest-aux-points-layer)
458 (when (and (not (equal undefined
*current-user-point
*))
459 (@ *current-user-point
* layer
))
461 user-points-select-control
462 (unselect *current-user-point
*)))
464 (setf *pristine-images-p
* t
)
465 (zoom-images-to-max-extent))
467 (defun enable-element-with-id (id)
468 "Activate HTML element with id=\"id\"."
469 (setf (chain document
(get-element-by-id id
) disabled
) nil
))
471 (defun disable-element-with-id (id)
472 "Grey out HTML element with id=\"id\"."
473 (setf (chain document
(get-element-by-id id
) disabled
) t
))
475 (defun hide-element-with-id (id)
476 "Hide HTML element wit id=\"id\"."
477 (setf (chain document
(get-element-by-id id
) style display
)
480 (defun reveal-element-with-id (id)
481 "Reveal HTML element wit id=\"id\"."
482 (setf (chain document
(get-element-by-id id
) style display
)
485 (defun hide-aux-data-choice ()
486 "Disable selector for auxiliary data."
487 ;;(disable-element-with-id "include-aux-data-p")
488 (hide-element-with-id "include-aux-data")
489 (hide-element-with-id "aux-point-distance")
490 (setf (chain document
491 (get-element-by-id "aux-point-distance")
496 (defun refresh-layer (layer)
497 "Have layer re-request and redraw features."
498 (chain layer
(refresh (create :force t
))))
500 (defun present-photos ()
501 "Handle the response triggered by request-photos-for-point."
502 (let ((photo-parameters
505 photo-request-response response-text
)))))
507 for p across photo-parameters
508 for i across
*images
*
510 (setf (getprop i
'photo-parameters
) p
)
511 ((getprop i
'show-photo
)))))
513 (defun consolidate-combobox (combobox-id)
514 "Help faking a combobox: copy selected option into input."
515 (let ((combobox-select (+ combobox-id
"-select"))
516 (combobox-input (+ combobox-id
"-input")))
517 (setf (value-with-id combobox-input
)
518 (getprop (chain document
519 (get-element-by-id combobox-select
)
522 (get-element-by-id combobox-select
)
526 (get-element-by-id combobox-input
)
529 (defun unselect-combobox-selection (combobox-id)
530 "Help faking a combobox: unset selected option so any
531 selection there will trigger an onchange event."
532 (let ((combobox-select (+ combobox-id
"-select")))
533 (setf (chain document
534 (get-element-by-id combobox-select
)
538 (defun stuff-combobox (combobox-id values
&optional
(selection -
1))
539 "Stuff combobox with values. If selection is a non-negative
540 integer, select the respective item."
541 (let ((combobox-select (+ combobox-id
"-select"))
542 (combobox-input (+ combobox-id
"-input")))
543 (setf (chain document
544 (get-element-by-id combobox-select
)
548 (loop for i in values do
550 (chain document
(create-element "option")))
551 (setf (@ combobox-item text
) i
)
553 (get-element-by-id combobox-select
)
554 (add combobox-item null
)))
555 (setf (chain document
556 (get-element-by-id combobox-select
)
559 (consolidate-combobox combobox-id
)))
561 (defun stuff-user-point-comboboxes (&optional selectp
)
562 "Stuff user point attribute comboboxes with sensible values.
563 If selectp it t, select the most frequently used one."
567 user-point-choice-response response-text
))))
569 (chain response attributes
(map (lambda (x)
572 (chain response descriptions
(map (lambda (x)
573 (@ x description
)))))
574 (best-used-attribute -
1)
575 (best-used-description -
1))
579 for i across
(@ response descriptions
)
581 do
(when (< maximum
(@ i count
))
582 (setf maximum
(@ i count
))
583 (setf best-used-description k
)))
586 for i across
(@ response attributes
)
588 do
(when (< maximum
(@ i count
))
589 (setf maximum
(@ i count
))
590 (setf best-used-attribute k
))))
592 "point-attribute" attributes best-used-attribute
)
594 "point-description" descriptions best-used-description
)))
596 (defun request-user-point-choice (&optional selectp
)
597 "Stuff user point attribute comboboxes with sensible values.
598 If selectp it t, select the most frequently used one."
599 (setf (@ *streetmap
* user-point-choice-response
)
600 ((@ *open-layers
*Request
*POST
*)
601 (create :url
"/phoros/lib/user-point-attributes.json"
603 :headers
(create "Content-type" "text/plain")
605 (stuff-user-point-comboboxes selectp
))))))
607 (defun request-photos-after-click (event)
608 "Handle the response to a click into *streetmap*; fetch photo
609 data. Set or update streetmap cursor."
610 (request-photos (chain *streetmap
*
611 (get-lon-lat-from-pixel (@ event xy
)))))
613 (defun request-photos (lonlat)
614 "Fetch photo data for a point near lonlat. Set or update
616 (setf (@ *streetmap
* clicked-lonlat
) lonlat
)
617 (if (checkbox-status-with-id "walk-p")
618 (request-aux-data-linestring-for-point
619 (@ *streetmap
* clicked-lonlat
))
620 (request-photos-for-point (@ *streetmap
* clicked-lonlat
))))
622 (defun request-aux-data-linestring-for-point (lonlat-spherical-mercator)
623 "Fetch a linestring along auxiyliary points near
624 lonlat-spherical-mercator."
625 (let ((lonlat-geographic
626 (chain lonlat-spherical-mercator
628 (transform +spherical-mercator
+ +geographic
+))))
629 (request-aux-data-linestring (@ lonlat-geographic lon
)
630 (@ lonlat-geographic lat
)
631 (* *linestring-step-ratio
*
633 (step-size-degrees))))
635 (defun request-photos-for-point (lonlat-spherical-mercator)
636 "Fetch photo data near lonlat-spherical-mercator; set or
637 update streetmap cursor."
638 (disable-element-with-id "finish-point-button")
639 (disable-element-with-id "remove-work-layers-button")
640 (remove-any-layers "Estimated Position")
641 (disable-streetmap-nearest-aux-points-layer)
643 (let* ((lonlat-geographic
644 (chain lonlat-spherical-mercator
646 (transform +spherical-mercator
+ +geographic
+)))
650 (create :longitude
(@ lonlat-geographic lon
)
651 :latitude
(@ lonlat-geographic lat
)
652 :zoom
((@ *streetmap
* get-zoom
))
653 :count
(lisp *number-of-images
*))))))
656 (remove-all-features))
660 (new (chain *open-layers
666 (*point
(@ lonlat-spherical-mercator
668 (@ lonlat-spherical-mercator
671 overview-cursor-layer
672 (remove-all-features))
674 overview-cursor-layer
676 (new (chain *open-layers
682 (*point
(@ lonlat-spherical-mercator
684 (@ lonlat-spherical-mercator
686 (setf (@ *streetmap
* photo-request-response
)
687 ((@ *open-layers
*Request
*POST
*)
688 (create :url
"/phoros/lib/local-data"
690 :headers
(create "Content-type" "text/plain"
691 "Content-length" (@ content length
))
692 :success present-photos
)))))
694 (defun draw-epipolar-line ()
695 "Draw an epipolar line from response triggered by clicking
696 into a (first) photo."
697 (enable-element-with-id "remove-work-layers-button")
698 (let* ((epipolar-line
701 (@ this epipolar-request-response response-text
))))
705 (new (chain *open-layers
708 (@ x
:m
) (@ x
:n
))))))))
710 (new (chain *open-layers
716 (*line-string points
))))))))
717 (setf (@ feature render-intent
) "temporary")
718 (chain this epipolar-layer
719 (add-features feature
))))
720 ;; either *line-string or *multi-point are usable
722 (defun request-nearest-aux-points (global-position count
)
723 "Draw into streetmap the count nearest points of auxiliary
725 (let ((global-position-etc global-position
)
727 (setf (@ global-position-etc count
) count
)
728 (setf content
(chain *json-parser
*
729 (write global-position-etc
)))
730 (setf (@ *streetmap
* aux-local-data-request-response
)
731 ((@ *open-layers
*Request
*POST
*)
732 (create :url
"/phoros/lib/aux-local-data"
734 :headers
(create "Content-type" "text/plain"
737 :success draw-nearest-aux-points
)))))
739 (defun request-aux-data-linestring (longitude latitude radius step-size
)
740 "Draw into streetmap a piece of linestring threaded along the
741 nearest points of auxiliary data inside radius."
742 (let* ((payload (create longitude longitude
746 azimuth
(@ *streetmap
*
747 linestring-central-azimuth
)))
748 (content (chain *json-parser
* (write payload
))))
749 (setf (@ *streetmap
* aux-data-linestring-request-response
)
750 ((@ *open-layers
*Request
*POST
*)
751 (create :url
"/phoros/lib/aux-local-linestring.json"
753 :headers
(create "Content-type" "text/plain"
756 :success draw-aux-data-linestring
)))))
758 (defun draw-estimated-positions ()
759 "Draw into streetmap and into all images points at Estimated
760 Position. Estimated Position is the point returned so far from
761 photogrammetric calculations that are triggered by clicking into
762 another photo. Also draw into streetmap the nearest auxiliary points
763 to Estimated Position."
764 (when (write-permission-p)
765 (setf (chain document
766 (get-element-by-id "finish-point-button")
769 (enable-element-with-id "finish-point-button"))
770 (let* ((estimated-positions-request-response
774 'estimated-positions-request-response
777 (aref estimated-positions-request-response
1))
778 (estimated-position-style
779 (create stroke-color
(chain *open-layers
782 style
"temporary" stroke-color
)
785 (setf *global-position
*
786 (aref estimated-positions-request-response
0))
788 (new ((@ *open-layers
*feature
*vector
)
789 ((@ (new ((@ *open-layers
*geometry
*point
)
790 (getprop *global-position
* 'longitude
)
791 (getprop *global-position
* 'latitude
)))
792 transform
) +geographic
+ +spherical-mercator
+)))))
793 (setf (@ feature render-intent
) "temporary")
794 (setf (@ *streetmap
* estimated-position-layer
)
795 (new (chain *open-layers
799 (create display-in-layer-switcher nil
)))))
800 (setf (@ *streetmap
* estimated-position-layer style
)
801 estimated-position-style
)
802 (chain *streetmap
* estimated-position-layer
(add-features feature
))
804 (add-layer (@ *streetmap
* estimated-position-layer
))))
805 (request-nearest-aux-points *global-position
* 7)
808 for p in estimated-positions
810 (when p
;otherwise a photogrammetry error has occured
811 (setf (@ i estimated-position-layer
)
817 (create display-in-layer-switcher nil
)))))
818 (setf (@ i estimated-position-lonlat
)
819 (new (chain *open-layers
(*lon-lat
822 (setf (@ i estimated-position-layer style
)
823 estimated-position-style
)
826 (chain *open-layers
*geometry
(*point
831 (chain *open-layers
*feature
(*vector point
)))))
833 (add-layer (@ i estimated-position-layer
)))
834 (chain i estimated-position-layer
835 (add-features feature
))))))
836 (zoom-anything-to-point)
838 (get-element-by-id "finish-point-button")
841 (defun draw-nearest-aux-points ()
842 "Draw a few auxiliary points into streetmap."
843 (reveal-element-with-id "include-aux-data")
844 (reveal-element-with-id "aux-point-distance")
849 'aux-local-data-request-response
852 (disable-streetmap-nearest-aux-points-layer)
853 (chain *streetmap
* user-points-select-control
(deactivate))
854 (chain *streetmap
* nearest-aux-points-select-control
(activate))
855 (chain *streetmap
* nearest-aux-points-hover-control
(activate))
856 (setf (@ *aux-point-distance-select
* options length
)
866 (*point
(@ i geometry coordinates
0)
867 (@ i geometry coordinates
1))))
868 (transform +geographic
+ +spherical-mercator
+)))
871 (chain *open-layers
*feature
(*vector point
)))))
872 (setf (@ feature attributes
)
874 (setf (@ feature fid
) ;this is supposed to correspond to
875 n
) ; option of *aux-point-distance-select*
877 nearest-aux-points-layer
878 (add-features feature
))
879 (setf aux-point-distance-item
880 (chain document
(create-element "option")))
881 (setf (@ aux-point-distance-item text
)
884 n
;let's hope add-features alway stores features in order of arrival
888 (format (@ i properties distance
) 3 ""))))
889 (chain *aux-point-distance-select
*
890 (add aux-point-distance-item null
))))
892 nearest-aux-points-select-control
895 (elt (@ *streetmap
* nearest-aux-points-layer features
)
897 (enable-element-with-id "aux-point-distance")))
899 (defun draw-aux-data-linestring ()
900 "Draw a piece of linestring along a few auxiliary points into
901 streetmap. Pan streetmap accordingly."
904 aux-data-linestring-request-response
907 (chain *json-parser
* (read data
) linestring
))
909 (chain *json-parser
* (read data
) current-point
))
911 (chain *json-parser
* (read data
) previous-point
))
913 (chain *json-parser
* (read data
) next-point
))
915 (chain *json-parser
* (read data
) azimuth
))
917 (chain *wkt-parser
* (read linestring-wkt
)))
919 (chain *wkt-parser
* (read current-point-wkt
)))
921 (chain *wkt-parser
* (read previous-point-wkt
)))
923 (chain *wkt-parser
* (read next-point-wkt
)))
924 (current-point-lonlat
925 (new (chain *open-layers
926 (*lon-lat
(@ current-point geometry x
)
927 (@ current-point geometry y
))))))
928 (chain *streetmap
* (pan-to current-point-lonlat
))
929 (setf (@ *streetmap
* linestring-central-azimuth
) azimuth
)
930 (request-photos-for-point current-point-lonlat
)
931 (setf (@ *streetmap
* step-back-point
) previous-point
)
932 (setf (@ *streetmap
* step-forward-point
) next-point
)
933 (chain *streetmap
* aux-data-linestring-layer
(remove-all-features))
935 aux-data-linestring-layer
936 (add-features linestring
))))
938 (defun step (&optional back-p
)
939 "Enable walk-mode if necessary, and do a step along
940 aux-data-linestring."
941 (if (checkbox-status-with-id "walk-p")
942 (let ((next-point-geometry
945 (if (< (- (@ *streetmap
* linestring-central-azimuth
) pi
) 0)
946 (setf (@ *streetmap
* linestring-central-azimuth
)
947 (+ (@ *streetmap
* linestring-central-azimuth
) pi
))
948 (setf (@ *streetmap
* linestring-central-azimuth
)
949 (- (@ *streetmap
* linestring-central-azimuth
) pi
)))
954 (transform +spherical-mercator
+ +geographic
+)))
959 (transform +spherical-mercator
+ +geographic
+)))))
960 (request-aux-data-linestring (@ next-point-geometry x
)
961 (@ next-point-geometry y
)
962 (* *linestring-step-ratio
*
964 (step-size-degrees)))
966 (setf (checkbox-status-with-id "walk-p") t
) ;doesn't seem to trigger event
967 (flip-walk-mode)))) ; so we have to do it explicitly
969 (defun step-size-degrees ()
970 "Return inner-html of element step-size (metres)
971 converted into map units (degrees). You should be close to the
973 (/ (inner-html-with-id "step-size") 1855.325 60))
975 (defun decrease-step-size ()
976 (when (> (inner-html-with-id "step-size") 0.5)
977 (setf (inner-html-with-id "step-size")
978 (/ (inner-html-with-id "step-size") 2))))
980 (defun increase-step-size ()
981 (when (< (inner-html-with-id "step-size") 100)
982 (setf (inner-html-with-id "step-size")
983 (* (inner-html-with-id "step-size") 2))))
985 (defun user-point-style-map (label-property)
986 "Create a style map where styles dispatch on feature property
987 \"attribute\" and features are labelled after feature
988 property label-property."
989 (let* ((symbolizer-property "attribute")
991 (new (chain *open-layers
993 (*comparison
(create type
(chain *open-layers
997 property symbolizer-property
998 value
"solitary")))))
1000 (new (chain *open-layers
1002 (*comparison
(create type
(chain *open-layers
1006 property symbolizer-property
1007 value
"polyline")))))
1009 (new (chain *open-layers
1011 (*comparison
(create type
(chain *open-layers
1015 property symbolizer-property
1016 value
"polygon")))))
1018 (new (chain *open-layers
1020 filter solitary-filter
1022 graphic-name
"triangle"))))))
1024 (new (chain *open-layers
1026 filter polyline-filter
1028 graphic-name
"square"
1029 point-radius
4))))))
1031 (new (chain *open-layers
1033 filter polygon-filter
1035 graphic-name
"star"))))))
1037 (new (chain *open-layers
1041 graphic-name
"x"))))))
1042 (user-point-default-style
1045 (*style
(create stroke-color
"OrangeRed"
1046 fill-color
"OrangeRed"
1049 font-color
"OrangeRed"
1050 font-family
"'andale mono', 'lucida console', monospace"
1055 (create rules
(array solitary-rule
1059 (user-point-select-style
1062 (*style
(create stroke-opacity
1
1063 label label-property
)
1064 (create rules
(array solitary-rule
1068 (user-point-temporary-style
1071 (*style
(create fill-opacity
.5)
1072 (create rules
(array solitary-rule
1076 (new (chain *open-layers
1078 (create "default" user-point-default-style
1079 "temporary" user-point-temporary-style
1080 "select" user-point-select-style
))))))
1082 (defun draw-user-points ()
1083 "Draw currently selected user points into all images."
1084 (let* ((user-point-positions-response
1085 (chain *json-parser
*
1087 (getprop *user-point-in-images-response
*
1089 (user-point-collections
1090 (chain user-point-positions-response image-points
))
1092 (chain user-point-positions-response user-point-count
))
1094 (when (> user-point-count
1) "${numericDescription}")))
1097 for user-point-collection in user-point-collections
1099 (when i
;otherwise a photogrammetry error has occured
1103 (@ user-point-collection features
)
1106 (@ raw-feature geometry coordinates
0))
1108 (@ raw-feature geometry coordinates
1))
1110 (new (chain *open-layers
1116 (@ raw-feature properties
))
1118 (new (chain *open-layers
1120 (*vector point attributes
)))))
1121 (setf (@ feature fid
) fid
)
1122 (setf (@ feature render-intent
) "select")
1125 (@ i user-point-layer
)
1126 (new (chain *open-layers
1130 (create display-in-layer-switcher nil
1131 style-map
(user-point-style-map
1133 (chain i map
(add-layer (@ i user-point-layer
)))
1134 (chain i user-point-layer
(add-features features
)))))))
1136 (defun finish-point ()
1137 "Send current *global-position* as a user point to the database."
1138 (let ((global-position-etc *global-position
*))
1139 (setf (@ global-position-etc attribute
)
1140 (value-with-id "point-attribute-input"))
1141 (setf (@ global-position-etc description
)
1142 (value-with-id "point-description-input"))
1143 (setf (@ global-position-etc numeric-description
)
1144 (value-with-id "point-numeric-description"))
1145 (when (checkbox-status-with-id "include-aux-data-p")
1146 (setf (@ global-position-etc aux-numeric
)
1147 (@ *current-nearest-aux-point
*
1150 (setf (@ global-position-etc aux-text
)
1151 (@ *current-nearest-aux-point
*
1155 (chain *json-parser
*
1156 (write global-position-etc
))))
1157 ((@ *open-layers
*Request
*POST
*)
1158 (create :url
"/phoros/lib/store-point"
1160 :headers
(create "Content-type" "text/plain"
1161 "Content-length" (@ content length
))
1164 (@ *streetmap
* user-point-layer
))
1165 (reset-layers-and-controls)
1166 (request-user-point-choice)))))))
1168 (defun increment-numeric-text (text)
1169 "Increment text if it looks like a number, and return it."
1170 (let* ((parts (chain (regex "(\\D*)(\\d*)(.*)") (exec text
)))
1171 (old-number (elt parts
2))
1172 (new-number (1+ (parse-int old-number
10)))))
1173 (if (is-finite new-number
)
1174 (+ (elt parts
1) new-number
(elt parts
3))
1177 (defun update-point ()
1178 "Send changes to currently selected user point to database."
1180 (create user-point-id
(@ *current-user-point
* fid
)
1182 (value-with-id "point-attribute-input")
1184 (value-with-id "point-description-input")
1186 (value-with-id "point-numeric-description")))
1188 (chain *json-parser
*
1189 (write point-data
))))
1190 ((@ *open-layers
*Request
*POST
*)
1191 (create :url
"/phoros/lib/update-point"
1193 :headers
(create "Content-type" "text/plain"
1194 "Content-length" (@ content length
))
1197 (@ *streetmap
* user-point-layer
))
1198 (reset-layers-and-controls)
1199 (request-user-point-choice))))))
1201 (defun delete-point ()
1202 "Purge currently selected user point from database."
1203 (let ((user-point-id (@ *current-user-point
* fid
)))
1205 (chain *json-parser
*
1206 (write user-point-id
)))
1207 ((@ *open-layers
*Request
*POST
*)
1208 (create :url
"/phoros/lib/delete-point"
1210 :headers
(create "Content-type" "text/plain"
1211 "Content-length" (@ content length
))
1214 (@ *streetmap
* user-point-layer
))
1215 (reset-layers-and-controls)
1216 (request-user-point-choice true
))))))
1218 (defun draw-active-point ()
1219 "Draw an Active Point, i.e. a point used in subsequent
1220 photogrammetric calculations."
1221 (chain this active-point-layer
1223 (new ((@ *open-layers
*feature
*vector
)
1224 (new ((@ *open-layers
*geometry
*point
)
1225 (getprop this
'photo-parameters
'm
)
1226 (getprop this
'photo-parameters
'n
))))))))
1228 (defun image-click-action (clicked-image)
1230 "Do appropriate things when an image is clicked into."
1232 ((@ (@ clicked-image map
) get-lon-lat-from-view-port-px
)
1235 (getprop clicked-image
'photo-parameters
))
1236 pristine-image-p content request
)
1237 (when (@ photo-parameters usable
)
1238 (setf (@ photo-parameters m
) (@ lonlat lon
)
1239 (@ photo-parameters n
) (@ lonlat lat
))
1240 (remove-layer (getprop clicked-image
'map
) "Active Point")
1241 (remove-any-layers "Epipolar Line")
1242 (setf *pristine-images-p
* (not (some-active-point-p)))
1243 (setf (@ clicked-image active-point-layer
)
1244 (new (chain *open-layers
1246 (*vector
"Active Point"
1247 (create display-in-layer-switcher
1249 ((@ clicked-image map add-layer
)
1250 (@ clicked-image active-point-layer
))
1251 ((getprop clicked-image
'draw-active-point
))
1255 (chain *streetmap
* user-points-select-control
(unselect-all))
1257 (setf (value-with-id "point-numeric-description")
1258 (increment-numeric-text
1259 (value-with-id "point-numeric-description")))
1260 (remove-any-layers "User Point") ;from images
1262 for i across
*images
* do
1263 (unless (equal i clicked-image
)
1265 (@ i epipolar-layer
)
1266 (new (chain *open-layers
1268 (*vector
"Epipolar Line"
1270 display-in-layer-switcher nil
))))
1271 content
(chain *json-parser
*
1273 (append (array photo-parameters
)
1274 (@ i photo-parameters
))))
1275 (@ i epipolar-request-response
)
1276 ((@ *open-layers
*Request
*POST
*)
1277 (create :url
"/phoros/lib/epipolar-line"
1279 :headers
(create "Content-type" "text/plain"
1282 :success
(getprop i
'draw-epipolar-line
)
1284 ((@ i map add-layer
) (@ i epipolar-layer
)))))
1286 (remove-any-layers "Epipolar Line")
1287 (remove-any-layers "Estimated Position")
1288 (let* ((active-pointed-photo-parameters
1290 for i across
*images
*
1291 when
(has-layer-p (getprop i
'map
) "Active Point")
1292 collect
(getprop i
'photo-parameters
)))
1294 (chain *json-parser
*
1296 (list active-pointed-photo-parameters
1300 x
'photo-parameters
)))))))))
1301 (setf (@ clicked-image estimated-positions-request-response
)
1302 ((@ *open-layers
*Request
*POST
*)
1303 (create :url
"/phoros/lib/estimated-positions"
1305 :headers
(create "Content-type" "text/plain"
1308 :success
(getprop clicked-image
1309 'draw-estimated-positions
)
1310 :scope clicked-image
))))))))))
1312 (defun iso-time-string (lisp-time)
1313 "Return Lisp universal time formatted as ISO time string"
1314 (let* ((unix-time (- lisp-time
+unix-epoch
+))
1315 (js-date (new (*date
(* 1000 unix-time
)))))
1316 (chain *open-layers
*date
(to-i-s-o-string js-date
))))
1318 (defun show-photo ()
1319 "Show the photo described in this object's photo-parameters."
1321 repeat
((getprop this
'map
'get-num-layers
))
1322 do
((getprop this
'map
'layers
0 'destroy
)))
1323 (let ((image-div-width
1324 (parse-int (chain (get-computed-style (@ this map div
) nil
)
1327 (parse-int (chain (get-computed-style (@ this map div
) nil
)
1330 (@ this photo-parameters sensor-width-pix
))
1332 (@ this photo-parameters sensor-height-pix
)))
1333 ((getprop this
'map
'add-layer
)
1339 (photo-path (@ this photo-parameters
))
1340 (new (chain *open-layers
1343 (+ image-width
.5) (+ image-height
.5))))
1344 (new (chain *open-layers
1345 (*size image-div-width
1348 max-resolution
(chain
1350 (max (/ image-width image-div-width
)
1351 (/ image-height image-div-height
))))))))
1352 (chain this map
(zoom-to-max-extent))
1353 (if (@ this photo-parameters usable
)
1354 (hide-element-with-id (@ this usable-id
))
1355 (reveal-element-with-id (@ this usable-id
)))
1356 (setf (@ this trigger-time-div inner-h-t-m-l
)
1357 (iso-time-string (@ this photo-parameters trigger-time
)))))
1359 (defun zoom-images-to-max-extent ()
1360 "Zoom out all images."
1361 (loop for i across
*images
* do
(chain i map
(zoom-to-max-extent))))
1363 (defun zoom-anything-to-point ()
1364 "For streetmap and for images that have an Active Point or an
1365 Estimated Position, zoom in and recenter."
1366 (when (checkbox-status-with-id "zoom-to-point-p")
1368 (new (chain *open-layers
1369 (*lon-lat
(@ *global-position
* longitude
)
1370 (@ *global-position
* latitude
))
1371 (transform +geographic
+ +spherical-mercator
+)))))
1374 (set-center point-lonlat
18 nil t
))))
1375 (loop for i across
*images
* do
1378 ((has-layer-p (@ i map
) "Active Point")
1379 (new (chain *open-layers
(*lon-lat
1380 (@ i photo-parameters m
)
1381 (@ i photo-parameters n
)))))
1382 ((has-layer-p (@ i map
) "Estimated Position")
1383 (@ i estimated-position-lonlat
))
1386 (chain i map
(set-center point-lonlat
4 nil t
)))))))
1388 (defun initialize-image (image-index)
1389 "Create an image usable for displaying photos at position
1390 image-index in array *images*."
1391 (setf (aref *images
* image-index
) (new *image
))
1392 (setf (@ (aref *images
* image-index
) usable-id
)
1393 (+ "image-" image-index
"-usable"))
1394 (hide-element-with-id (+ "image-" image-index
"-usable"))
1395 (setf (@ (aref *images
* image-index
) trigger-time-div
)
1398 (get-element-by-id (+ "image-" image-index
"-trigger-time"))))
1399 (setf (@ (aref *images
* image-index
) image-click-action
)
1400 (image-click-action (aref *images
* image-index
)))
1401 (setf (@ (aref *images
* image-index
) click
)
1402 (new (*click-control
*
1403 (create :trigger
(@ (aref *images
* image-index
)
1404 image-click-action
)))))
1405 (chain (aref *images
* image-index
)
1408 (@ (aref *images
* image-index
) click
)))
1409 (chain (aref *images
* image-index
) click
(activate))
1410 ;;(chain (aref *images* image-index)
1413 ;; (new (chain *open-layers
1419 ;; (get-element-by-id
1420 ;; (+ "image-" image-index "-zoom")))))))))
1421 (chain (aref *images
* image-index
)
1424 (new (chain *open-layers
1431 (+ "image-" image-index
"-layer-switcher")))
1432 rounded-corner nil
))))))
1433 (let ((pan-west-control
1434 (new (chain *open-layers
*control
(*pan
"West"))))
1436 (new (chain *open-layers
*control
(*pan
"North"))))
1438 (new (chain *open-layers
*control
(*pan
"South"))))
1440 (new (chain *open-layers
*control
(*pan
"East"))))
1442 (new (chain *open-layers
*control
(*zoom-in
))))
1444 (new (chain *open-layers
*control
(*zoom-out
))))
1445 (zoom-to-max-extent-control
1446 (new (chain *open-layers
*control
(*zoom-to-max-extent
))))
1448 (new (chain *open-layers
1455 (+ "image-" image-index
"-zoom")))))))))
1456 (chain (aref *images
* image-index
)
1458 (add-control pan-zoom-panel
))
1459 (chain pan-zoom-panel
1460 (add-controls (array pan-west-control
1466 zoom-to-max-extent-control
))))
1467 (chain (aref *images
* image-index
)
1469 (render (chain document
1471 (+ "image-" image-index
))))))
1473 (defun user-point-selected (event)
1474 "Things to do once a user point is selected."
1475 (remove-any-layers "Active Point")
1476 (remove-any-layers "Epipolar Line")
1477 (remove-any-layers "Estimated Position")
1478 (unselect-combobox-selection "point-attribute")
1479 (unselect-combobox-selection "point-description")
1480 (user-point-selection-changed))
1482 (defun user-point-unselected (event)
1483 "Things to do once a user point is unselected."
1485 (user-point-selection-changed))
1487 (defun user-point-selection-changed ()
1488 "Things to do once a user point is selected or unselected."
1489 (hide-aux-data-choice)
1490 (setf *current-user-point
*
1491 (@ *streetmap
* user-point-layer selected-features
0))
1492 (let ((selected-features-count
1493 (@ *streetmap
* user-point-layer selected-features length
)))
1494 (setf (@ *streetmap
* user-point-layer style-map
)
1495 (user-point-style-map
1496 (when (> selected-features-count
1)
1497 "${numericDescription}")))
1499 ((> selected-features-count
1)
1500 (hide-element-with-id "real-phoros-controls")
1501 (reveal-element-with-id "multiple-points-phoros-controls"))
1502 ((= selected-features-count
1)
1503 (setf (value-with-id "point-attribute-input")
1504 (@ *current-user-point
* attributes attribute
))
1505 (setf (value-with-id "point-description-input")
1506 (@ *current-user-point
* attributes description
))
1507 (setf (value-with-id "point-numeric-description")
1508 (@ *current-user-point
* attributes numeric-description
))
1509 (setf (inner-html-with-id "point-creation-date")
1510 (@ *current-user-point
* attributes creation-date
))
1511 (setf (inner-html-with-id "aux-numeric-list")
1513 (@ *current-user-point
* attributes aux-numeric
)))
1514 (setf (inner-html-with-id "aux-text-list")
1516 (@ *current-user-point
* attributes aux-text
)))
1517 (if (write-permission-p
1518 (@ *current-user-point
* attributes user-name
))
1520 (setf (chain document
1521 (get-element-by-id "finish-point-button")
1524 (enable-element-with-id "finish-point-button")
1525 (enable-element-with-id "delete-point-button")
1526 (setf (inner-html-with-id "h2-controls") "Edit Point"))
1528 (disable-element-with-id "finish-point-button")
1529 (disable-element-with-id "delete-point-button")
1530 (setf (inner-html-with-id "h2-controls") "View Point")))
1531 (setf (inner-html-with-id "creator")
1533 (@ *current-user-point
* attributes user-name
)
1536 (hide-element-with-id "multiple-points-phoros-controls")
1537 (reveal-element-with-id "real-phoros-controls"))))
1538 (chain *streetmap
* user-point-layer
(redraw))
1539 (remove-any-layers "User Point") ;from images
1541 (chain *json-parser
*
1543 (array (chain *streetmap
*
1546 (map (lambda (x) (@ x fid
))))
1548 for i across
*images
*
1549 collect
(@ i photo-parameters
))))))
1550 (setf *user-point-in-images-response
*
1551 ((@ *open-layers
*Request
*POST
*)
1552 (create :url
"/phoros/lib/user-point-positions"
1554 :headers
(create "Content-type" "text/plain"
1555 "Content-length" (@ content length
))
1556 :success draw-user-points
))))
1558 (defun aux-point-distance-selected ()
1559 "Things to do on change of aux-point-distance select element."
1561 nearest-aux-points-select-control
1564 nearest-aux-points-select-control
1567 (elt (@ *streetmap
* nearest-aux-points-layer features
)
1568 (@ *aux-point-distance-select
*
1570 selected-index
))))))
1572 (defun enable-aux-point-selection ()
1573 "Check checkbox include-aux-data-p and act accordingly."
1574 (setf (checkbox-status-with-id "include-aux-data-p") t
)
1575 (flip-aux-data-inclusion))
1577 (defun flip-walk-mode ()
1578 "Query status of checkbox walk-p and induce first walking
1579 step if it's just been turned on. Otherwise delete our
1581 (if (checkbox-status-with-id "walk-p")
1582 (request-aux-data-linestring-for-point (@ *streetmap
*
1585 aux-data-linestring-layer
1586 (remove-all-features))))
1588 (defun flip-aux-data-inclusion ()
1589 "Query status of checkbox include-aux-data-p and act
1591 (if (checkbox-status-with-id "include-aux-data-p")
1593 nearest-aux-points-layer
1596 nearest-aux-points-layer
1597 (set-visibility nil
))))
1599 (defun html-ordered-list (aux-data)
1600 "Return a html-formatted list from aux-data."
1603 (:ol
:class
"aux-data-list"
1605 (reduce (lambda (x y
)
1606 (+ x
(who-ps-html (:li y
))))
1610 (defun nearest-aux-point-selected (event)
1611 "Things to do once a nearest auxiliary point is selected in streetmap."
1612 (setf *current-nearest-aux-point
* (@ event feature
))
1614 (@ event feature attributes aux-numeric
))
1616 (@ event feature attributes aux-text
))
1618 (@ event feature attributes distance
)))
1619 (setf (@ *aux-point-distance-select
* options selected-index
)
1620 (@ event feature fid
))
1621 (setf (inner-html-with-id "aux-numeric-list")
1622 (html-ordered-list aux-numeric
))
1623 (setf (inner-html-with-id "aux-text-list")
1624 (html-ordered-list aux-text
))))
1627 "Store user's current map extent and log out."
1628 (let* ((bbox (chain *streetmap
*
1630 (transform +spherical-mercator
+ +geographic
+)
1632 (href (+ "/phoros/lib/logout?bbox=" bbox
)))
1633 (when (@ *streetmap
* cursor-layer features length
)
1634 (let* ((lonlat-geographic (chain *streetmap
*
1640 (transform +spherical-mercator
+
1643 "&longitude=" (@ lonlat-geographic x
)
1644 "&latitude=" (@ lonlat-geographic y
)))))
1645 (setf (@ location href
) href
)))
1648 "Prepare user's playground."
1649 (unless +presentation-project-bbox-text
+
1650 (setf (inner-html-with-id "presentation-project-emptiness")
1656 (create projection
+geographic
+
1657 display-projection
+geographic
+
1658 controls
(array (new (chain *open-layers
1661 (new (chain *open-layers
1663 (*attribution
)))))))))
1664 (unless +aux-data-p
+
1665 (disable-element-with-id "walk-p")
1666 (hide-element-with-id "decrease-step-size")
1667 (hide-element-with-id "step-size")
1668 (hide-element-with-id "increase-step-size")
1669 (hide-element-with-id "step-button"))
1670 (when (write-permission-p)
1671 (enable-element-with-id "point-attribute-input")
1672 (enable-element-with-id "point-attribute-select")
1673 (enable-element-with-id "point-description-input")
1674 (enable-element-with-id "point-description-select")
1675 (enable-element-with-id "point-numeric-description")
1676 (request-user-point-choice true
))
1677 (setf (inner-html-with-id "h2-controls") "Create Point")
1678 (hide-element-with-id "multiple-points-phoros-controls")
1679 (setf *point-attributes-select
*
1680 (chain document
(get-element-by-id "point-attribute-select")))
1681 (setf *aux-point-distance-select
*
1682 (chain document
(get-element-by-id "aux-point-distance")))
1683 (hide-aux-data-choice)
1684 (let ((cursor-layer-style
1687 external-graphic
"/phoros/lib/public_html/phoros-cursor.png")))
1688 (setf (@ *streetmap
* cursor-layer
)
1694 style cursor-layer-style
)))))
1695 (setf (@ *streetmap
* overview-cursor-layer
)
1701 style cursor-layer-style
))))))
1702 (let ((survey-layer-style
1703 (create stroke-color
(chain *open-layers
*feature
*vector
1704 style
"default" stroke-color
)
1708 graphic-name
"circle")))
1709 (setf (@ *streetmap
* survey-layer
)
1715 strategies
(array (new (*bbox-strategy
*)))
1717 (new (*http-protocol
*
1718 (create :url
"/phoros/lib/points.json")))
1719 style survey-layer-style
))))))
1720 (setf (@ *streetmap
* user-point-layer
)
1726 strategies
(array (new *bbox-strategy
*))
1728 (new (*http-protocol
*
1729 (create :url
"/phoros/lib/user-points.json")))
1730 style-map
(user-point-style-map nil
))))))
1731 (setf (@ *streetmap
* user-points-hover-control
)
1732 (new (chain *open-layers
1734 (*select-feature
(@ *streetmap
* user-point-layer
)
1735 (create render-intent
"temporary"
1737 highlight-only t
)))))
1738 (setf (@ *streetmap
* user-points-select-control
)
1739 (new (chain *open-layers
1741 (*select-feature
(@ *streetmap
* user-point-layer
)
1744 (let ((aux-layer-style
1745 (create stroke-color
"grey"
1749 graphic-name
"circle")))
1750 (setf (@ *streetmap
* aux-point-layer
)
1756 strategies
(array (new (*bbox-strategy
*)))
1758 (new (*http-protocol
*
1759 (create :url
"/phoros/lib/aux-points.json")))
1760 style aux-layer-style
1761 visibility nil
))))))
1762 (let ((nearest-aux-point-layer-style-map
1763 (new (chain *open-layers
1766 (create stroke-color
"grey"
1770 graphic-name
"circle")
1772 (create stroke-color
"black"
1776 graphic-name
"circle")
1778 (create stroke-color
"grey"
1783 graphic-name
"circle")))))))
1784 (setf (@ *streetmap
* nearest-aux-points-layer
)
1785 (new (chain *open-layers
1788 "Nearest Aux Points"
1790 display-in-layer-switcher nil
1791 style-map nearest-aux-point-layer-style-map
1793 (setf (@ *streetmap
* nearest-aux-points-hover-control
)
1794 (new (chain *open-layers
1797 (@ *streetmap
* nearest-aux-points-layer
)
1798 (create render-intent
"temporary"
1800 highlight-only t
)))))
1801 (setf (@ *streetmap
* nearest-aux-points-select-control
)
1802 (new (chain *open-layers
1805 (@ *streetmap
* nearest-aux-points-layer
)))))
1806 (setf (@ *streetmap
* aux-data-linestring-layer
)
1807 (new (chain *open-layers
1810 "Aux Data Linestring"
1812 display-in-layer-switcher nil
1813 style-map nearest-aux-point-layer-style-map
1815 (setf (@ *streetmap
* google-streetmap-layer
)
1816 (new (chain *open-layers
1818 (*google
"Google Streets"
1819 (create num-zoom-levels
23)))))
1820 (setf (@ *streetmap
* osm-layer
)
1821 (new (chain *open-layers
1826 (create num-zoom-levels
23
1828 "Data CC-By-SA by openstreetmap.org")))))
1829 (setf (@ *streetmap
* overview-osm-layer
)
1830 (new (chain *open-layers
1832 (*osm
* "OpenStreetMap"))))
1833 (setf (@ *streetmap
* click-streetmap
)
1834 (new (*click-control
*
1835 (create :trigger request-photos-after-click
))))
1836 (setf (@ *streetmap
* nirvana-layer
)
1841 (create is-base-layer t
1842 projection
(@ *streetmap
* osm-layer projection
)
1843 max-extent
(@ *streetmap
* osm-layer max-extent
)
1844 max-resolution
(@ *streetmap
*
1847 units
(@ *streetmap
* osm-layer units
)
1848 num-zoom-levels
(@ *streetmap
*
1850 num-zoom-levels
))))))
1853 (new (chain *open-layers
1860 "streetmap-layer-switcher"))
1861 rounded-corner nil
))))))
1862 (let ((pan-west-control
1863 (new (chain *open-layers
*control
(*pan
"West"))))
1865 (new (chain *open-layers
*control
(*pan
"North"))))
1867 (new (chain *open-layers
*control
(*pan
"South"))))
1869 (new (chain *open-layers
*control
(*pan
"East"))))
1871 (new (chain *open-layers
*control
(*zoom-in
))))
1873 (new (chain *open-layers
*control
(*zoom-out
))))
1874 (zoom-to-max-extent-control
1880 display-class
"streetmapZoomToMaxExtent"
1884 +presentation-project-bounds
+ ))))))))
1886 (new (chain *open-layers
1893 "streetmap-zoom")))))))
1895 (new (chain *open-layers
1901 (@ *streetmap
* overview-osm-layer
)
1902 (@ *streetmap
* overview-cursor-layer
))
1908 "streetmap-overview")))))))
1909 (mouse-position-control
1910 (new (chain *open-layers
1913 (create div
(chain document
1915 "streetmap-mouse-position"))
1916 empty-string
"longitude, latitude")))))
1918 (new (chain *open-layers
1922 (add-control pan-zoom-panel
))
1923 (chain pan-zoom-panel
1924 (add-controls (array pan-west-control
1930 zoom-to-max-extent-control
)))
1932 (add-control (@ *streetmap
* click-streetmap
)))
1933 (chain *streetmap
* click-streetmap
(activate))
1938 (register "featureselected"
1939 (@ *streetmap
* user-point-layer
)
1940 user-point-selected
))
1944 (register "featureunselected"
1945 (@ *streetmap
* user-point-layer
)
1946 user-point-unselected
))
1948 nearest-aux-points-layer
1950 (register "featureselected"
1951 (@ *streetmap
* nearest-aux-points-layer
)
1952 nearest-aux-point-selected
))
1955 (@ *streetmap
* nearest-aux-points-hover-control
)))
1958 (@ *streetmap
* nearest-aux-points-select-control
)))
1961 (@ *streetmap
* user-points-hover-control
)))
1964 (@ *streetmap
* user-points-select-control
)))
1965 (chain *streetmap
* user-points-hover-control
(activate))
1966 (chain *streetmap
* user-points-select-control
(activate))
1967 (chain *streetmap
* nearest-aux-points-hover-control
(activate))
1968 (chain *streetmap
* nearest-aux-points-select-control
(activate))
1969 (chain *streetmap
* (add-layer (@ *streetmap
* osm-layer
)))
1970 (try (chain *streetmap
*
1971 (add-layer (@ *streetmap
* google-streetmap-layer
)))
1974 (remove-layer (@ *streetmap
*
1975 google-streetmap-layer
)))))
1976 (chain *streetmap
* (add-layer (@ *streetmap
* nirvana-layer
)))
1978 (add-layer (@ *streetmap
* nearest-aux-points-layer
)))
1979 (chain *streetmap
* (add-layer (@ *streetmap
* survey-layer
)))
1981 (add-layer (@ *streetmap
* cursor-layer
)))
1983 (add-layer (@ *streetmap
* aux-point-layer
)))
1985 (add-layer (@ *streetmap
* aux-data-linestring-layer
)))
1987 (add-layer (@ *streetmap
* user-point-layer
)))
1988 (setf (@ overview-map element
)
1989 (chain document
(get-element-by-id
1990 "streetmap-overview-element")))
1991 (chain *streetmap
* (add-control overview-map
))
1992 (chain *streetmap
* (add-control mouse-position-control
))
1993 (chain *streetmap
* (add-control scale-line-control
)))
1995 for i from
0 to
(lisp (1- *number-of-images
*))
1996 do
(initialize-image i
))
2000 (if (lisp (stored-bbox))
2001 (new (chain *open-layers
2003 (from-string (lisp (stored-bbox)))
2004 (transform +geographic
+ +spherical-mercator
+)))
2005 +presentation-project-bounds
+)))
2006 (let ((stored-cursor (lisp (stored-cursor))))
2009 (new (chain *open-layers
2011 (from-string stored-cursor
)
2012 (transform +geographic
+
2013 +spherical-mercator
+)))))))))))
2015 (pushnew (hunchentoot:create-regex-dispatcher
2016 (format nil
"/phoros/lib/phoros-~A-\\S*-\\S*\.js"
2019 hunchentoot
:*dispatch-table
*)