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 (define-easy-handler (phoros.js
:uri
"/phoros-lib/phoros.js") ()
21 "Serve some Javascript."
22 (when (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."))
52 (:p
"Current action."))
53 :multiple-points-phoros-controls
55 (:p
"Try reading the text under mouse pointer."))
58 (:p
"Store point with its attribute, description and
59 numeric description into database. Afterwards, increment
60 the numeric description if possible."))
63 (:p
"Delete current point."))
64 :download-user-points-button
66 (:p
"Download all user points as GeoJSON-fomatted text file."))
69 (:p
"One of a few possible user point attributes.")
70 (:p
"TODO: currently only the hard-coded ones are available."))
73 (:p
"Optional verbal description of user point."))
74 :point-numeric-description
76 (:p
"Optional additional description of user point. If
77 parts of it looks like a number, the leftmost such part is
78 automatically incremented during click into first image."))
81 (:p
"Creation date of current user point. Will be updated
82 when you change this point."))
85 (:p
"Check this if the user point being created should
86 include auxiliary data."))
89 (:p
"Select a set of auxiliary data, either by its distance
90 from the current estimated position, or by clicking its
91 representation in streetmap.")
92 (:p
"TODO: This is not a decent length unit."))
95 (:p
"Auxiliary data connected to this presentation project;
96 all the numeric values followed by all the text values if
100 (:p
"Creator of current user point. Will be updated when
101 you change this point."))
102 :remove-work-layers-button
104 (:p
"Discard the current, unstored user point or unselect
105 currently selected user points. Zoom out all images. Keep
106 the rest of the workspace untouched."))
109 (:p
"View some info about Phoros."))
112 (:p
"Finish this session. Fresh login is required to
116 (:p
"Clicking into the streetmap fetches images which most
117 probably feature the clicked point.")
118 (:p
"TODO: This is not quite so. Currently images taken
119 from points nearest to the clicked one are displayed.")
120 (:p
"To pan the map, drag the mouse. To zoom, spin the
121 mouse wheel, or hold shift down whilst dragging a box, or
122 double-click (shift double-click for larger zoom steps) a
123 point of interest."))
126 (:p
"Clicking into an image sets or resets the active point
127 there. Once a feature is marked by active points in more
128 than one image, the estimated position is calculated.")
129 (:p
"To pan an image, drag the mouse. To zoom, spin the
130 mouse wheel, or hold shift down whilst dragging a box, or
131 double-click (shift double-click for larger zoom steps) a
132 point of interest."))
133 ol-Control-Pan-West-Item-Inactive
135 (:p
"Move viewport left."))
136 ol-Control-Pan-East-Item-Inactive
138 (:p
"Move viewport right."))
139 ol-Control-Pan-North-Item-Inactive
141 (:p
"Move viewport up."))
142 ol-Control-Pan-South-Item-Inactive
144 (:p
"Move viewport down."))
145 ol-Control-Zoom-In-Item-Inactive
148 ol-Control-Zoom-Out-Item-Inactive
151 streetmap-Zoom-To-Max-Extent-Item-Inactive
153 (:p
"Zoom to the extent of presentation project."))
154 ol-Control-Zoom-To-Max-Extent-Item-Inactive
156 (:p
"Zoom out completely, restoring the original view."))
157 :zoom-images-to-max-extent
159 (:p
"Zoom all images out completely, restoring the original
163 (:p
"Check this to automatically zoom into images once they
164 get an estimated position."))
165 :image-layer-switcher
167 (:p
"Toggle display of image."))
170 (:p
"Time this image was taken."))
173 (:p
"Choose a background streetmap."))
176 (:p
"Toggle visibility of data layers."))
179 (:p
"Click to re-center streetmap, or drag the red rectangle."))
180 :streetmap-mouse-position
182 (:p
"Cursor position in geographic coordinates when cursor
186 (:p
"Hints on Phoros' displays and controls are shown here
187 while hovering over the respective elements."))))
189 (defun add-help-topic (topic element
)
190 "Add mouse events to DOM element that initiate display of a
193 (setf (@ element onmouseover
)
195 (lambda () (show-help x
)))
197 (setf (@ element onmouseout
) show-help
)))
199 (defun add-help-events ()
200 "Add mouse events to DOM elements that initiate display of a
203 (topic *help-topics
*)
204 (add-help-topic topic
(chain document
(get-element-by-id topic
)))
205 (dolist (element (chain document
(get-elements-by-class-name topic
)))
206 (add-help-topic topic element
))))
208 (defun show-help (&optional topic
)
209 "Put text on topic into help-display"
210 (setf (inner-html-with-id "help-display")
211 (let ((help-body (getprop *help-topics
* topic
)))
212 (if (undefined help-body
)
216 (defvar *click-control
*
220 (@ *open-layers
*control
)
222 :default-handler-options
231 (@ this handler-options
)
236 (@ this default-handler-options
))))
241 (apply this arguments
))
242 (setf (@ this handler
)
243 (new (chain *open-layers
247 :click
(@ this trigger
))
248 (@ this handler-options
))))))))))
250 (defvar +unix-epoch
+ (lisp *unix-epoch
*)
251 "Seconds between Lisp epoch and UNIX epoch.")
253 (new (chain *open-layers
(*projection
"EPSG:4326"))))
254 (defvar +spherical-mercator
+
255 (new (chain *open-layers
(*projection
"EPSG:900913"))))
257 (defvar +user-name
+ (lisp (session-value 'user-name
))
258 "User's (short) name")
259 (defvar +user-role
+ (lisp (string-downcase (session-value 'user-role
)))
260 "User's permissions")
262 (defvar +presentation-project-bounds
+
263 (chain (new (chain *open-layers
266 (lisp (session-value 'presentation-project-bbox
)))))
267 (transform +geographic
+ +spherical-mercator
+))
268 "Bounding box of the entire presentation project.")
270 (defvar *images
* (array) "Collection of the photos currently shown.")
272 (defvar *streetmap
* undefined
273 "The streetmap shown to the user.")
275 (defvar *streetmap-estimated-position-layer
*)
277 (defvar *point-attributes-select
* undefined
278 "The HTML element for selecting user point attributes.")
280 (defvar *aux-point-distance-select
* undefined
281 "The HTML element for selecting one of a few nearest auxiliary points.")
283 (defvar *global-position
* undefined
284 "Coordinates of the current estimated position")
286 (defvar *current-nearest-aux-point
*
287 (create attributes
(create aux-numeric undefined
289 "Attributes of currently selected point of auxiliary data.")
292 (defvar *bbox-strategy
* (chain *open-layers
*strategy
*bbox
*))
293 (setf (chain *bbox-strategy
* prototype ratio
) 1.5)
294 (setf (chain *bbox-strategy
* prototype res-factor
) 1.5)
296 (defvar *json-parser
* (new (chain *open-layers
*format
*json
*)))
298 (defvar *geojson-format
* (chain *open-layers
*format
*geo-j-s-o-n
))
299 (setf (chain *geojson-format
* prototype ignore-extra-dims
)
300 t
) ;doesn't handle height anyway
301 (setf (chain *geojson-format
* prototype external-projection
)
303 (setf (chain *geojson-format
* prototype internal-projection
)
306 (defvar *http-protocol
* (chain *open-layers
*protocol
*http
*))
307 (setf (chain *http-protocol
* prototype format
) (new *geojson-format
*))
309 (defvar *survey-layer
*
310 (let ((survey-layer-style
311 (create stroke-color
(chain *open-layers
*feature
*vector
312 style
"default" stroke-color
)
316 graphic-name
"circle")))
322 strategies
(array (new (*bbox-strategy
*)))
324 (new (*http-protocol
*
325 (create :url
"/phoros-lib/points.json")))
326 style survey-layer-style
329 (defvar *user-point-layer
*
335 strategies
(array (new *bbox-strategy
*))
337 (new (*http-protocol
*
338 (create :url
"/phoros-lib/user-points.json")))
339 style-map
(user-point-style-map nil
))))))
341 (defvar *aux-point-layer
*
342 (let ((aux-layer-style
343 (create stroke-color
"grey"
347 graphic-name
"circle")))
353 strategies
(array (new (*bbox-strategy
*)))
355 (new (*http-protocol
*
356 (create :url
"/phoros-lib/aux-points.json")))
357 style aux-layer-style
360 (defvar *streetmap-nearest-aux-points-layer
*
361 (let ((nearest-aux-point-layer-style-map
362 (new (chain *open-layers
365 (create stroke-color
"grey"
369 graphic-name
"circle")
371 (create stroke-color
"black"
375 graphic-name
"circle")
377 (create stroke-color
"grey"
382 graphic-name
"circle")))))))
383 (new (chain *open-layers
385 (*vector
"Nearest Aux Points"
387 display-in-layer-switcher nil
388 style-map nearest-aux-point-layer-style-map
391 (defvar *nearest-aux-points-hover-control
*
392 (new (chain *open-layers
394 (*select-feature
*streetmap-nearest-aux-points-layer
*
395 (create render-intent
"temporary"
397 highlight-only t
)))))
399 (defvar *nearest-aux-points-select-control
*
400 (new (chain *open-layers
402 (*select-feature
*streetmap-nearest-aux-points-layer
*))))
404 (defvar *pristine-images-p
* t
405 "T if none of the current images has been clicked into yet.")
407 (defvar *current-user-point
* undefined
408 "The currently selected user-point.")
410 (defvar *user-points-hover-control
*
411 (new (chain *open-layers
413 (*select-feature
*user-point-layer
*
414 (create render-intent
"temporary"
416 highlight-only t
)))))
418 (defvar *user-points-select-control
*
419 (new (chain *open-layers
421 (*select-feature
*user-point-layer
*
425 (defvar *google-streetmap-layer
*
426 (new (chain *open-layers
428 (*google
"Google Streets"
429 (create num-zoom-levels
22)))))
432 (new (chain *open-layers
434 (*osm
* "OpenStreetMap"
435 nil
(create num-zoom-levels
19)))))
437 (defvar *click-streetmap
*
438 (new (*click-control
* (create :trigger request-photos
))))
440 (defun write-permission-p (&optional
(current-owner +user-name
+))
441 "Nil if current user can't edit stuff created by
442 current-owner or, without arguments, new stuff."
443 (or (== +user-role
+ "admin")
444 (and (== +user-role
+ "write")
445 (== +user-name
+ current-owner
))))
448 "Anything necessary to deal with a photo."
449 (setf (getprop this
'map
)
450 (new ((getprop *open-layers
'*map
)
451 (create projection
+spherical-mercator
+
453 controls
(array (new (chain *open-layers
456 (setf (getprop this
'dummy
) false
) ;TODO why? (omitting splices map components directly into *image)
459 (setf (getprop *image
'prototype
'show-photo
)
461 (setf (getprop *image
'prototype
'draw-epipolar-line
)
463 (setf (getprop *image
'prototype
'draw-active-point
)
465 (setf (getprop *image
'prototype
'draw-estimated-positions
)
466 draw-estimated-positions
)
468 (defun photo-path (photo-parameters)
469 "Create from stuff found in photo-parameters a path for use in
471 (+ "/phoros-lib/photo/" (@ photo-parameters directory
) "/"
472 (@ photo-parameters filename
) "/"
473 (@ photo-parameters byte-position
) ".png"))
475 (defun has-layer-p (map layer-name
)
476 "False if map doesn't have a layer called layer-name."
477 (chain map
(get-layers-by-name layer-name
) length
))
479 (defun some-active-point-p ()
480 "False if no image in *images* has an Active Point."
482 for i across
*images
*
483 sum
(has-layer-p (getprop i
'map
) "Active Point")))
485 (defun remove-layer (map layer-name
)
486 "Destroy layer layer-name in map."
487 (when (has-layer-p map layer-name
)
488 (chain map
(get-layers-by-name layer-name
) 0 (destroy))))
490 (defun remove-any-layers (layer-name)
491 "Destroy in all *images* and in *streetmap* the layer named layer-name."
493 for i across
*images
* do
494 (remove-layer (getprop i
'map
) layer-name
))
495 (remove-layer *streetmap
* layer-name
))
497 (defun reset-controls ()
498 (reveal-element-with-id "real-phoros-controls")
499 (hide-element-with-id "multiple-points-phoros-controls")
500 (disable-element-with-id "finish-point-button")
501 (disable-element-with-id "delete-point-button")
502 (disable-element-with-id "remove-work-layers-button")
503 (setf (inner-html-with-id "h2-controls") "Create Point")
504 (setf (inner-html-with-id "creator") nil
)
505 (setf (inner-html-with-id "point-creation-date") nil
)
506 (hide-aux-data-choice)
507 (setf (inner-html-with-id "aux-numeric-list") nil
)
508 (setf (inner-html-with-id "aux-text-list") nil
))
510 (defun disable-streetmap-nearest-aux-points-layer ()
511 "Get *streetmap-nearest-aux-points-layer* out of the way,
512 I.e., remove features and disable feature select control so it won't
513 shadow any other control."
514 (chain *streetmap-nearest-aux-points-layer
* (remove-all-features))
515 (chain *nearest-aux-points-select-control
* (deactivate))
516 (chain *user-points-select-control
* (activate)))
518 (defun reset-layers-and-controls ()
519 "Destroy user-generated layers in *streetmap* and in all
520 *images*, and put controls into pristine state."
521 (remove-any-layers "Epipolar Line")
522 (remove-any-layers "Active Point")
523 (remove-any-layers "Estimated Position")
524 (remove-any-layers "User Point")
525 (chain *user-points-select-control
* (unselect-all))
526 (disable-streetmap-nearest-aux-points-layer)
527 (when (and (!= undefined
*current-user-point
*)
528 (chain *current-user-point
* layer
))
529 (chain *user-points-select-control
*
530 (unselect *current-user-point
*)))
532 (setf *pristine-images-p
* t
)
533 (zoom-images-to-max-extent))
535 (defun enable-element-with-id (id)
536 "Activate HTML element with id=\"id\"."
537 (setf (chain document
(get-element-by-id id
) disabled
) nil
))
539 (defun disable-element-with-id (id)
540 "Grey out HTML element with id=\"id\"."
541 (setf (chain document
(get-element-by-id id
) disabled
) t
))
543 (defun hide-element-with-id (id)
544 "Hide HTML element wit id=\"id\"."
545 (setf (chain document
(get-element-by-id id
) style display
)
548 (defun reveal-element-with-id (id)
549 "Reveal HTML element wit id=\"id\"."
550 (setf (chain document
(get-element-by-id id
) style display
)
553 (defun hide-aux-data-choice ()
554 "Disable selector for auxiliary data."
555 ;;(disable-element-with-id "include-aux-data-p")
556 (hide-element-with-id "include-aux-data-p")
557 (hide-element-with-id "aux-point-distance")
558 (setf (chain document
559 (get-element-by-id "aux-point-distance")
564 (defun refresh-layer (layer)
565 "Have layer re-request and redraw features."
566 (chain layer
(refresh (create :force t
))))
568 (defun present-photos ()
569 "Handle the response triggered by request-photos."
570 (let ((photo-parameters
572 (read (@ photo-request-response response-text
)))))
574 for p across photo-parameters
575 for i across
*images
*
577 (setf (getprop i
'photo-parameters
) p
)
578 ((getprop i
'show-photo
)))
579 ;; (setf (@ (aref photo-parameters 0) angle180) 1) ; Debug: coordinate flipping
582 (defun request-photos (event)
583 "Handle the response to a click into *streetmap*; fetch photo data."
584 (disable-element-with-id "finish-point-button")
585 (disable-element-with-id "remove-work-layers-button")
586 (remove-any-layers "Estimated Position")
587 (disable-streetmap-nearest-aux-points-layer)
591 (get-lon-lat-from-pixel (@ event xy
))
592 (transform +spherical-mercator
+
597 (create :longitude
(@ lonlat lon
)
598 :latitude
(@ lonlat lat
)
599 :zoom
((@ *streetmap
* get-zoom
))
600 :count
(lisp *number-of-images
*))))))
601 (setf photo-request-response
602 ((@ *open-layers
*Request
*POST
*)
603 (create :url
"/phoros-lib/local-data"
605 :headers
(create "Content-type" "text/plain"
606 "Content-length" (@ content length
))
607 :success present-photos
)))))
609 (defun draw-epipolar-line ()
610 "Draw an epipolar line from response triggered by clicking
611 into a (first) photo."
612 (enable-element-with-id "remove-work-layers-button")
613 (let* ((epipolar-line
616 (@ this epipolar-request-response response-text
))))
620 (new (chain *open-layers
*geometry
(*point
621 (@ x
:m
) (@ x
:n
))))))))
623 (new (chain *open-layers
629 (*line-string points
))))))))
630 (setf (chain feature render-intent
) "temporary")
631 (chain this epipolar-layer
632 (add-features feature
))))
633 ;; either *line-string or *multi-point are usable
635 (defun request-nearest-aux-points (global-position count
)
636 "Draw into streetmap the count nearest points of auxiliary
638 (let ((global-position-etc global-position
)
640 (setf (chain global-position-etc count
) count
)
641 (setf content
(chain *json-parser
*
642 (write global-position-etc
)))
643 (setf (@ *streetmap
* aux-local-data-request-response
)
644 ((@ *open-layers
*Request
*POST
*)
645 (create :url
"/phoros-lib/aux-local-data"
647 :headers
(create "Content-type" "text/plain"
650 :success draw-nearest-aux-points
)))))
652 (defun draw-estimated-positions ()
653 "Draw into streetmap and into all images points at Estimated
654 Position. Estimated Position is the point returned so far from
655 photogrammetric calculations that are triggered by clicking into
656 another photo. Also draw into streetmap the nearest auxiliary points
657 to Estimated Position."
658 (when (write-permission-p)
659 (setf (chain document
660 (get-element-by-id "finish-point-button")
663 (enable-element-with-id "finish-point-button"))
664 (let* ((estimated-positions-request-response
668 'estimated-positions-request-response
671 (aref estimated-positions-request-response
1))
672 (estimated-position-style
673 (create stroke-color
(chain *open-layers
*feature
*vector
674 style
"temporary" stroke-color
)
677 (setf *global-position
*
678 (aref estimated-positions-request-response
0))
680 (new ((@ *open-layers
*feature
*vector
)
681 ((@ (new ((@ *open-layers
*geometry
*point
)
682 (getprop *global-position
* 'longitude
)
683 (getprop *global-position
* 'latitude
)))
684 transform
) +geographic
+ +spherical-mercator
+)))))
685 (setf (chain feature render-intent
) "temporary")
686 (setf *streetmap-estimated-position-layer
*
687 (new (chain *open-layers
689 (*vector
"Estimated Position"
690 (create display-in-layer-switcher nil
)))))
691 (setf (chain *streetmap-estimated-position-layer
* style
)
692 estimated-position-style
)
693 (chain *streetmap-estimated-position-layer
*
694 (add-features feature
))
696 (add-layer *streetmap-estimated-position-layer
*)))
697 (request-nearest-aux-points *global-position
* 5)
700 for p in estimated-positions
702 (when i
;otherwise a photogrammetry error has occured
703 (setf (@ i estimated-position-layer
)
705 (chain *open-layers
*layer
706 (*vector
"Estimated Position"
707 (create display-in-layer-switcher nil
)))))
708 (setf (chain i estimated-position-lonlat
)
709 (new (chain *open-layers
(*lon-lat
712 (setf (chain i estimated-position-layer style
)
713 estimated-position-style
)
716 (chain *open-layers
*geometry
(*point
721 (chain *open-layers
*feature
(*vector point
)))))
723 (add-layer (@ i estimated-position-layer
)))
724 (chain i estimated-position-layer
725 (add-features feature
))))))
726 (zoom-anything-to-point))
728 (defun draw-nearest-aux-points ()
729 "Draw a few auxiliary points into streetmap."
730 (reveal-element-with-id "include-aux-data-p")
731 (reveal-element-with-id "aux-point-distance")
736 'aux-local-data-request-response
739 (disable-streetmap-nearest-aux-points-layer)
740 (chain *user-points-select-control
* (deactivate))
741 (chain *nearest-aux-points-select-control
* (activate))
742 (chain *nearest-aux-points-hover-control
* (activate))
743 (setf (chain *aux-point-distance-select
*
755 (*point
(chain i geometry coordinates
0)
756 (chain i geometry coordinates
1))))
757 (transform +geographic
+ +spherical-mercator
+)))
760 (chain *open-layers
*feature
(*vector point
)))))
761 (setf (chain feature attributes
)
762 (chain i properties
))
763 (setf (chain feature fid
) ;this is supposed to correspond to
764 n
) ; option of *aux-point-distance-select*
765 (chain *streetmap-nearest-aux-points-layer
*
766 (add-features feature
))
767 (setf aux-point-distance-item
768 (chain document
(create-element "option")))
769 (setf (chain aux-point-distance-item text
)
772 n
;let's hope add-features alway stores features in order of arrival
774 (chain i properties distance
)))
775 (chain *aux-point-distance-select
*
776 (add aux-point-distance-item null
))))
777 (chain *nearest-aux-points-select-control
*
780 (elt (chain *streetmap-nearest-aux-points-layer
* features
)
782 (enable-element-with-id "aux-point-distance")))
784 (defun user-point-style-map (label-property)
785 "Create a style map where styles dispatch on feature property
786 \"attribute\" and features are labelled after feature
787 property label-property."
788 (let* ((symbolizer-property "attribute")
790 (new (chain *open-layers
792 (*comparison
(create type
(chain *open-layers
796 property symbolizer-property
797 value
"solitary")))))
799 (new (chain *open-layers
801 (*comparison
(create type
(chain *open-layers
805 property symbolizer-property
806 value
"polyline")))))
808 (new (chain *open-layers
810 (*comparison
(create type
(chain *open-layers
814 property symbolizer-property
817 (new (chain *open-layers
819 filter solitary-filter
821 graphic-name
"triangle"))))))
823 (new (chain *open-layers
825 filter polyline-filter
827 graphic-name
"square"))))))
829 (new (chain *open-layers
831 filter polygon-filter
833 graphic-name
"star"))))))
835 (new (chain *open-layers
839 graphic-name
"x"))))))
840 (user-point-default-style
843 (*style
(create stroke-color
"OrangeRed"
844 fill-color
"OrangeRed"
849 (create rules
(array solitary-rule
853 (user-point-select-style
856 (*style
(create stroke-opacity
1
857 label label-property
)
858 (create rules
(array solitary-rule
862 (user-point-temporary-style
865 (*style
(create fill-opacity
.5)
866 (create rules
(array solitary-rule
870 (new (chain *open-layers
872 (create "default" user-point-default-style
873 "temporary" user-point-temporary-style
874 "select" user-point-select-style
))))))
876 (defun draw-user-point () ;TODO: we may draw more than one point; change name
877 "Draw currently selected user point into all images."
878 (let* ((user-point-positions-response
881 (getprop *user-point-in-images-response
*
883 (user-point-collections
884 (chain user-point-positions-response image-points
))
886 (chain user-point-positions-response user-point-count
))
888 (when (> user-point-count
1) "${numericDescription}")))
891 for user-point-collection in user-point-collections
893 (when i
;otherwise a photogrammetry error has occured
897 (chain user-point-collection features
)
900 (chain raw-feature geometry coordinates
0))
902 (chain raw-feature geometry coordinates
1))
904 (new (chain *open-layers
908 (chain raw-feature id
))
910 (chain raw-feature properties
))
912 (new (chain *open-layers
914 (*vector point attributes
)))))
915 (setf (chain feature fid
) fid
)
916 (setf (chain feature render-intent
) "select")
919 (@ i user-point-layer
)
920 (new (chain *open-layers
924 (create display-in-layer-switcher nil
925 style-map
(user-point-style-map
927 (chain i map
(add-layer (@ i user-point-layer
)))
928 (chain i user-point-layer
(add-features features
)))))))
930 (defun finish-point ()
931 "Send current *global-position* as a user point to the database."
932 (let ((global-position-etc *global-position
*))
933 (setf (chain global-position-etc attribute
)
935 (elt (chain *point-attributes-select
* options
)
936 (chain *point-attributes-select
* options selected-index
))
938 (setf (chain global-position-etc description
)
939 (value-with-id "point-description"))
940 (setf (chain global-position-etc numeric-description
)
941 (value-with-id "point-numeric-description"))
942 (when (checkbox-status-with-id "include-aux-data-p")
943 (setf (chain global-position-etc aux-numeric
)
944 (chain *current-nearest-aux-point
*
947 (setf (chain global-position-etc aux-text
)
948 (chain *current-nearest-aux-point
*
953 (write global-position-etc
))))
954 ((@ *open-layers
*Request
*POST
*)
955 (create :url
"/phoros-lib/store-point"
957 :headers
(create "Content-type" "text/plain"
958 "Content-length" (@ content length
))
960 (refresh-layer *user-point-layer
*)
961 (reset-layers-and-controls)))))))
963 (defun increment-numeric-text (text)
964 "Increment text if it looks like a number, and return it."
965 (let* ((parts (chain (regex "(\\D*)(\\d*)(.*)") (exec text
)))
966 (old-number (elt parts
2))
967 (new-number (1+ (parse-int old-number
10)))))
968 (if (is-finite new-number
)
969 (+ (elt parts
1) new-number
(elt parts
3))
972 (defun update-point ()
973 "Send changes to currently selected user point to database."
975 (create user-point-id
(chain *current-user-point
* fid
)
978 (elt (chain *point-attributes-select
*
980 (chain *point-attributes-select
*
985 (value-with-id "point-description")
987 (value-with-id "point-numeric-description")))
990 (write point-data
))))
991 ((@ *open-layers
*Request
*POST
*)
992 (create :url
"/phoros-lib/update-point"
994 :headers
(create "Content-type" "text/plain"
995 "Content-length" (@ content length
))
997 (refresh-layer *user-point-layer
*)
998 (reset-layers-and-controls))))))
1000 (defun delete-point ()
1001 "Purge currently selected user point from database."
1002 (let ((user-point-id (chain *current-user-point
* fid
)))
1004 (chain *json-parser
*
1005 (write user-point-id
)))
1006 ((@ *open-layers
*Request
*POST
*)
1007 (create :url
"/phoros-lib/delete-point"
1009 :headers
(create "Content-type" "text/plain"
1010 "Content-length" (@ content length
))
1012 (refresh-layer *user-point-layer
*)
1013 (reset-layers-and-controls))))))
1015 (defun draw-active-point ()
1016 "Draw an Active Point, i.e. a point used in subsequent
1017 photogrammetric calculations."
1018 (chain this active-point-layer
1020 (new ((@ *open-layers
*feature
*vector
)
1021 (new ((@ *open-layers
*geometry
*point
)
1022 (getprop this
'photo-parameters
'm
)
1023 (getprop this
'photo-parameters
'n
))))))))
1025 (defun image-click-action (clicked-image)
1027 "Do appropriate things when an image is clicked into."
1029 ((@ (@ clicked-image map
) get-lon-lat-from-view-port-px
)
1032 (getprop clicked-image
'photo-parameters
))
1033 pristine-image-p content request
)
1034 (setf (@ photo-parameters m
) (@ lonlat lon
)
1035 (@ photo-parameters n
) (@ lonlat lat
))
1036 (remove-layer (getprop clicked-image
'map
) "Active Point")
1037 (remove-any-layers "Epipolar Line")
1038 (setf *pristine-images-p
* (not (some-active-point-p)))
1039 (setf (@ clicked-image active-point-layer
)
1040 (new (chain *open-layers
1042 (*vector
"Active Point"
1043 (create display-in-layer-switcher
1045 ((@ clicked-image map add-layer
)
1046 (@ clicked-image active-point-layer
))
1047 ((getprop clicked-image
'draw-active-point
))
1051 (chain *user-points-select-control
* (unselect-all))
1053 (setf (value-with-id "point-numeric-description")
1054 (increment-numeric-text
1055 (value-with-id "point-numeric-description")))
1056 (remove-any-layers "User Point") ;from images
1058 for i across
*images
* do
1059 (unless (== i clicked-image
)
1061 (@ i epipolar-layer
)
1062 (new (chain *open-layers
1064 (*vector
"Epipolar Line"
1065 (create display-in-layer-switcher nil
))))
1066 content
(chain *json-parser
*
1068 (append (array photo-parameters
)
1069 (@ i photo-parameters
))))
1070 (@ i epipolar-request-response
)
1071 ((@ *open-layers
*Request
*POST
*)
1072 (create :url
"/phoros-lib/epipolar-line"
1074 :headers
(create "Content-type" "text/plain"
1077 :success
(getprop i
'draw-epipolar-line
)
1079 ((@ i map add-layer
) (@ i epipolar-layer
)))))
1081 (remove-any-layers "Epipolar Line")
1082 (remove-any-layers "Estimated Position")
1083 (let* ((active-pointed-photo-parameters
1085 for i across
*images
*
1086 when
(has-layer-p (getprop i
'map
) "Active Point")
1087 collect
(getprop i
'photo-parameters
)))
1089 (chain *json-parser
*
1091 (list active-pointed-photo-parameters
1095 x
'photo-parameters
)))))))))
1096 (setf (@ clicked-image estimated-positions-request-response
)
1097 ((@ *open-layers
*Request
*POST
*)
1098 (create :url
"/phoros-lib/estimated-positions"
1100 :headers
(create "Content-type" "text/plain"
1103 :success
(getprop clicked-image
1104 'draw-estimated-positions
)
1105 :scope clicked-image
)))))))))
1107 (defun iso-time-string (lisp-time)
1108 "Return Lisp universal time formatted as ISO time string"
1109 (let* ((unix-time (- lisp-time
+unix-epoch
+))
1110 (js-date (new (*date
(* 1000 unix-time
)))))
1111 (chain *open-layers
*date
(to-i-s-o-string js-date
))))
1113 (defun show-photo ()
1114 "Show the photo described in this object's photo-parameters."
1116 repeat
((getprop this
'map
'get-num-layers
))
1117 do
((getprop this
'map
'layers
0 'destroy
)))
1118 ((getprop this
'map
'add-layer
)
1124 (photo-path (getprop this
'photo-parameters
))
1125 (new ((@ *open-layers
*bounds
) -
.5 -
.5
1126 (+ (getprop this
'photo-parameters
'sensor-width-pix
)
1128 (+ (getprop this
'photo-parameters
'sensor-height-pix
)
1129 .5))) ; coordinates shown
1130 (new ((@ *open-layers
*size
) 512 256))
1132 (chain this map
(zoom-to-max-extent))
1133 (setf (chain this trigger-time-div inner-h-t-m-l
)
1134 (iso-time-string (getprop this
'photo-parameters
'trigger-time
))))
1136 (defun zoom-images-to-max-extent ()
1137 "Zoom out all images."
1138 (loop for i across
*images
* do
(chain i map
(zoom-to-max-extent))))
1140 (defun zoom-anything-to-point ()
1141 "For streetmap and for images that have an Active Point or an
1142 Estimated Position, zoom in and recenter."
1143 (when (checkbox-status-with-id "zoom-to-point-p")
1145 (new (chain *open-layers
1146 (*lon-lat
(chain *global-position
* longitude
)
1147 (chain *global-position
* latitude
))
1148 (transform +geographic
+ +spherical-mercator
+)))))
1151 (set-center point-lonlat
18 nil t
))))
1152 (loop for i across
*images
* do
1155 ((has-layer-p (chain i map
) "Active Point")
1156 (new (chain *open-layers
(*lon-lat
1157 (chain i photo-parameters m
)
1158 (chain i photo-parameters n
)))))
1159 ((has-layer-p (chain i map
) "Estimated Position")
1160 (chain i estimated-position-lonlat
))
1163 (chain i map
(set-center point-lonlat
4 nil t
)))))))
1165 (defun initialize-image (image-index)
1166 "Create an image usable for displaying photos at position
1167 image-index in array *images*."
1168 (setf (aref *images
* image-index
) (new *image
))
1169 (setf (@ (aref *images
* image-index
) trigger-time-div
)
1172 (get-element-by-id (+ "image-" image-index
"-trigger-time"))))
1173 (setf (@ (aref *images
* image-index
) image-click-action
)
1174 (image-click-action (aref *images
* image-index
)))
1175 (setf (@ (aref *images
* image-index
) click
)
1176 (new (*click-control
*
1177 (create :trigger
(@ (aref *images
* image-index
)
1178 image-click-action
)))))
1179 (chain (aref *images
* image-index
)
1182 (@ (aref *images
* image-index
) click
)))
1183 (chain (aref *images
* image-index
) click
(activate))
1184 ;;(chain (aref *images* image-index)
1187 ;; (new (chain *open-layers
1193 ;; (get-element-by-id
1194 ;; (+ "image-" image-index "-zoom")))))))))
1195 (chain (aref *images
* image-index
)
1198 (new (chain *open-layers
1205 (+ "image-" image-index
"-layer-switcher")))
1206 rounded-corner nil
))))))
1207 (let ((pan-west-control
1208 (new (chain *open-layers
*control
(*pan
"West"))))
1210 (new (chain *open-layers
*control
(*pan
"North"))))
1212 (new (chain *open-layers
*control
(*pan
"South"))))
1214 (new (chain *open-layers
*control
(*pan
"East"))))
1216 (new (chain *open-layers
*control
(*zoom-in
))))
1218 (new (chain *open-layers
*control
(*zoom-out
))))
1219 (zoom-to-max-extent-control
1220 (new (chain *open-layers
*control
(*zoom-to-max-extent
))))
1222 (new (chain *open-layers
1229 (+ "image-" image-index
"-zoom")))))))))
1230 (chain (aref *images
* image-index
) map
(add-control pan-zoom-panel
))
1231 (chain pan-zoom-panel
(add-controls (array pan-west-control
1237 zoom-to-max-extent-control
))))
1238 (chain (aref *images
* image-index
)
1240 (render (chain document
1242 (+ "image-" image-index
))))))
1244 (defun user-point-selected (event)
1245 "Things to do once a user point is selected."
1246 (remove-any-layers "Active Point")
1247 (remove-any-layers "Epipolar Line")
1248 (remove-any-layers "Estimated Position")
1249 (user-point-selection-changed event
))
1251 (defun user-point-unselected (event)
1252 "Things to do once a user point is selected."
1253 (user-point-selection-changed event
))
1255 (defun user-point-selection-changed (event)
1256 "Things to do once a user point is selected or unselected."
1257 (hide-aux-data-choice)
1258 ;; after single select: same as event
1259 (setf *current-user-point
* (chain event object selected-features
0))
1260 (let ((selected-features-count
1261 (chain *user-point-layer
* selected-features length
)))
1262 (setf (chain *user-point-layer
* style-map
)
1263 (user-point-style-map
1264 (when (> selected-features-count
1)
1265 "${numericDescription}")))
1266 (if (> selected-features-count
1)
1268 (hide-element-with-id "real-phoros-controls")
1269 (reveal-element-with-id "multiple-points-phoros-controls"))
1271 (hide-element-with-id "multiple-points-phoros-controls")
1272 (reveal-element-with-id "real-phoros-controls"))))
1273 (chain *user-point-layer
* (redraw))
1274 (remove-any-layers "User Point") ;from images
1275 (if (write-permission-p (chain event feature attributes user-name
))
1277 (setf (chain document
1278 (get-element-by-id "finish-point-button")
1281 (enable-element-with-id "finish-point-button")
1282 (enable-element-with-id "delete-point-button")
1283 (setf (inner-html-with-id "h2-controls") "Edit Point"))
1285 (disable-element-with-id "finish-point-button")
1286 (disable-element-with-id "delete-point-button")
1287 (setf (inner-html-with-id "h2-controls") "View Point")))
1288 (setf (inner-html-with-id "creator")
1289 (+ "(by " (chain event feature attributes user-name
) ")"))
1290 (setf (value-with-id "point-attribute")
1291 (chain event feature attributes attribute
))
1292 (setf (value-with-id "point-description")
1293 (chain event feature attributes description
))
1294 (setf (value-with-id "point-numeric-description")
1295 (chain event feature attributes numeric-description
))
1296 (setf (inner-html-with-id "point-creation-date")
1297 (chain event feature attributes creation-date
))
1298 (setf (inner-html-with-id "aux-numeric-list")
1300 (chain event feature attributes aux-numeric
)))
1301 (setf (inner-html-with-id "aux-text-list")
1303 (chain event feature attributes aux-text
)))
1305 (chain *json-parser
*
1310 (map (lambda (x) (@ x fid
))))
1312 for i across
*images
*
1313 collect
(chain i photo-parameters
))))))
1314 (setf *user-point-in-images-response
*
1315 ((@ *open-layers
*Request
*POST
*)
1316 (create :url
"/phoros-lib/user-point-positions"
1318 :headers
(create "Content-type" "text/plain"
1319 "Content-length" (@ content length
))
1320 :success draw-user-point
))))
1322 (defun aux-point-distance-selected ()
1323 "Things to do on change of aux-point-distance select element."
1324 (chain *nearest-aux-points-select-control
*
1326 (chain *nearest-aux-points-select-control
*
1329 (elt (chain *streetmap-nearest-aux-points-layer
* features
)
1330 (chain *aux-point-distance-select
*
1332 selected-index
))))))
1334 (defun enable-aux-point-selection ()
1335 "Check checkbox include-aux-data-p and act accordingly."
1336 (setf (checkbox-status-with-id "include-aux-data-p") t
)
1337 (flip-aux-data-inclusion))
1339 (defun flip-aux-data-inclusion ()
1340 "Query status of checkbox include-aux-data-p and act
1342 (if (checkbox-status-with-id "include-aux-data-p")
1343 (chain *streetmap-nearest-aux-points-layer
*
1345 (chain *streetmap-nearest-aux-points-layer
*
1346 (set-visibility nil
))))
1348 (defun html-ordered-list (aux-data)
1349 "Return a html-formatted list from aux-data."
1352 (:ol
:class
"aux-data-list"
1354 (reduce (lambda (x y
)
1355 (+ x
(who-ps-html (:li y
))))
1359 (defun nearest-aux-point-selected (event)
1360 "Things to do once a nearest auxiliary point is selected in streetmap."
1361 (setf *current-nearest-aux-point
* (chain event feature
))
1363 (chain event feature attributes aux-numeric
))
1365 (chain event feature attributes aux-text
))
1367 (chain event feature attributes distance
)))
1368 (setf (chain *aux-point-distance-select
* options selected-index
)
1369 (chain event feature fid
))
1370 (setf (inner-html-with-id "aux-numeric-list")
1371 (html-ordered-list aux-numeric
))
1372 (setf (inner-html-with-id "aux-text-list")
1373 (html-ordered-list aux-text
))))
1376 "Prepare user's playground."
1377 (when (write-permission-p)
1378 (enable-element-with-id "point-attribute")
1379 (enable-element-with-id "point-description")
1380 (enable-element-with-id "point-numeric-description")
1381 (hide-element-with-id "multiple-points-phoros-controls")
1382 (setf (inner-html-with-id "h2-controls") "Create Point"))
1383 (setf *point-attributes-select
*
1384 (chain document
(get-element-by-id "point-attribute")))
1385 (setf *aux-point-distance-select
*
1386 (chain document
(get-element-by-id "aux-point-distance")))
1387 (loop for i in
'("solitary" "polyline" "polygon") do
1388 (setf point-attribute-item
(chain document
(create-element "option")))
1389 (setf (chain point-attribute-item text
) i
)
1390 (chain *point-attributes-select
* (add point-attribute-item null
))) ;TODO: input of user-defined attributes
1391 (hide-aux-data-choice)
1396 (create projection
+geographic
+
1397 display-projection
+geographic
+
1398 controls
(array (new (chain *open-layers
1401 (new (chain *open-layers
1403 (*attribution
)))))))))
1406 (new (chain *open-layers
1413 "streetmap-layer-switcher"))
1414 rounded-corner nil
))))))
1415 (let ((pan-west-control
1416 (new (chain *open-layers
*control
(*pan
"West"))))
1418 (new (chain *open-layers
*control
(*pan
"North"))))
1420 (new (chain *open-layers
*control
(*pan
"South"))))
1422 (new (chain *open-layers
*control
(*pan
"East"))))
1424 (new (chain *open-layers
*control
(*zoom-in
))))
1426 (new (chain *open-layers
*control
(*zoom-out
))))
1427 (zoom-to-max-extent-control
1433 display-class
"streetmapZoomToMaxExtent"
1437 +presentation-project-bounds
+ ))))))))
1439 (new (chain *open-layers
1446 "streetmap-zoom")))))))
1448 (new (chain *open-layers
1456 "streetmap-overview")))))))
1457 (mouse-position-control
1458 (new (chain *open-layers
1461 (create div
(chain document
1463 "streetmap-mouse-position"))
1464 empty-string
"longitude, latitude")))))
1466 (new (chain *open-layers
1470 (add-control pan-zoom-panel
))
1471 (chain pan-zoom-panel
1472 (add-controls (array pan-west-control
1478 zoom-to-max-extent-control
)))
1480 (add-control *click-streetmap
*))
1481 (chain *click-streetmap
* (activate))
1483 (chain *user-point-layer
*
1485 (register "featureselected"
1487 user-point-selected
))
1488 (chain *user-point-layer
*
1490 (register "featureunselected"
1492 user-point-unselected
))
1493 (chain *streetmap-nearest-aux-points-layer
*
1495 (register "featureselected"
1496 *streetmap-nearest-aux-points-layer
*
1497 nearest-aux-point-selected
))
1498 (chain *streetmap
* (add-control *nearest-aux-points-hover-control
*))
1499 (chain *streetmap
* (add-control *nearest-aux-points-select-control
*))
1500 (chain *streetmap
* (add-control *user-points-hover-control
*))
1501 (chain *streetmap
* (add-control *user-points-select-control
*))
1502 (chain *user-points-hover-control
* (activate))
1503 (chain *user-points-select-control
* (activate))
1504 (chain *nearest-aux-points-hover-control
* (activate))
1505 (chain *nearest-aux-points-select-control
* (activate))
1507 (chain *streetmap
* (add-layer *osm-layer
*))
1508 (try (chain *streetmap
* (add-layer *google-streetmap-layer
*))
1510 (chain *streetmap
* (remove-layer *google-streetmap-layer
*))))
1511 (chain *streetmap
* (add-layer *streetmap-nearest-aux-points-layer
*))
1512 (chain *streetmap
* (add-layer *survey-layer
*))
1513 (chain *streetmap
* (add-layer *aux-point-layer
*))
1514 (chain *streetmap
* (add-layer *user-point-layer
*))
1515 (setf (chain overview-map element
)
1516 (chain document
(get-element-by-id
1517 "streetmap-overview-element")))
1518 (chain *streetmap
* (add-control overview-map
))
1520 (zoom-to-extent +presentation-project-bounds
+))
1521 (chain *streetmap
* (add-control mouse-position-control
))
1522 (chain *streetmap
* (add-control scale-line-control
)))
1524 for i from
0 to
(lisp (1- *number-of-images
*))
1525 do
(initialize-image i
))
1526 (add-help-events))))))