?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Display geographic coordinates of streetmap cursor outside map
[phoros.git] / phoros.lisp
blobfa16d15b34288c70b37e7397f15b4cf97bcd87b8
1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
3 ;;;
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.
8 ;;;
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.
13 ;;;
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.
17
18 (in-package :phoros)
19
20 (setf *js-target-version* 1.8)
21
22 ;;; Debug helpers. TODO: remove them.
23 (defparameter *t* nil)
24 (defparameter *tt* nil)
25
26 (cffi:define-foreign-library phoml
27 (:unix (:or "./libphoml.so"
28 "./phoml/lib/libphoml.so"))
29 (t (:default "libphoml")))
30
31 (defparameter *standard-coordinates* 4326
32 "EPSG code of the coordinate system that we use for communication.")
33
34 (defparameter *postgresql-credentials* nil
35 "A list: (database user password host &key (port 5432) use-ssl)")
36
37 (defparameter *photogrammetry-mutex* (bt:make-lock "photogrammetry"))
38
39 (setf *read-default-float-format* 'double-float)
40
41 (defparameter *phoros-server* nil "Hunchentoot acceptor.")
42
43 (defparameter *common-root* nil
44 "Root directory; contains directories of measuring data.")
45
46 (defparameter *verbose* 0
47 "Integer (interpreted as a bit mask) denoting various kinds of
48 debugging output.")
49
50 (defparameter *use-multi-file-openlayers* nil
51 "If t, use OpenLayers uncompiled from openlayers/*, which makes
52 debugging easier. Otherwise use a single-file shrunk
53 ol/Openlayers.js.")
54
55 (defparameter *number-of-images* 4
56 "Number of photos shown to the HTTP client.")
57
58 (defparameter *number-of-features-per-layer* 500
59 "What we think a browser can swallow.")
60
61 (defun check-db (db-credentials)
62 "Check postgresql connection. Return t if successful; show error on
63 *error-output* otherwise. db-credentials is a list like so: (database
64 user password host &key (port 5432) use-ssl)."
65 (let (connection)
66 (handler-case
67 (setf connection (apply #'connect db-credentials))
68 (error (e) (format *error-output* "Database connection ~S failed: ~A~&"
69 db-credentials e)))
70 (when connection
71 (disconnect connection)
72 t)))
73
74 (defmethod hunchentoot:session-cookie-name (acceptor)
75 (declare (ignore acceptor))
76 "phoros-session")
77
78 (defun start-server (&key (server-port 8080) (common-root "/"))
79 (setf *phoros-server* (make-instance 'hunchentoot:acceptor :port server-port))
80 (setf *session-max-time* (* 3600 24))
81 (setf *common-root* common-root)
82 (setf *show-lisp-errors-p* (logbitp 16 *verbose*))
83 (setf *ps-print-pretty* (logbitp 15 *verbose*))
84 (setf *use-multi-file-openlayers* (logbitp 14 *verbose*))
85 ;; Doesn't seem to exist(setf *show-lisp-backtraces-p* t) ;TODO: tie this to --debug option
86 (setf *message-log-pathname* "hunchentoot-messages.log") ;TODO: try using cl-log
87 (setf *access-log-pathname* "hunchentoot-access.log") ;TODO: try using cl-log
88 (check-db *postgresql-credentials*)
89 (with-connection *postgresql-credentials*
90 (assert-phoros-db-major-version))
91 (hunchentoot:start *phoros-server*))
92
93 (defun stop-server () (hunchentoot:stop *phoros-server*))
94
95 (eval-when (:compile-toplevel :load-toplevel :execute)
96 (register-sql-operators :2+-ary :&& :overlaps))
97
98 (define-easy-handler phoros-handler ()
99 "First HTTP contact: if necessary, check credentials, establish new
100 session."
101 (with-connection *postgresql-credentials*
102 (let* ((presentation-project-name
103 (second (cl-utilities:split-sequence #\/ (script-name*) :remove-empty-subseqs t)))
104 (presentation-project-id
105 (ignore-errors
106 (query
107 (:select 'presentation-project-id
108 :from 'sys-presentation-project
109 :where (:= 'presentation-project-name presentation-project-name))
110 :single))))
111 (cond
112 ((null presentation-project-id) "No such project.") ;TODO: send appropriate http error code
113 ((and (equal (session-value 'presentation-project-name) presentation-project-name)
114 (session-value 'authenticated-p))
115 (redirect "/phoros-lib/view" :add-session-id t))
116 (t
117 (progn
118 (setf (session-value 'presentation-project-name)
119 presentation-project-name)
120 (setf (session-value 'presentation-project-id)
121 presentation-project-id)
122 (setf (session-value 'presentation-project-bbox)
123 (presentation-project-bbox presentation-project-id))
124 (who:with-html-output-to-string (s nil :prologue t :indent t)
125 (:form :method "post" :enctype "multipart/form-data"
126 :action "/phoros-lib/authenticate"
127 "User:" :br
128 (:input :type "text" :name "user-name") :br
129 "Password:" :br
130 (:input :type "password" :name "user-password") :br
131 (:input :type "submit" :value "Submit")))))))))
132
133 (pushnew (create-prefix-dispatcher "/phoros/" 'phoros-handler)
134 *dispatch-table*)
135
136 (define-easy-handler
137 (authenticate-handler :uri "/phoros-lib/authenticate"
138 :default-request-type :post)
139 ()
140 "Check user credentials."
141 (with-connection *postgresql-credentials*
142 (let* ((user-name (post-parameter "user-name"))
143 (user-password (post-parameter "user-password"))
144 (presentation-project-id (session-value 'presentation-project-id))
145 (user-info
146 (when presentation-project-id
147 (query
148 (:select
149 'sys-user.user-full-name
150 'sys-user.user-id
151 'sys-user-role.user-role
152 :from 'sys-user-role 'sys-user
153 :where (:and
154 (:= 'presentation-project-id presentation-project-id)
155 (:= 'sys-user-role.user-id 'sys-user.user-id)
156 (:= 'user-name user-name)
157 (:= 'user-password user-password)))
158 :row)))
159 (user-full-name (first user-info))
160 (user-id (second user-info))
161 (user-role (third user-info)))
162 (if user-role
163 (progn
164 (setf (session-value 'authenticated-p) t
165 (session-value 'user-name) user-name
166 (session-value 'user-full-name) user-full-name
167 (session-value 'user-id) user-id
168 (session-value 'user-role) user-role)
169 (redirect "/phoros-lib/view" :add-session-id t))
170 "Rejected."))))
171
172 (define-easy-handler logout-handler ()
173 (if (session-verify *request*)
174 (progn (remove-session *session*)
175 "Bye.")
176 "Bye (again)."))
177
178 (pushnew (create-regex-dispatcher "/logout" 'logout-handler)
179 *dispatch-table*)
180
181 (define-easy-handler
182 (local-data :uri "/phoros-lib/local-data" :default-request-type :post)
183 ()
184 "Receive coordinates, respond with the count nearest json objects
185 containing picture url, calibration parameters, and car position,
186 wrapped in an array."
187 (when (session-value 'authenticated-p)
188 (let* ((presentation-project-id (session-value 'presentation-project-id))
189 (common-table-names (common-table-names presentation-project-id))
190 (data (json:decode-json-from-string (raw-post-data)))
191 (longitude-input (cdr (assoc :longitude data)))
192 (latitude-input (cdr (assoc :latitude data)))
193 (count (cdr (assoc :count data)))
194 (zoom-input (cdr (assoc :zoom data)))
195 ;;(snap-distance (* 10d-5 (expt 2 (- 18 zoom-input)))) ; assuming geographic coordinates
196 (snap-distance (* 10d-1 (expt 2 (- 18 zoom-input)))) ; assuming geographic coordinates
197 (point-form
198 (format nil "POINT(~F ~F)" longitude-input latitude-input))
199 (result
200 (ignore-errors
201 (with-connection *postgresql-credentials*
202 (loop
203 for common-table-name in common-table-names
204 nconc
205 (query
206 (:limit
207 (:order-by
208 (:select
209 'date ;TODO: debug only
210 'measurement-id 'recorded-device-id 'device-stage-of-life-id ;TODO: debug only
211 'directory
212 'filename 'byte-position 'point-id
213 'trigger-time
214 ;'coordinates ;the search target
215 'longitude 'latitude 'ellipsoid-height
216 'cartesian-system
217 'east-sd 'north-sd 'height-sd
218 'roll 'pitch 'heading 'roll-sd 'pitch-sd 'heading-sd
219 'sensor-width-pix 'sensor-height-pix 'pix-size
220 'mounting-angle
221 'dx 'dy 'dz 'omega 'phi 'kappa
222 'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
223 'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
224 'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
225 :from
226 (aggregate-view-name common-table-name)
227 :where
228 (:and (:= 'presentation-project-id presentation-project-id)
229 (:st_dwithin 'coordinates
230 (:st_geomfromtext point-form *standard-coordinates*)
231 snap-distance)))
232 (:st_distance 'coordinates
233 (:st_geomfromtext point-form *standard-coordinates*)))
234 count)
235 :alists))))))
236 (json:encode-json-to-string result))))
237
238 (define-easy-handler
239 (store-point :uri "/phoros-lib/store-point" :default-request-type :post)
240 ()
241 "Receive point sent by user; store it into database."
242 (when (session-value 'authenticated-p)
243 (let* ((presentation-project-name (session-value 'presentation-project-name))
244 (user-id (session-value 'user-id))
245 (user-role (session-value 'user-role))
246 (data (json:decode-json-from-string (raw-post-data)))
247 (longitude-input (cdr (assoc :longitude data)))
248 (latitude-input (cdr (assoc :latitude data)))
249 (ellipsoid-height-input (cdr (assoc :ellipsoid-height data)))
250 (stdx-global (cdr (assoc :stdx-global data)))
251 (stdy-global (cdr (assoc :stdy-global data)))
252 (stdz-global (cdr (assoc :stdz-global data)))
253 (attribute (cdr (assoc :attribute data)))
254 (description (cdr (assoc :description data)))
255 (numeric-description (cdr (assoc :numeric-description data)))
256 (point-form
257 (format nil "SRID=4326; POINT(~S ~S ~S)"
258 longitude-input latitude-input ellipsoid-height-input))
259 (user-point-table-name
260 (user-point-table-name presentation-project-name)))
261 (assert
262 (not (string-equal user-role "read")) ;that is, "write" or "admin"
263 () "No write permission.")
264 (with-connection *postgresql-credentials*
265 (assert
266 (= 1 (execute (:insert-into user-point-table-name :set
267 'user-id user-id
268 'attribute attribute
269 'description description
270 'numeric-description numeric-description
271 'creation-date 'current-timestamp
272 'coordinates (:st_geomfromewkt point-form)
273 'stdx-global stdx-global
274 'stdy-global stdy-global
275 'stdz-global stdz-global
276 )))
277 () "No point stored. This should not happen.")))))
278
279 (define-easy-handler
280 (update-point :uri "/phoros-lib/update-point" :default-request-type :post)
281 ()
282 "Update point sent by user in database."
283 (when (session-value 'authenticated-p)
284 (let* ((presentation-project-name (session-value 'presentation-project-name))
285 (user-id (session-value 'user-id))
286 (user-role (session-value 'user-role))
287 (data (json:decode-json-from-string (raw-post-data)))
288 (user-point-id (cdr (assoc :user-point-id data)))
289 (attribute (cdr (assoc :attribute data)))
290 (description (cdr (assoc :description data)))
291 (numeric-description (cdr (assoc :numeric-description data)))
292 (user-point-table-name
293 (user-point-table-name presentation-project-name)))
294 (assert
295 (not (string-equal user-role "read")) ;that is, "write" or "admin"
296 () "No write permission.")
297 (with-connection *postgresql-credentials*
298 (assert
299 (= 1 (execute (:update user-point-table-name :set
300 'attribute attribute
301 'description description
302 'numeric-description numeric-description
303 'creation-date 'current-timestamp
304 :where (:and (:= 'user-point-id user-point-id)
305 (:= (if (string-equal user-role "admin")
306 user-id
307 'user-id)
308 user-id)))))
309 () "No point stored. Did you try to update someone else's point without having admin permission?")))))
310
311 (define-easy-handler
312 (delete-point :uri "/phoros-lib/delete-point" :default-request-type :post)
313 ()
314 "Delete user point if user is allowed to do so."
315 (when (session-value 'authenticated-p)
316 (let* ((presentation-project-name (session-value 'presentation-project-name))
317 (user-id (session-value 'user-id))
318 (user-role (session-value 'user-role))
319 (user-point-table-name
320 (user-point-table-name presentation-project-name))
321 (data (json:decode-json-from-string (raw-post-data))))
322 (with-connection *postgresql-credentials*
323 (assert
324 (eql 1 (cond ((string-equal user-role "admin")
325 (execute (:delete-from user-point-table-name
326 :where (:= 'user-point-id data))))
327 ((string-equal user-role "write")
328 (execute (:delete-from user-point-table-name
329 :where (:and
330 (:= 'user-point-id data)
331 (:= 'user-id user-id)))))))
332 () "No point deleted. This should not happen.")))))
333
334
335 (defun common-table-names (presentation-project-id)
336 "Return a list of common-table-names of table sets that contain data
337 of presentation project with presentation-project-id."
338 (handler-case
339 (with-connection *postgresql-credentials*
340 (query
341 (:select 'common-table-name
342 :distinct
343 :from 'sys-presentation 'sys-measurement 'sys-acquisition-project
344 :where (:and
345 (:= 'sys-presentation.presentation-project-id presentation-project-id)
346 (:= 'sys-presentation.measurement-id 'sys-measurement.measurement-id)
347 (:= 'sys-measurement.acquisition-project-id 'sys-acquisition-project.acquisition-project-id)))
348 :column))
349 (condition (c)
350 (cl-log:log-message
351 :server
352 "While fetching common-table-names of presentation-project-id ~D: ~A"
353 presentation-project-id c))))
354
355 (defun encode-geojson-to-string (features &rest junk-keys)
356 "Encode a list of property lists into a GeoJSON FeatureCollection.
357 Each property list must contain keys for coordinates, :x, :y, :z; and
358 for a numeric point :id, followed by zero or more pieces of extra
359 information. The extra information is stored as GeoJSON Feature
360 properties. Exclude property list elements with keys that are in
361 junk-keys."
362 (with-output-to-string (s)
363 (json:with-object (s)
364 (json:encode-object-member :type :*feature-collection s)
365 (json:as-object-member (:features s)
366 (json:with-array (s)
367 (mapcar
368 #'(lambda (point-with-properties)
369 (dolist (junk-key junk-keys)
370 (remf point-with-properties junk-key))
371 (destructuring-bind (&key x y z id &allow-other-keys) ;TODO: z probably bogus
372 point-with-properties
373 (json:as-array-member (s)
374 (json:with-object (s)
375 (json:encode-object-member :type :*feature s)
376 (json:as-object-member (:geometry s)
377 (json:with-object (s)
378 (json:encode-object-member :type :*point s)
379 (json:as-object-member (:coordinates s)
380 (json:encode-json (list x y z) s))))
381 (json:encode-object-member :id id s)
382 (json:as-object-member (:properties s)
383 (dolist (key '(:x :y :z :id))
384 (remf point-with-properties key))
385 (json:encode-json-plist point-with-properties s))))))
386 features))))))
387
388 (defun box3d (bbox)
389 "Return a WKT-compliant BOX3D string from string bbox."
390 (concatenate 'string "BOX3D("
391 (substitute #\Space #\,
392 (substitute #\Space #\, bbox :count 1)
393 :from-end t :count 1)
394 ")"))
395
396 (define-easy-handler (points :uri "/phoros-lib/points") (bbox)
397 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
398 (when (session-value 'authenticated-p)
399 (handler-case
400 (let* ((presentation-project-id (session-value 'presentation-project-id))
401 (common-table-names
402 (common-table-names presentation-project-id)))
403 (encode-geojson-to-string
404 (with-connection *postgresql-credentials*
405 (query
406 (sql-compile
407 `(:limit
408 (:order-by
409 (:union
410 ,@(loop
411 for common-table-name in common-table-names
412 for aggregate-view-name
413 = (aggregate-view-name common-table-name)
414 collect
415 `(:select
416 (:as
417 (:st_x
418 (:st_transform 'coordinates ,*standard-coordinates*))
419 x)
420 (:as
421 (:st_y
422 (:st_transform 'coordinates ,*standard-coordinates*))
423 y)
424 (:as
425 (:st_z
426 (:st_transform 'coordinates ,*standard-coordinates*))
427 z)
428 (:as 'point-id 'id) ;becomes fid on client
429 (:as (:random) random)
430 :from ',aggregate-view-name
431 :natural :left-join 'sys-presentation
432 :where
433 (:and
434 (:= 'presentation-project-id ,presentation-project-id)
435 (:&&
436 (:st_transform 'coordinates ,*standard-coordinates*)
437 (:st_setsrid (:type ,(box3d bbox) box3d)
438 ,*standard-coordinates*))))))
439 random)
440 ,*number-of-features-per-layer*))
441 :plists))
442 :random))
443 (condition (c)
444 (cl-log:log-message
445 :server "While fetching points from inside bbox ~S: ~A"
446 bbox c)))))
447
448 (defun presentation-project-bbox (presentation-project-id)
449 "Return bounding box of the entire presentation-project as a string
450 \"x1,y1,x2,y2\"."
451 (let* ((common-table-names
452 (common-table-names presentation-project-id)))
453 (with-connection *postgresql-credentials*
454 (substitute
455 #\, #\Space
456 (string-trim
457 "BOX()"
458 (query
459 (sql-compile
460 `(:select
461 (:st_extent (:st_transform 'coordinates ,*standard-coordinates*))
462 :from
463 (:as (:union
464 ,@(loop
465 for common-table-name in common-table-names
466 for aggregate-view-name
467 = (aggregate-view-name common-table-name)
468 collect
469 `(:select
470 'coordinates
471 :from ',aggregate-view-name
472 :natural :left-join 'sys-presentation
473 :where
474 (:= 'presentation-project-id
475 ,presentation-project-id))))
476 all-coordinates)))
477 :single!))))))
478
479 (define-easy-handler (user-points :uri "/phoros-lib/user-points") (bbox)
480 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
481 (when (session-value 'authenticated-p)
482 (handler-case
483 (let ((user-point-table-name
484 (user-point-table-name (session-value 'presentation-project-name))))
485 (encode-geojson-to-string
486 (with-connection *postgresql-credentials*
487 (query
488 (:limit
489 (:order-by
490 (:select
491 (:as
492 (:st_x (:st_transform 'coordinates *standard-coordinates*))
493 'x)
494 (:as
495 (:st_y (:st_transform 'coordinates *standard-coordinates*))
496 'y)
497 (:as
498 (:st_z (:st_transform 'coordinates *standard-coordinates*))
499 'z)
500 (:as 'user-point-id 'id) ;becomes fid on client
501 'attribute
502 'description
503 'numeric-description
504 'user-name
505 (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
506 'creation-date)
507 :from user-point-table-name :natural :left-join 'sys-user
508 :where (:&&
509 (:st_transform 'coordinates *standard-coordinates*)
510 (:st_setsrid (:type (box3d bbox) box3d)
511 *standard-coordinates*)))
512 (:random))
513 *number-of-features-per-layer*)
514 :plists))))
515 (condition (c)
516 (cl-log:log-message
517 :server "While fetching user-points from inside bbox ~S: ~A"
518 bbox c)))))
519
520 (define-easy-handler photo-handler
521 ((bayer-pattern :init-form "#00ff00,#ff0000")
522 (color-raiser :init-form "1,1,1"))
523 "Serve an image from a .pictures file."
524 (when (session-value 'authenticated-p)
525 (handler-case
526 (let* ((s (cdr (cl-utilities:split-sequence #\/ (script-name*)
527 :remove-empty-subseqs t)))
528 (directory (last (butlast s 2)))
529 (file-name-and-type (cl-utilities:split-sequence
530 #\. (first (last s 2))))
531 (byte-position (parse-integer (car (last s)) :junk-allowed t))
532 (path-to-file
533 (car
534 (directory
535 (make-pathname
536 :directory (append (pathname-directory *common-root*)
537 directory '(:wild-inferiors))
538 :name (first file-name-and-type)
539 :type (second file-name-and-type)))))
540 stream)
541 (setf (content-type*) "image/png")
542 (setf stream (send-headers))
543 (send-png stream path-to-file byte-position
544 :bayer-pattern (canonicalize-bayer-pattern bayer-pattern)
545 :color-raiser (canonicalize-color-raiser color-raiser)))
546 (condition (c)
547 (cl-log:log-message
548 :server "While serving image ~S: ~A" (request-uri*) c)))))
549
550 (pushnew (create-prefix-dispatcher "/phoros-lib/photo" 'photo-handler)
551 *dispatch-table*)
552
553 ;;; for debugging; this is the multi-file OpenLayers
554 (pushnew (create-folder-dispatcher-and-handler
555 "/phoros-lib/openlayers/" "OpenLayers-2.10/")
556 *dispatch-table*)
557
558 (pushnew (create-folder-dispatcher-and-handler "/phoros-lib/ol/" "ol/")
559 *dispatch-table*)
560
561 (pushnew (create-folder-dispatcher-and-handler "/phoros-lib/css/" "css/") ;TODO: merge this style.css into public_html/style.css
562 *dispatch-table*)
563
564 (pushnew (create-folder-dispatcher-and-handler
565 "/phoros-lib/public_html/" "public_html/")
566 *dispatch-table*)
567
568 (pushnew (create-static-file-dispatcher-and-handler
569 "/favicon.ico" "public_html/favicon.ico")
570 *dispatch-table*)
571
572 (define-easy-handler (phoros.js :uri "/phoros-lib/phoros.js") ()
573 "Serve some Javascript."
574 (when (session-value 'authenticated-p)
575 (ps
576
577 (setf debug-info (@ *open-layers *console info))
578
579 (defmacro inner-html-with-id (id)
580 "innerHTML of element with id=\"id\"."
581 `(chain document (get-element-by-id ,id) inner-h-t-m-l))
582
583 (defvar *help-topics*
584 (create
585 :user-role
586 (who-ps-html (:p "User role. \"Read\" can't write anything. \"Write\" may write user points and delete their own ones. \"Admin\" may write user points and delete points written by others."))
587 :presentation-project-name
588 (who-ps-html (:p "Presentation project name."))
589 :h2-controls
590 (who-ps-html (:p "Next action."))
591 :finish-point-button
592 (who-ps-html (:p "Store point with its attribute, description and numeric description into database. Afterwards, increment the numeric description if possible."))
593 :delete-point-button
594 (who-ps-html (:p "Delete current point."))
595 :point-attribute
596 (who-ps-html (:p "One of a few possible point attributes.")
597 (:p "TODO: currently only the hard-coded ones are available."))
598 :point-description
599 (who-ps-html (:p "Optional verbal description of point."))
600 :point-numeric-description
601 (who-ps-html (:p "Optional additional description of point. Preferrably numeric and if so, automatically incremented after finishing point."))
602 :point-creation-date
603 (who-ps-html (:p "Creation date of current point. Will be updated when you change this point."))
604 :creator
605 (who-ps-html (:p "Creator of current point. Will be updated when you change this point."))
606 :remove-work-layers-button
607 (who-ps-html (:p "Discard the current, unstored point but let the rest of the workspace untouched."))
608 :blurb-button
609 (who-ps-html (:p "View some info about phoros."))
610 :logout-button
611 (who-ps-html (:p "Finish this session. Fresh login is required to continue."))
612 :streetmap
613 (who-ps-html (:p "Clicking into the streetmap fetches images which most probably feature the clicked point.")
614 (:p "TODO: This is not quite so. Currently images taken from points nearest to the clicked one are displayed.")
615 (:p "To pan the map, drag the mouse. To zoom, spin the mouse wheel or hold shift down whilst dragging a box."))
616 :image
617 (who-ps-html (:p "Clicking into an image sets or resets the active point there. Once a feature is marked by active points in more than one image, the estimated position is calculated.")
618 (:p "To pan an image, drag the mouse. To zoom, spin the mouse wheel or hold shift down whilst dragging a box."))
619 ol-Control-Pan-West-Item-Inactive
620 (who-ps-html (:p "Move viewport left."))
621 ol-Control-Pan-East-Item-Inactive
622 (who-ps-html (:p "Move viewport right."))
623 ol-Control-Pan-North-Item-Inactive
624 (who-ps-html (:p "Move viewport up."))
625 ol-Control-Pan-South-Item-Inactive
626 (who-ps-html (:p "Move viewport down."))
627 ol-Control-Zoom-In-Item-Inactive
628 (who-ps-html (:p "Zoom in."))
629 ol-Control-Zoom-Out-Item-Inactive
630 (who-ps-html (:p "Zoom out."))
631 streetmap-Zoom-To-Max-Extent-Item-Inactive
632 (who-ps-html (:p "Zoom to the extent of presentation project."))
633 ol-Control-Zoom-To-Max-Extent-Item-Inactive
634 (who-ps-html (:p "Zoom out completely, restoring the original view."))
635 :image-layer-switcher
636 (who-ps-html (:p "Toggle display of image."))
637 :streetmap-layer-switcher
638 (who-ps-html (:p "Toggle visibility of data layers, or choose a background streetmap. (TODO: currently only one \"choice\")"))
639 :streetmap-overview
640 (who-ps-html (:p "Click to re-center streetmap, or drag the red rectangle."))
641 :streetmap-mouse-position
642 (who-ps-html (:p "Position in geographic coordinates when cursor is in streetmap."))
643 :h2-help
644 (who-ps-html (:p "Hints on Phoros' displays and controls are shown here while hovering over the respective elements."))))
645
646 (defun add-help-topic (topic element)
647 "Add mouse events to DOM element that initiate display of a
648 help message."
649 (when element
650 (setf (@ element onmouseover)
651 ((lambda (x)
652 (lambda () (show-help x)))
653 topic))
654 (setf (@ element onmouseout) show-help)))
655
656 (defun add-help-events ()
657 "Add mouse events to DOM elements that initiate display of a
658 help message."
659 (for-in
660 (topic *help-topics*)
661 (add-help-topic topic (chain document (get-element-by-id topic)))
662 (dolist (element (chain document (get-elements-by-class-name topic)))
663 (add-help-topic topic element))))
664
665 (defun show-help (&optional topic)
666 "Put text on topic into help-display"
667 (setf (inner-html-with-id "help-display")
668 (let ((help-body (getprop *help-topics* topic)))
669 (if (undefined help-body)
670 ""
671 help-body))))
672
673 (defvar *click-control*
674 (chain
675 *open-layers
676 (*class
677 (@ *open-layers *control)
678 (create
679 :default-handler-options
680 (create :single t
681 :double false
682 :pixel-tolerance 0
683 :stop-single false
684 :stop-double false)
685 :initialize
686 (lambda (options)
687 (setf
688 (@ this handler-options)
689 (chain *open-layers
690 *util
691 (extend
692 (create)
693 (@ this default-handler-options))))
694 (chain *open-layers
695 *control
696 prototype
697 initialize
698 (apply this arguments))
699 (setf (@ this handler)
700 (new (chain *open-layers
701 *handler
702 (*click this
703 (create
704 :click (@ this trigger))
705 (@ this handler-options))))))))))
706
707 (defvar +geographic+
708 (new (chain *open-layers (*projection "EPSG:4326"))))
709 (defvar +spherical-mercator+
710 (new (chain *open-layers (*projection "EPSG:900913"))))
711
712 (defvar +user-name+ (lisp (session-value 'user-name))
713 "User's (short) name")
714 (defvar +user-role+ (lisp (string-downcase (session-value 'user-role)))
715 "User's permissions")
716
717 (defvar +presentation-project-bounds+
718 (chain (new (chain *open-layers
719 *bounds
720 (from-string
721 (lisp (session-value 'presentation-project-bbox)))))
722 (transform +geographic+ +spherical-mercator+))
723 "Bounding box of the entire presentation project.")
724
725 (defvar *images* (array) "Collection of the photos currently shown.")
726 (defvar *streetmap* undefined
727 "The streetmap shown to the user.")
728 (defvar *streetmap-estimated-position-layer*)
729 (defvar *point-attributes-select* undefined
730 "The HTML element for selecting user point attributes.")
731
732 (defvar *global-position*
733 "Coordinates of the current estimated position")
734
735 (defvar *bbox-strategy* (chain *open-layers *strategy *bbox*))
736 (setf (chain *bbox-strategy* prototype ratio) 1.5)
737 (setf (chain *bbox-strategy* prototype res-factor) 1.5)
738
739 (defvar *json-parser* (new (chain *open-layers *format *json*)))
740
741 (defvar *geojson-format* (chain *open-layers *format *geo-j-s-o-n))
742 (setf (chain *geojson-format* prototype ignore-extra-dims) t) ;doesn't handle height anyway
743 (setf (chain *geojson-format* prototype external-projection) +geographic+)
744 (setf (chain *geojson-format* prototype internal-projection) +geographic+)
745
746 (defvar *http-protocol* (chain *open-layers *protocol *http*))
747 (setf (chain *http-protocol* prototype format) (new *geojson-format*))
748
749 (defvar *survey-layer*
750 (new (chain
751 *open-layers *layer
752 (*vector
753 "Survey"
754 (create
755 strategies (array (new (*bbox-strategy*)))
756 protocol
757 (new (*http-protocol*
758 (create :url "/phoros-lib/points"))))))))
759
760 (defvar *user-point-layer*
761 (new (chain
762 *open-layers *layer
763 (*vector
764 "User Points"
765 (create
766 strategies (array (new *bbox-strategy*))
767 protocol
768 (new (*http-protocol*
769 (create :url "/phoros-lib/user-points"))))))))
770
771 (defvar *pristine-images-p* t
772 "T if none of the current images has been clicked into yet.")
773
774 (defvar *current-user-point* undefined
775 "The currently selected user-point.")
776
777 (defvar *user-points-select-control*
778 (new (chain *open-layers *control (*select-feature *user-point-layer*))))
779 ;;(defvar google (new ((@ *open-layers *Layer *google) "Google Streets")))
780 (defvar *osm-layer* (new (chain *open-layers *layer (*osm*))))
781 (defvar *click-streetmap*
782 (new (*click-control* (create :trigger request-photos))))
783
784 (defun write-permission-p (&optional (current-owner +user-name+))
785 "Nil if current user can't edit stuff created by current-owner or, without arguments, new stuff."
786 (or (== +user-role+ "admin")
787 (and (== +user-role+ "write")
788 (== +user-name+ current-owner))))
789
790 (defun *image ()
791 "Anything necessary to deal with a photo."
792 (setf (getprop this 'map)
793 (new ((getprop *open-layers '*map)
794 (create projection +spherical-mercator+
795 all-overlays t
796 controls (array (new (chain *open-layers
797 *control
798 (*navigation))))))))
799 (setf (getprop this 'dummy) false) ;TODO why? (omitting splices map components directly into *image)
800 )
801
802 (setf (getprop *image 'prototype 'show-photo) show-photo)
803 (setf (getprop *image 'prototype 'draw-epipolar-line) draw-epipolar-line)
804 (setf (getprop *image 'prototype 'draw-active-point) draw-active-point)
805 (setf (getprop *image 'prototype 'draw-estimated-positions)
806 draw-estimated-positions)
807
808 (defun photo-path (photo-parameters)
809 "Create from stuff found in photo-parameters a path for use in
810 an image url."
811 (+ "/phoros-lib/photo/" (@ photo-parameters directory) "/"
812 (@ photo-parameters filename) "/"
813 (@ photo-parameters byte-position) ".png"))
814
815 (defun has-layer-p (map layer-name)
816 "False if map doesn't have a layer called layer-name."
817 (chain map (get-layers-by-name layer-name) length))
818
819 (defun some-active-point-p ()
820 "False if no image in *images* has an Active Point."
821 (loop
822 for i across *images*
823 sum (has-layer-p (getprop i 'map) "Active Point")))
824
825 (defun remove-layer (map layer-name)
826 "Destroy layer layer-name in map."
827 (when (has-layer-p map layer-name)
828 (chain map (get-layers-by-name layer-name) 0 (destroy))))
829
830 (defun remove-any-layers (layer-name)
831 "Destroy in all *images* and in *streetmap* the layer named layer-name."
832 (loop
833 for i across *images* do (remove-layer (getprop i 'map) layer-name))
834 (remove-layer *streetmap* layer-name))
835
836 (defun reset-controls ()
837 "Destroy user-generated layers in *streetmap* and in all *images*."
838 (disable-element-with-id "finish-point-button")
839 (disable-element-with-id "delete-point-button")
840 (disable-element-with-id "remove-work-layers-button")
841 (setf (inner-html-with-id "h2-controls") "Create Point")
842 (setf (inner-html-with-id "creator") nil)
843 (setf (inner-html-with-id "point-creation-date") nil))
844
845 (defun reset-layers-and-controls ()
846 (remove-any-layers "Epipolar Line")
847 (remove-any-layers "Active Point")
848 (remove-any-layers "Estimated Position")
849 (remove-any-layers "User Point")
850 (when (and (!= undefined *current-user-point*)
851 (chain *current-user-point* layer))
852 (chain *user-points-select-control* (unselect *current-user-point*)))
853 (reset-controls)
854 (setf *pristine-images-p* t)
855 )
856
857 (defun enable-element-with-id (id)
858 "Activate HTML element with id=\"id\"."
859 (setf (chain document (get-element-by-id id) disabled) nil))
860
861 (defun disable-element-with-id (id)
862 "Grey out HTML element with id=\"id\"."
863 (setf (chain document (get-element-by-id id) disabled) t))
864
865 (defmacro value-with-id (id)
866 "Value of element with id=\"id\"."
867 `(chain document (get-element-by-id ,id) value))
868
869 (defun refresh-layer (layer)
870 "Have layer re-request and redraw features."
871 (chain layer (refresh (create :force t))))
872
873 (defun present-photos ()
874 "Handle the response triggered by request-photos."
875 (let ((photo-parameters
876 (chain *json-parser*
877 (read (@ photo-request-response response-text)))))
878 (loop
879 for p across photo-parameters
880 for i across *images*
881 do
882 (setf (getprop i 'photo-parameters) p)
883 ((getprop i 'show-photo)))
884 ;; (setf (@ (aref photo-parameters 0) angle180) 1) ; Debug: coordinate flipping
885 ))
886
887 (defun request-photos (event)
888 "Handle the response to a click into *streetmap*; fetch photo data."
889 (disable-element-with-id "finish-point-button")
890 (disable-element-with-id "remove-work-layers-button")
891 (remove-any-layers "Estimated Position")
892 (let* ((lonlat
893 ((@ ((@ *streetmap* get-lon-lat-from-pixel) (@ event xy)) transform)
894 +spherical-mercator+ ; why?
895 +geographic+))
896 (content
897 (chain *json-parser*
898 (write
899 (create :longitude (@ lonlat lon)
900 :latitude (@ lonlat lat)
901 :zoom ((@ *streetmap* get-zoom))
902 :count (lisp *number-of-images*))))))
903 (setf photo-request-response
904 ((@ *open-layers *Request *POST*)
905 (create :url "/phoros-lib/local-data"
906 :data content
907 :headers (create "Content-type" "text/plain"
908 "Content-length" (@ content length))
909 :success present-photos)))))
910
911 (defun draw-epipolar-line ()
912 "Draw an epipolar line from response triggered by clicking
913 into a (first) photo."
914 (enable-element-with-id "remove-work-layers-button")
915 (let* ((epipolar-line
916 (chain *json-parser*
917 (read
918 (@ this epipolar-request-response response-text))))
919 (points
920 (chain epipolar-line
921 (map (lambda (x)
922 (new ((@ *open-layers *geometry *point)
923 (@ x :m) (@ x :n)))))))
924 (feature
925 (new (chain *open-layers
926 *feature
927 (*vector
928 (new (chain
929 *open-layers
930 *geometry
931 (*line-string points))))))))
932 (setf (chain feature render-intent) "temporary")
933 (chain this epipolar-layer
934 (add-features feature))))
935 ;; either *line-string or *multi-point are usable
936
937 (defun draw-estimated-positions ()
938 "Draw into streetmap and into all images points at Estimated
939 Position. Estimated Position is the point returned so far from
940 photogrammetric calculations that are triggered by clicking into
941 another photo."
942 (when (write-permission-p)
943 (setf (chain document
944 (get-element-by-id "finish-point-button")
945 onclick)
946 finish-point)
947 (enable-element-with-id "finish-point-button"))
948 (let* ((estimated-positions-request-response
949 (chain *json-parser*
950 (read
951 (getprop this
952 'estimated-positions-request-response
953 'response-text))))
954 (estimated-positions
955 (aref estimated-positions-request-response 1)))
956 (setf *global-position*
957 (aref estimated-positions-request-response 0))
958 (let ((feature
959 (new ((@ *open-layers *feature *vector)
960 ((@ (new ((@ *open-layers *geometry *point)
961 (getprop *global-position* 'longitude)
962 (getprop *global-position* 'latitude)))
963 transform) +geographic+ +spherical-mercator+)))))
964 (setf (chain feature render-intent) "temporary")
965 (setf *streetmap-estimated-position-layer*
966 (new (chain *open-layers
967 *layer
968 (*vector "Estimated Position"
969 (create display-in-layer-switcher nil)))))
970 (chain *streetmap-estimated-position-layer*
971 (add-features feature))
972 (chain *streetmap* (add-layer *streetmap-estimated-position-layer*)))
973 (let ((estimated-position-style
974 (create stroke-color (chain *open-layers *feature *vector
975 style "temporary" stroke-color)
976 point-radius 9
977 fill-opacity 0)))
978 (loop
979 for i in *images*
980 for p in estimated-positions
981 do
982 (when i ;otherwise a photogrammetry error has occured
983 (setf (@ i estimated-position-layer)
984 (new
985 (chain *open-layers *layer
986 (*vector "Estimated Position"
987 (create display-in-layer-switcher nil)))))
988 (setf (chain i estimated-position-layer style)
989 estimated-position-style)
990 (let* ((point
991 (new
992 (chain *open-layers *geometry (*point
993 (getprop p 'm)
994 (getprop p 'n)))))
995 (feature
996 (new
997 (chain *open-layers *feature (*vector point)))))
998 (chain i map
999 (add-layer (@ i estimated-position-layer)))
1000 (chain i estimated-position-layer
1001 (add-features feature))))))))
1002
1003 (defun draw-user-point ()
1004 "Draw currently selected user point into all images."
1005 (let* ((user-point-in-images
1006 (chain *json-parser*
1007 (read
1008 (getprop *user-point-in-images-response*
1009 'response-text)))))
1010 (loop
1011 for i in *images*
1012 for p in user-point-in-images
1013 do
1014 (when i ;otherwise a photogrammetry error has occured
1015 (setf (@ i user-point-layer)
1016 (new (chain *open-layers
1017 *layer
1018 (*vector "User Point"
1019 (create display-in-layer-switcher nil)))))
1020 (let* ((point
1021 (new (chain *open-layers *geometry (*point
1022 (getprop p 'm)
1023 (getprop p 'n)))))
1024 (feature
1025 (new (chain *open-layers *feature (*vector point)))))
1026 (setf (chain feature render-intent) "select")
1027 (chain i map (add-layer (@ i user-point-layer)))
1028 (chain i user-point-layer (add-features feature)))))))
1029
1030 (defun finish-point ()
1031 "Send current *global-position* as a user point to the database."
1032 (let ((global-position-etc *global-position*))
1033 (setf (chain global-position-etc attribute)
1034 (chain
1035 (elt (chain *point-attributes-select* options)
1036 (chain *point-attributes-select* options selected-index))
1037 text))
1038 (setf (chain global-position-etc description)
1039 (value-with-id "point-description"))
1040 (setf (chain global-position-etc numeric-description)
1041 (value-with-id "point-numeric-description"))
1042 (let ((content
1043 (chain *json-parser*
1044 (write global-position-etc))))
1045 ((@ *open-layers *Request *POST*)
1046 (create :url "/phoros-lib/store-point"
1047 :data content
1048 :headers (create "Content-type" "text/plain"
1049 "Content-length" (@ content length))
1050 :success (lambda ()
1051 (refresh-layer *user-point-layer*)
1052 (reset-layers-and-controls)))))
1053 (let* ((previous-numeric-description ;increment if possible
1054 (chain global-position-etc numeric-description))
1055 (current-numeric-description
1056 (1+ (parse-int previous-numeric-description 10))))
1057 (setf (value-with-id "point-numeric-description")
1058 (if (is-finite current-numeric-description)
1059 current-numeric-description
1060 previous-numeric-description)))))
1061
1062 (defun update-point ()
1063 "Send changes to currently selected user point to database."
1064 (let* ((point-data
1065 (create user-point-id (chain *current-user-point* fid)
1066 attribute
1067 (chain
1068 (elt (chain *point-attributes-select* options)
1069 (chain *point-attributes-select* options selected-index))
1070 text)
1071 description
1072 (value-with-id "point-description")
1073 numeric-description
1074 (value-with-id "point-numeric-description")))
1075 (content
1076 (chain *json-parser*
1077 (write point-data))))
1078 ((@ *open-layers *Request *POST*)
1079 (create :url "/phoros-lib/update-point"
1080 :data content
1081 :headers (create "Content-type" "text/plain"
1082 "Content-length" (@ content length))
1083 :success (lambda ()
1084 (refresh-layer *user-point-layer*)
1085 (reset-layers-and-controls))))))
1086
1087 (defun delete-point ()
1088 "Purge currently selected user point from database."
1089 (let ((user-point-id (chain *current-user-point* fid)))
1090 (setf content
1091 (chain *json-parser*
1092 (write user-point-id)))
1093 ((@ *open-layers *Request *POST*)
1094 (create :url "/phoros-lib/delete-point"
1095 :data content
1096 :headers (create "Content-type" "text/plain"
1097 "Content-length" (@ content length))
1098 :success (lambda ()
1099 (refresh-layer *user-point-layer*)
1100 (reset-layers-and-controls))))))
1101
1102 (defun draw-active-point ()
1103 "Draw an Active Point, i.e. a point used in subsequent
1104 photogrammetric calculations."
1105 (chain this active-point-layer
1106 (add-features
1107 (new ((@ *open-layers *feature *vector)
1108 (new ((@ *open-layers *geometry *point)
1109 (getprop this 'photo-parameters 'm)
1110 (getprop this 'photo-parameters 'n))))))))
1111
1112 (defun image-click-action (clicked-image)
1113 (lambda (event)
1114 "Do appropriate things when an image is clicked into."
1115 (let* ((lonlat
1116 ((@ (@ clicked-image map) get-lon-lat-from-view-port-px)
1117 (@ event xy)))
1118 (photo-parameters
1119 (getprop clicked-image 'photo-parameters))
1120 pristine-image-p content request)
1121 (setf (@ photo-parameters m) (@ lonlat lon)
1122 (@ photo-parameters n) (@ lonlat lat))
1123 (remove-layer (getprop clicked-image 'map) "Active Point")
1124 (remove-any-layers "Epipolar Line")
1125 (setf *pristine-images-p* (not (some-active-point-p)))
1126 (setf (@ clicked-image active-point-layer)
1127 (new (chain *open-layers
1128 *layer
1129 (*vector "Active Point"
1130 (create display-in-layer-switcher nil)))))
1131 ((@ clicked-image map add-layer)
1132 (@ clicked-image active-point-layer))
1133 ((getprop clicked-image 'draw-active-point))
1134 (if
1135 *pristine-images-p*
1136 (progn
1137 (reset-controls)
1138 (remove-any-layers "User Point") ;from images
1139 (when (and (!= undefined *current-user-point*)
1140 (chain *current-user-point* layer))
1141 (chain *user-points-select-control* (unselect *current-user-point*)))
1142 (loop
1143 for i across *images* do
1144 (unless (== i clicked-image)
1145 (setf
1146 (@ i epipolar-layer)
1147 (new (chain *open-layers
1148 *layer
1149 (*vector "Epipolar Line"
1150 (create display-in-layer-switcher nil))))
1151 content (chain *json-parser*
1152 (write
1153 (append (array photo-parameters)
1154 (@ i photo-parameters))))
1155 (@ i epipolar-request-response)
1156 ((@ *open-layers *Request *POST*)
1157 (create :url "/phoros-lib/epipolar-line"
1158 :data content
1159 :headers (create "Content-type" "text/plain"
1160 "Content-length"
1161 (@ content length))
1162 :success (getprop i 'draw-epipolar-line)
1163 :scope i)))
1164 ((@ i map add-layer) (@ i epipolar-layer)))))
1165 (progn
1166 (remove-any-layers "Epipolar Line")
1167 (remove-any-layers "Estimated Position")
1168 (let* ((active-pointed-photo-parameters
1169 (loop
1170 for i across *images*
1171 when (has-layer-p (getprop i 'map) "Active Point")
1172 collect (getprop i 'photo-parameters)))
1173 (content
1174 (chain *json-parser*
1175 (write
1176 (list active-pointed-photo-parameters
1177 (chain *images*
1178 (map #'(lambda (x)
1179 (getprop
1180 x 'photo-parameters)))))))))
1181 (setf (@ clicked-image estimated-positions-request-response)
1182 ((@ *open-layers *Request *POST*)
1183 (create :url "/phoros-lib/estimated-positions"
1184 :data content
1185 :headers (create "Content-type" "text/plain"
1186 "Content-length"
1187 (@ content length))
1188 :success (getprop clicked-image
1189 'draw-estimated-positions)
1190 :scope clicked-image)))))))))
1191
1192 (defun show-photo ()
1193 "Show the photo described in this object's photo-parameters."
1194 (loop
1195 repeat ((getprop this 'map 'get-num-layers))
1196 do ((getprop this 'map 'layers 0 'destroy)))
1197 ((getprop this 'map 'add-layer)
1198 (new ((@ *open-layers *layer *image)
1199 "Photo"
1200 (photo-path (getprop this 'photo-parameters))
1201 (new ((@ *open-layers *bounds) -.5 -.5
1202 (+ (getprop this 'photo-parameters 'sensor-width-pix)
1203 .5)
1204 (+ (getprop this 'photo-parameters 'sensor-height-pix)
1205 .5))) ; coordinates shown
1206 (new ((@ *open-layers *size) 512 256))
1207 (create))))
1208 (chain this map (zoom-to-max-extent)))
1209
1210 (defun initialize-image (image-index)
1211 "Create an image usable for displaying photos at position
1212 image-index in array *images*."
1213 (setf (aref *images* image-index) (new *image))
1214 (setf (@ (aref *images* image-index) image-click-action)
1215 (image-click-action (aref *images* image-index)))
1216 (setf (@ (aref *images* image-index) click)
1217 (new (*click-control*
1218 (create :trigger (@ (aref *images* image-index)
1219 image-click-action)))))
1220 (chain (aref *images* image-index)
1221 map
1222 (add-control
1223 (@ (aref *images* image-index) click)))
1224 (chain (aref *images* image-index) click (activate))
1225 ;;(chain (aref *images* image-index)
1226 ;; map
1227 ;; (add-control
1228 ;; (new (chain *open-layers
1229 ;; *control
1230 ;; (*mouse-position
1231 ;; (create
1232 ;; div (chain
1233 ;; document
1234 ;; (get-element-by-id
1235 ;; (+ "image-" image-index "-zoom")))))))))
1236 (chain (aref *images* image-index)
1237 map
1238 (add-control
1239 (new (chain *open-layers
1240 *control
1241 (*layer-switcher
1242 (create
1243 div (chain
1244 document
1245 (get-element-by-id
1246 (+ "image-" image-index "-layer-switcher")))
1247 rounded-corner nil))))))
1248 (let ((pan-west-control
1249 (new (chain *open-layers *control (*pan "West"))))
1250 (pan-north-control
1251 (new (chain *open-layers *control (*pan "North"))))
1252 (pan-south-control
1253 (new (chain *open-layers *control (*pan "South"))))
1254 (pan-east-control
1255 (new (chain *open-layers *control (*pan "East"))))
1256 (zoom-in-control
1257 (new (chain *open-layers *control (*zoom-in))))
1258 (zoom-out-control
1259 (new (chain *open-layers *control (*zoom-out))))
1260 (zoom-to-max-extent-control
1261 (new (chain *open-layers *control (*zoom-to-max-extent))))
1262 (pan-zoom-panel
1263 (new (chain *open-layers
1264 *control
1265 (*panel
1266 (create div
1267 (chain
1268 document
1269 (get-element-by-id
1270 (+ "image-" image-index "-zoom")))))))))
1271 (chain (aref *images* image-index) map (add-control pan-zoom-panel))
1272 (chain pan-zoom-panel (add-controls (array pan-west-control
1273 pan-north-control
1274 pan-south-control
1275 pan-east-control
1276 zoom-in-control
1277 zoom-out-control
1278 zoom-to-max-extent-control))))
1279 (chain (aref *images* image-index)
1280 map
1281 (render (chain document
1282 (get-element-by-id
1283 (+ "image-" image-index))))))
1284
1285 (defun user-point-selected (event)
1286 (setf *current-user-point* (chain event feature))
1287 (remove-any-layers "Active Point")
1288 (remove-any-layers "Epipolar Line")
1289 (remove-any-layers "Estimated Position")
1290 (remove-any-layers "User Point")
1291 (if (write-permission-p (chain event feature attributes user-name))
1292 (progn
1293 (setf (chain document (get-element-by-id "finish-point-button") onclick) update-point)
1294 (enable-element-with-id "finish-point-button")
1295 (enable-element-with-id "delete-point-button")
1296 (setf (inner-html-with-id "h2-controls") "Edit Point"))
1297 (progn
1298 (disable-element-with-id "finish-point-button")
1299 (disable-element-with-id "delete-point-button")
1300 (setf (inner-html-with-id "h2-controls") "View Point")))
1301 (setf (inner-html-with-id "creator")
1302 (+ "(by " (chain event feature attributes user-name) ")"))
1303 (setf (value-with-id "point-attribute") (chain event feature attributes attribute))
1304 (setf (value-with-id "point-description") (chain event feature attributes description))
1305 (setf (value-with-id "point-numeric-description") (chain event feature attributes numeric-description))
1306 (setf (inner-html-with-id "point-creation-date") (chain event feature attributes creation-date))
1307 (setf content
1308 (chain *json-parser*
1309 (write
1310 (array (chain event feature fid)
1311 (loop
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"
1317 :data content
1318 :headers (create "Content-type" "text/plain"
1319 "Content-length" (@ content length))
1320 :success draw-user-point))))
1321
1322 (defun init ()
1323 "Prepare user's playground."
1324 (when (write-permission-p)
1325 (enable-element-with-id "point-attribute")
1326 (enable-element-with-id "point-description")
1327 (enable-element-with-id "point-numeric-description")
1328 (setf (inner-html-with-id "h2-controls") "Create Point"))
1329 (setf *point-attributes-select* (chain document (get-element-by-id "point-attribute")))
1330
1331 (loop for i in '("solitary" "polyline" "polygon") do
1332 (setf point-attribute-item (chain document (create-element "option")))
1333 (setf (chain point-attribute-item text) i)
1334 (chain *point-attributes-select* (add point-attribute-item null))) ;TODO: input of user-defined attributes
1335 (setf *streetmap*
1336 (new (chain
1337 *open-layers
1338 (*map "streetmap"
1339 (create projection +geographic+
1340 display-projection +geographic+
1341 controls (array (new (chain *open-layers
1342 *control
1343 (*navigation)))
1344 (new (chain *open-layers
1345 *control
1346 (*attribution)))))))))
1347
1348
1349 (chain *streetmap*
1350 (add-control
1351 (new (chain *open-layers
1352 *control
1353 (*layer-switcher
1354 (create
1355 div (chain
1356 document
1357 (get-element-by-id
1358 "streetmap-layer-switcher"))
1359 rounded-corner nil))))))
1360 (let ((pan-west-control
1361 (new (chain *open-layers *control (*pan "West"))))
1362 (pan-north-control
1363 (new (chain *open-layers *control (*pan "North"))))
1364 (pan-south-control
1365 (new (chain *open-layers *control (*pan "South"))))
1366 (pan-east-control
1367 (new (chain *open-layers *control (*pan "East"))))
1368 (zoom-in-control
1369 (new (chain *open-layers *control (*zoom-in))))
1370 (zoom-out-control
1371 (new (chain *open-layers *control (*zoom-out))))
1372 (zoom-to-max-extent-control
1373 (new (chain
1374 *open-layers
1375 *control
1376 (*button
1377 (create
1378 display-class "streetmapZoomToMaxExtent"
1379 trigger (lambda ()
1380 (chain *streetmap*
1381 (zoom-to-extent
1382 +presentation-project-bounds+ ))))))))
1383 (pan-zoom-panel
1384 (new (chain *open-layers
1385 *control
1386 (*panel
1387 (create div
1388 (chain
1389 document
1390 (get-element-by-id
1391 "streetmap-zoom")))))))
1392 (overview-map
1393 (new (chain *open-layers
1394 *control
1395 (*overview-map
1396 (create
1397 min-ratio 14
1398 max-ratio 16
1399 div (chain document
1400 (get-element-by-id
1401 "streetmap-overview")))))))
1402 (mouse-position-control
1403 (new (chain *open-layers
1404 *control
1405 (*mouse-position
1406 (create div (chain document
1407 (get-element-by-id
1408 "streetmap-mouse-position"))
1409 empty-string "longitude, latitude"))))))
1410 (chain *streetmap* (add-control pan-zoom-panel))
1411 (chain pan-zoom-panel
1412 (add-controls (array pan-west-control
1413 pan-north-control
1414 pan-south-control
1415 pan-east-control
1416 zoom-in-control
1417 zoom-out-control
1418 zoom-to-max-extent-control)))
1419 (chain *streetmap* (add-control *click-streetmap*))
1420 (chain *click-streetmap* (activate))
1421
1422 (chain *user-point-layer*
1423 events
1424 (register "featureselected"
1425 *user-point-layer* user-point-selected))
1426 (chain *user-point-layer*
1427 events
1428 (register "featureunselected"
1429 *user-point-layer* reset-controls))
1430 (chain *streetmap* (add-control *user-points-select-control*))
1431 (chain *user-points-select-control* (activate))
1432
1433 (chain *streetmap* (add-layer *osm-layer*))
1434 ;;(chain *streetmap* (add-layer *google*))
1435 (chain *streetmap* (add-layer *survey-layer*))
1436 (chain *streetmap* (add-layer *user-point-layer*))
1437 (setf (chain overview-map element)
1438 (chain document (get-element-by-id
1439 "streetmap-overview-element")))
1440 (chain *streetmap* (add-control overview-map))
1441 (chain *streetmap*
1442 (zoom-to-extent +presentation-project-bounds+))
1443 (chain *streetmap* (add-control mouse-position-control)))
1444 (loop
1445 for i from 0 to (lisp (1- *number-of-images*))
1446 do (initialize-image i))
1447 (add-help-events)))))
1448
1449 (define-easy-handler
1450 (view :uri "/phoros-lib/view" :default-request-type :post) ()
1451 "Serve the client their main workspace."
1452 (if
1453 (session-value 'authenticated-p)
1454 (who:with-html-output-to-string (s nil :indent t)
1455 (:html
1456 :xmlns "http://www.w3.org/1999/xhtml"
1457 (:head
1458 (:title (who:str
1459 (concatenate
1460 'string
1461 "Phoros: " (session-value 'presentation-project-name))))
1462 (if *use-multi-file-openlayers*
1463 (who:htm
1464 (:script :src "/phoros-lib/openlayers/lib/Firebug/firebug.js")
1465 (:script :src "/phoros-lib/openlayers/lib/OpenLayers.js")
1466 ;;(:script :src "/phoros-lib/openlayers/lib/proj4js.js") ;TODO: we don't seem to use this
1467 )
1468 (who:htm (:script :src "/phoros-lib/ol/OpenLayers.js")))
1469 (:link :rel "stylesheet" :href "/phoros-lib/css/style.css" :type "text/css")
1470 (:script :src "/phoros-lib/phoros.js")
1471 ;;(:script :src "http://maps.google.com/maps/api/js?sensor=false")
1472 )
1473 (:body
1474 :onload (ps (init))
1475 (:h1 :id "title"
1476 "Phoros: " (who:str (session-value 'user-full-name))
1477 (who:fmt " (~A)" (session-value 'user-name))
1478 "with " (:span :id "user-role"
1479 (who:str (session-value 'user-role)))
1480 "permission on "
1481 (:span :id "presentation-project-name"
1482 (who:str (session-value 'presentation-project-name))))
1483 (:div :class "controlled-streetmap"
1484 (:div :id "streetmap-controls" :class "streetmap-controls"
1485 (:div :class "streetmap-zoom-and-layer-switcher"
1486 (:div :id "streetmap-layer-switcher"
1487 :class "streetmap-layer-switcher")
1488 (:div :id "streetmap-zoom" :class "streetmap-zoom"))
1489 (:div :id "streetmap-overview" :class "streetmap-overview")
1490 (:div :id "streetmap-empty-space" :class "streetmap-empty-space")
1491 (:div :id "streetmap-mouse-position" :class "streetmap-mouse-position"))
1492 (:div :id "streetmap" :class "smallmap" :style "cursor:crosshair"))
1493 (:div :class "phoros-controls"
1494 (:button :id "blurb-button"
1495 :type "button"
1496 :onclick "self.location.href = \"/phoros-lib/blurb\""
1497 "blurb")
1498 (:button :id "logout-button"
1499 :type "button"
1500 :onclick "self.location.href = \"/phoros-lib/logout\""
1501 "bye")
1502 :br
1503 (:button :id "remove-work-layers-button" :disabled t
1504 :type "button" :onclick (ps-inline (reset-layers-and-controls))
1505 "start over")
1506 (:h2 (:span :id "h2-controls") (:span :id "creator"))
1507 (:small (:code :id "point-creation-date"))
1508 :br
1509 (:select :id "point-attribute" :disabled t
1510 :size 1 :name "point-attribute")
1511 (:input :id "point-numeric-description" :disabled t
1512 :type "text" :size 6 :name "point-numeric-description")
1513 :br
1514 (:input :id "point-description" :disabled t
1515 :type "text" :size 20 :name "point-description")
1516 :br
1517 (:button :disabled t :id "finish-point-button"
1518 :type "button"
1519 "finish")
1520 (:button :id "delete-point-button" :disabled t
1521 :type "button" :onclick (ps-inline (delete-point))
1522 "delete"))
1523 (:div :class "smalltext"
1524 (:h2 :id "h2-help" "Help")
1525 (:div :id "help-display"))
1526 (:div :id "images" :style "clear:both"
1527 (loop
1528 for i from 0 below *number-of-images* do
1529 (who:htm
1530 (:div :class "controlled-image"
1531 (:div :id (format nil "image-~S-controls" i)
1532 :class "image-controls"
1533 (:div :id (format nil "image-~S-zoom" i)
1534 :class "image-zoom")
1535 (:div :id (format nil "image-~S-layer-switcher" i)
1536 :class "image-layer-switcher"))
1537 (:div :id (format nil "image-~S" i)
1538 :class "image" :style "cursor:crosshair"))))))))
1539 (redirect
1540 (concatenate 'string "/phoros/" (session-value 'presentation-project-name))
1541 :add-session-id t)))
1542
1543 (define-easy-handler (epipolar-line :uri "/phoros-lib/epipolar-line") ()
1544 "Receive vector of two sets of picture parameters, respond with
1545 JSON encoded epipolar-lines."
1546 (when (session-value 'authenticated-p)
1547 (let* ((data (json:decode-json-from-string (raw-post-data))))
1548 (json:encode-json-to-string
1549 (photogrammetry :epipolar-line (first data) (second data))))))
1550
1551 (define-easy-handler
1552 (estimated-positions :uri "/phoros-lib/estimated-positions")
1553 ()
1554 "Receive a two-part JSON vector comprising (1) a vector containing
1555 sets of picture-parameters including clicked (\"active\") points
1556 stored in :m, :n; and (2) a vector containing sets of
1557 picture-parameters; respond with a JSON encoded two-part vector
1558 comprising (1) a point in global coordinates; and (2) a vector of
1559 image coordinates (m, n) for the global point that correspond to the
1560 images from the received second vector. TODO: report error on bad
1561 data (ex: points too far apart)."
1562 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1563 (when (session-value 'authenticated-p)
1564 (let* ((data (json:decode-json-from-string (raw-post-data)))
1565 (active-point-photo-parameters (first data))
1566 (destination-photo-parameters (second data))
1567 (cartesian-system (cdr (assoc :cartesian-system (first active-point-photo-parameters))))
1568 (global-point-cartesian (photogrammetry :multi-position-intersection active-point-photo-parameters))
1569 (global-point-geographic-radians
1570 (proj:cs2cs (list (cdr (assoc :x-global global-point-cartesian))
1571 (cdr (assoc :y-global global-point-cartesian))
1572 (cdr (assoc :z-global global-point-cartesian)))
1573 :source-cs cartesian-system))
1574 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1575 (pairlis '(:longitude :latitude :ellipsoid-height
1576 :stdx-global :stdy-global :stdz-global)
1577 (list
1578 (proj:radians-to-degrees (first global-point-geographic-radians))
1579 (proj:radians-to-degrees (second global-point-geographic-radians))
1580 (third global-point-geographic-radians)
1581 (cdr (assoc :stdx-global global-point-cartesian))
1582 (cdr (assoc :stdy-global global-point-cartesian))
1583 (cdr (assoc :stdz-global global-point-cartesian)))))
1584 (image-coordinates
1585 (loop
1586 for i in destination-photo-parameters
1587 collect
1588 (ignore-errors
1589 (photogrammetry :reprojection i global-point-cartesian)))))
1590 (json:encode-json-to-string
1591 (list global-point-for-display image-coordinates)))))
1592
1593 (define-easy-handler
1594 (user-point-positions :uri "/phoros-lib/user-point-positions")
1595 ()
1596 "Receive a two-part JSON vector comprising (1) a user-point-id and
1597 \(2) a vector containing sets of picture-parameters; respond with a
1598 JSON encoded vector of image coordinates (m, n) for the global
1599 coordinates of the user point with user-point-id that correspond to
1600 the images from the received image vector."
1601 (when (session-value 'authenticated-p)
1602 (let* ((user-point-table-name
1603 (user-point-table-name (session-value 'presentation-project-name)))
1604 (data (json:decode-json-from-string (raw-post-data)))
1605 (user-point-id (first data))
1606 (destination-photo-parameters (second data))
1607 (cartesian-system (cdr (assoc :cartesian-system (first destination-photo-parameters)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1608 (global-point-geographic
1609 (with-connection *postgresql-credentials*
1610 (query
1611 (:select
1612 (:as
1613 (:st_x (:st_transform 'coordinates *standard-coordinates*))
1614 'x-global)
1615 (:as
1616 (:st_y (:st_transform 'coordinates *standard-coordinates*))
1617 'y-global)
1618 (:as
1619 (:st_z (:st_transform 'coordinates *standard-coordinates*))
1620 'z-global)
1621 :from user-point-table-name
1622 :where (:= 'user-point-id user-point-id))
1623 :list)))
1624 (global-point-cartesian
1625 (pairlis '(:x-global :y-global :z-global)
1626 (proj:cs2cs
1627 (list
1628 (proj:degrees-to-radians (first global-point-geographic))
1629 (proj:degrees-to-radians (second global-point-geographic))
1630 (third global-point-geographic))
1631 :destination-cs cartesian-system)))
1632 (image-coordinates
1633 (loop
1634 for i in destination-photo-parameters
1635 collect
1636 (ignore-errors
1637 (photogrammetry :reprojection i global-point-cartesian)))))
1638 (json:encode-json-to-string
1639 image-coordinates))))
1640
1641 (define-easy-handler (multi-position-intersection :uri "/phoros-lib/intersection") ()
1642 "Receive vector of sets of picture parameters, respond with stuff."
1643 (when (session-value 'authenticated-p)
1644 (let* ((data (json:decode-json-from-string (raw-post-data))))
1645 (json:encode-json-to-string (photogrammetry :multi-position-intersection data)))))
1646
1647 (defgeneric photogrammetry (mode photo-1 &optional photo-2)
1648 (:documentation "Call to photogrammetry library. Dispatch on mode."))
1649
1650 (defmethod photogrammetry :around (mode clicked-photo &optional other-photo)
1651 "Prepare and clean up a run of photogrammetry."
1652 (declare (ignore other-photo))
1653 (bt:with-lock-held (*photogrammetry-mutex*)
1654 (del-all)
1655 (unwind-protect
1656 (call-next-method)
1657 (del-all))))
1658
1659 (defmethod photogrammetry ((mode (eql :epipolar-line)) clicked-photo &optional other-photo)
1660 "Return in an alist an epipolar line in coordinates of other-photo from m and n in clicked-photo."
1661 (add-cam* clicked-photo)
1662 (add-bpoint* clicked-photo)
1663 (add-global-car-reference-point* clicked-photo t)
1664 (add-cam* other-photo)
1665 (add-global-car-reference-point* other-photo t)
1666 (loop
1667 for i = 2d0 then (* i 1.4) until (> i 50)
1668 do
1669 (set-distance-for-epipolar-line i)
1670 when (ignore-errors (calculate))
1671 collect (pairlis '(:m :n) (list (flip-m-maybe (get-m) other-photo)
1672 (flip-n-maybe (get-n) other-photo)))))
1673
1674 (defmethod photogrammetry ((mode (eql :reprojection)) photo &optional global-point)
1675 "Calculate reprojection from photo."
1676 (add-cam* photo)
1677 (add-global-measurement-point* global-point)
1678 (add-global-car-reference-point* photo)
1679 (set-global-reference-frame)
1680 (calculate)
1681 (pairlis '(:m :n)
1682 (list (flip-m-maybe (get-m) photo) (flip-n-maybe (get-n) photo))))
1683
1684 (defmethod photogrammetry ((mode (eql :multi-position-intersection)) photos &optional other-photo)
1685 "Calculate intersection from photos."
1686 (declare (ignore other-photo))
1687 (set-global-reference-frame)
1688 (loop
1689 for photo in photos
1690 do
1691 (add-cam* photo)
1692 (add-bpoint* photo)
1693 (add-global-car-reference-point* photo t))
1694 (calculate)
1695 (pairlis '(:x-global :y-global :z-global
1696 :stdx-global :stdy-global :stdz-global)
1697 (list
1698 (get-x-global) (get-y-global) (get-z-global)
1699 (get-stdx-global) (get-stdy-global) (get-stdz-global))))
1700
1701 (defmethod photogrammetry ((mode (eql :intersection)) photo &optional other-photo)
1702 "Calculate intersection from two photos that are taken out of the
1703 same local coordinate system. (Used for debugging only)."
1704 (add-cam* photo)
1705 (add-bpoint* photo)
1706 (add-cam* other-photo)
1707 (add-bpoint* other-photo)
1708 (calculate)
1709 (pairlis '(:x-local :y-local :z-local
1710 :stdx-local :stdy-local :stdz-local)
1711 (list
1712 (get-x-local) (get-y-local) (get-z-local)
1713 (get-stdx-local) (get-stdy-local) (get-stdz-local)
1714 (get-x-global) (get-y-global) (get-z-global))))
1715
1716 (defmethod photogrammetry ((mode (eql :mono)) photo &optional floor)
1717 "Return in an alist the intersection point of the ray through m and n in photo, and floor."
1718 (add-cam* photo)
1719 (add-bpoint* photo)
1720 (add-ref-ground-surface* floor)
1721 (add-global-car-reference-point* photo)
1722 (set-global-reference-frame)
1723 (calculate)
1724 (pairlis '(:x-global :y-global :z-global)
1725 (list
1726 (get-x-global) (get-y-global) (get-z-global))))
1727
1728 (defun flip-m-maybe (m photo)
1729 "Flip coordinate m when :mounting-angle in photo suggests it necessary."
1730 (if (= 180 (cdr (assoc :mounting-angle photo)))
1731 (- (cdr (assoc :sensor-width-pix photo)) m)
1732 m))
1733 (defun flip-n-maybe (n photo)
1734 "Flip coordinate n when :mounting-angle in photo suggests it necessary."
1735 (if (zerop (cdr (assoc :mounting-angle photo)))
1736 (- (cdr (assoc :sensor-height-pix photo)) n)
1737 n))
1738
1739 (defun photogrammetry-arglist (alist &rest keys)
1740 "Construct an arglist from alist values corresponding to keys."
1741 (mapcar #'(lambda (x) (cdr (assoc x alist))) keys))
1742
1743 (defun add-cam* (photo-alist)
1744 "Call add-cam with arguments taken from photo-alist."
1745 (let ((integer-args
1746 (photogrammetry-arglist
1747 photo-alist :sensor-height-pix :sensor-width-pix))
1748 (double-float-args
1749 (mapcar #'(lambda (x) (coerce x 'double-float))
1750 (photogrammetry-arglist photo-alist
1751 :pix-size
1752 :dx :dy :dz :omega :phi :kappa
1753 :c :xh :yh
1754 :a-1 :a-2 :a-3 :b-1 :b-2 :c-1 :c-2 :r-0
1755 :b-dx :b-dy :b-dz :b-ddx :b-ddy :b-ddz
1756 :b-rotx :b-roty :b-rotz
1757 :b-drotx :b-droty :b-drotz))))
1758 (apply #'add-cam (nconc integer-args double-float-args))))
1759
1760 (defun add-bpoint* (photo-alist)
1761 "Call add-bpoint with arguments taken from photo-alist."
1762 (add-bpoint (coerce (flip-m-maybe (cdr (assoc :m photo-alist)) photo-alist) 'double-float)
1763 (coerce (flip-n-maybe (cdr (assoc :n photo-alist)) photo-alist) 'double-float)))
1764
1765 (defun add-ref-ground-surface* (floor-alist)
1766 "Call add-ref-ground-surface with arguments taken from floor-alist."
1767 (let ((double-float-args
1768 (mapcar #'(lambda (x) (coerce x 'double-float))
1769 (photogrammetry-arglist floor-alist
1770 :nx :ny :nz :d))))
1771 (apply #'add-ref-ground-surface double-float-args)))
1772
1773 (defun add-global-car-reference-point* (photo-alist &optional cam-set-global-p)
1774 "Call add-global-car-reference-point with arguments taken from photo-alist. When cam-set-global-p is t, call add-global-car-reference-point-cam-set-global instead."
1775 (let* ((longitude-radians (proj:degrees-to-radians (car (photogrammetry-arglist photo-alist :longitude))))
1776 (latitude-radians (proj:degrees-to-radians (car (photogrammetry-arglist photo-alist :latitude))))
1777 (ellipsoid-height (car (photogrammetry-arglist photo-alist :ellipsoid-height)))
1778 (destination-cs (car (photogrammetry-arglist photo-alist :cartesian-system)))
1779 (cartesian-coordinates
1780 (proj:cs2cs (list longitude-radians latitude-radians ellipsoid-height)
1781 :destination-cs destination-cs))
1782 (other-args
1783 (mapcar #'(lambda (x) (coerce x 'double-float))
1784 (photogrammetry-arglist photo-alist
1785 :roll :pitch :heading
1786 :latitude :longitude)))
1787 (double-float-args
1788 (nconc cartesian-coordinates other-args)))
1789 (apply (if cam-set-global-p
1790 #'add-global-car-reference-point-cam-set-global
1791 #'add-global-car-reference-point)
1792 double-float-args)))
1793
1794 (defun add-global-measurement-point* (point)
1795 "Call add-global-measurement-point with arguments taken from point."
1796 (let ((double-float-args
1797 (mapcar #'(lambda (x) (coerce x 'double-float))
1798 (photogrammetry-arglist point
1799 :x-global :y-global :z-global))))
1800 (apply #'add-global-measurement-point double-float-args)))
1801
A Tool for Photogrammetric Road Survey