?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Add help callbacks automatically
[phoros.git] / phoros.lisp
blob6141d923a348db5327c411e05235bd8f584f9e21
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 (defun check-db (db-credentials)
59 "Check postgresql connection. Return t if successful; show error on
60 *error-output* otherwise. db-credentials is a list like so: (database
61 user password host &key (port 5432) use-ssl)."
62 (let (connection)
63 (handler-case
64 (setf connection (apply #'connect db-credentials))
65 (error (e) (format *error-output* "Database connection ~S failed: ~A~&"
66 db-credentials e)))
67 (when connection
68 (disconnect connection)
69 t)))
70
71 (defmethod hunchentoot:session-cookie-name (acceptor)
72 (declare (ignore acceptor))
73 "phoros-session")
74
75 (defun start-server (&key (server-port 8080) (common-root "/"))
76 (setf *phoros-server* (make-instance 'hunchentoot:acceptor :port server-port))
77 (setf *session-max-time* (* 3600 24))
78 (setf *common-root* common-root)
79 (setf *show-lisp-errors-p* (logbitp 16 *verbose*))
80 (setf *ps-print-pretty* (logbitp 15 *verbose*))
81 (setf *use-multi-file-openlayers* (logbitp 14 *verbose*))
82 ;; Doesn't seem to exist(setf *show-lisp-backtraces-p* t) ;TODO: tie this to --debug option
83 (setf *message-log-pathname* "hunchentoot-messages.log") ;TODO: try using cl-log
84 (setf *access-log-pathname* "hunchentoot-access.log") ;TODO: try using cl-log
85 (check-db *postgresql-credentials*)
86 (with-connection *postgresql-credentials*
87 (assert-phoros-db-major-version))
88 (hunchentoot:start *phoros-server*))
89
90 (defun stop-server () (hunchentoot:stop *phoros-server*))
91
92 (eval-when (:compile-toplevel :load-toplevel :execute)
93 (register-sql-operators :2+-ary :&& :overlaps))
94
95 (define-easy-handler phoros-handler ()
96 "First HTTP contact: if necessary, check credentials, establish new
97 session."
98 (with-connection *postgresql-credentials*
99 (let* ((presentation-project-name
100 (second (cl-utilities:split-sequence #\/ (script-name*) :remove-empty-subseqs t)))
101 (presentation-project-id
102 (ignore-errors
103 (query
104 (:select 'presentation-project-id
105 :from 'sys-presentation-project
106 :where (:= 'presentation-project-name presentation-project-name))
107 :single))))
108 (cond
109 ((null presentation-project-id) "No such project.")
110 ((and (equal (session-value 'presentation-project-name) presentation-project-name)
111 (session-value 'authenticated-p))
112 (redirect "/phoros-lib/view" :add-session-id t))
113 (t
114 (progn
115 (setf (session-value 'presentation-project-name) presentation-project-name
116 (session-value 'presentation-project-id) presentation-project-id)
117 (who:with-html-output-to-string (s nil :prologue t :indent t)
118 (:form :method "post" :enctype "multipart/form-data"
119 :action "/phoros-lib/authenticate"
120 "User:" :br
121 (:input :type "text" :name "user-name") :br
122 "Password:" :br
123 (:input :type "password" :name "user-password") :br
124 (:input :type "submit" :value "Submit")))))))))
125
126 (pushnew (create-prefix-dispatcher "/phoros/" 'phoros-handler)
127 *dispatch-table*)
128
129 (define-easy-handler
130 (authenticate-handler :uri "/phoros-lib/authenticate"
131 :default-request-type :post)
132 ()
133 "Check user credentials."
134 (with-connection *postgresql-credentials*
135 (let* ((user-name (post-parameter "user-name"))
136 (user-password (post-parameter "user-password"))
137 (presentation-project-id (session-value 'presentation-project-id))
138 (user-info
139 (when presentation-project-id
140 (query
141 (:select
142 'sys-user.user-full-name
143 'sys-user.user-id
144 'sys-user-role.user-role
145 :from 'sys-user-role 'sys-user
146 :where (:and
147 (:= 'presentation-project-id presentation-project-id)
148 (:= 'sys-user-role.user-id 'sys-user.user-id)
149 (:= 'user-name user-name)
150 (:= 'user-password user-password)))
151 :row)))
152 (user-full-name (first user-info))
153 (user-id (second user-info))
154 (user-role (third user-info)))
155 (if user-role
156 (progn
157 (setf (session-value 'authenticated-p) t
158 (session-value 'user-name) user-name
159 (session-value 'user-full-name) user-full-name
160 (session-value 'user-id) user-id
161 (session-value 'user-role) user-role)
162 (redirect "/phoros-lib/view" :add-session-id t))
163 "Rejected."))))
164
165 (define-easy-handler logout-handler ()
166 (if (session-verify *request*)
167 (progn (remove-session *session*)
168 "Bye.")
169 "Bye (again)."))
170
171 (pushnew (create-regex-dispatcher "/logout" 'logout-handler)
172 *dispatch-table*)
173
174 (define-easy-handler (test :uri "/phoros-lib/test") ()
175 "Authenticated.")
176
177 (define-easy-handler
178 (local-data :uri "/phoros-lib/local-data" :default-request-type :post)
179 ()
180 "Receive coordinates, respond with the count nearest json objects
181 containing picture url, calibration parameters, and car position,
182 wrapped in an array."
183 (when (session-value 'authenticated-p)
184 (let* ((presentation-project-id (session-value 'presentation-project-id))
185 (common-table-names (common-table-names presentation-project-id))
186 (data (json:decode-json-from-string (raw-post-data)))
187 (longitude-input (cdr (assoc :longitude data)))
188 (latitude-input (cdr (assoc :latitude data)))
189 (count (cdr (assoc :count data)))
190 (zoom-input (cdr (assoc :zoom data)))
191 ;;(snap-distance (* 10d-5 (expt 2 (- 18 zoom-input)))) ; assuming geographic coordinates
192 (snap-distance (* 10d-1 (expt 2 (- 18 zoom-input)))) ; assuming geographic coordinates
193 (point-form
194 (format nil "POINT(~F ~F)" longitude-input latitude-input))
195 (result
196 (ignore-errors
197 (with-connection *postgresql-credentials*
198 (loop
199 for common-table-name in common-table-names
200 nconc
201 (query
202 (:limit
203 (:order-by
204 (:select
205 'date ;TODO: debug only
206 'measurement-id 'recorded-device-id 'device-stage-of-life-id ;TODO: debug only
207 'directory
208 'filename 'byte-position 'point-id
209 'trigger-time
210 ;'coordinates ;the search target
211 'longitude 'latitude 'ellipsoid-height
212 'cartesian-system
213 'east-sd 'north-sd 'height-sd
214 'roll 'pitch 'heading 'roll-sd 'pitch-sd 'heading-sd
215 'sensor-width-pix 'sensor-height-pix 'pix-size
216 'mounting-angle
217 'dx 'dy 'dz 'omega 'phi 'kappa
218 'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
219 'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
220 'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
221 :from
222 (aggregate-view-name common-table-name)
223 :where
224 (:and (:= 'presentation-project-id presentation-project-id)
225 (:st_dwithin 'coordinates
226 (:st_geomfromtext point-form *standard-coordinates*)
227 snap-distance)))
228 (:st_distance 'coordinates
229 (:st_geomfromtext point-form *standard-coordinates*)))
230 count)
231 :alists))))))
232 (json:encode-json-to-string result))))
233
234 (define-easy-handler
235 (store-point :uri "/phoros-lib/store-point" :default-request-type :post)
236 ()
237 "Receive point sent by user; store it into database."
238 (when (session-value 'authenticated-p)
239 (let* ((presentation-project-name (session-value 'presentation-project-name))
240 (user-id (session-value 'user-id))
241 (user-role (session-value 'user-role))
242 (data (json:decode-json-from-string (raw-post-data)))
243 (longitude-input (cdr (assoc :longitude data)))
244 (latitude-input (cdr (assoc :latitude data)))
245 (ellipsoid-height-input (cdr (assoc :ellipsoid-height data)))
246 (stdx-global (cdr (assoc :stdx-global data)))
247 (stdy-global (cdr (assoc :stdy-global data)))
248 (stdz-global (cdr (assoc :stdz-global data)))
249 (attribute (cdr (assoc :attribute data)))
250 (description (cdr (assoc :description data)))
251 (numeric-description (cdr (assoc :numeric-description data)))
252 (point-form
253 (format nil "SRID=4326; POINT(~S ~S ~S)"
254 longitude-input latitude-input ellipsoid-height-input))
255 (user-point-table-name
256 (user-point-table-name presentation-project-name)))
257 (assert
258 (not (string-equal user-role "read")) ;that is, "write" or "admin"
259 () "No write permission.")
260 (with-connection *postgresql-credentials*
261 (assert
262 (= 1 (execute (:insert-into user-point-table-name :set
263 'user-id user-id
264 'attribute attribute
265 'description description
266 'numeric-description numeric-description
267 'creation-date 'current-timestamp
268 'coordinates (:st_geomfromewkt point-form)
269 'stdx-global stdx-global
270 'stdy-global stdy-global
271 'stdz-global stdz-global
272 )))
273 () "No point stored. This should not happen.")))))
274
275 (define-easy-handler
276 (delete-point :uri "/phoros-lib/delete-point" :default-request-type :post)
277 ()
278 "Delete user point if user is allowed to do so."
279 (when (session-value 'authenticated-p)
280 (let* ((presentation-project-name (session-value 'presentation-project-name))
281 (user-id (session-value 'user-id))
282 (user-role (session-value 'user-role))
283 (user-point-table-name
284 (user-point-table-name presentation-project-name))
285 (data (json:decode-json-from-string (raw-post-data))))
286 (with-connection *postgresql-credentials*
287 (assert
288 (eql 1 (cond ((string-equal user-role "admin")
289 (execute (:delete-from user-point-table-name
290 :where (:= 'user-point-id data))))
291 ((string-equal user-role "write")
292 (execute (:delete-from user-point-table-name
293 :where (:and
294 (:= 'user-point-id data)
295 (:= 'user-id user-id)))))))
296 () "No point deleted. This should not happen.")))))
297
298
299 (defun common-table-names (presentation-project-id)
300 "Return a list of common-table-names of table sets that contain data
301 of presentation project with presentation-project-id."
302 (handler-case
303 (with-connection *postgresql-credentials*
304 (query
305 (:select 'common-table-name
306 :distinct
307 :from 'sys-presentation 'sys-measurement 'sys-acquisition-project
308 :where (:and
309 (:= 'sys-presentation.presentation-project-id presentation-project-id)
310 (:= 'sys-presentation.measurement-id 'sys-measurement.measurement-id)
311 (:= 'sys-measurement.acquisition-project-id 'sys-acquisition-project.acquisition-project-id)))
312 :column))
313 (condition (c)
314 (cl-log:log-message
315 :server
316 "While fetching common-table-names of presentation-project-id ~D: ~A"
317 presentation-project-id c))))
318
319 (defun encode-geojson-to-string (features)
320 "Encode a list of property lists into a GeoJSON FeatureCollection.
321 Each property list must contain keys for coordinates, :x, :y, :z; and
322 for a numeric point :id, followed by zero or more pieces of extra
323 information. The extra information is stored as GeoJSON Feature
324 properties."
325 (with-output-to-string (s)
326 (json:with-object (s)
327 (json:encode-object-member :type :*feature-collection s)
328 (json:as-object-member (:features s)
329 (json:with-array (s)
330 (mapcar
331 #'(lambda (point-with-properties)
332 (destructuring-bind (&key x y z id &allow-other-keys) ;TODO: z probably bogus
333 point-with-properties
334 (json:as-array-member (s)
335 (json:with-object (s)
336 (json:encode-object-member :type :*feature s)
337 (json:as-object-member (:geometry s)
338 (json:with-object (s)
339 (json:encode-object-member :type :*point s)
340 (json:as-object-member (:coordinates s)
341 (json:encode-json (list x y z) s))))
342 (json:encode-object-member :id id s)
343 (json:as-object-member (:properties s)
344 (dolist (key '(:x :y :z :id))
345 (remf point-with-properties key))
346 (json:encode-json-plist point-with-properties s))))))
347 features))))))
348
349 (defun box3d (bbox)
350 "Return a WKT-compliant BOX3D string from string bbox."
351 (concatenate 'string "BOX3D("
352 (substitute #\Space #\,
353 (substitute #\Space #\, bbox :count 1)
354 :from-end t :count 1)
355 ")"))
356
357 (define-easy-handler (points :uri "/phoros-lib/points") (bbox)
358 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
359 (when (session-value 'authenticated-p)
360 (handler-case
361 (let ((common-table-names
362 (common-table-names
363 (session-value 'presentation-project-id))))
364 (encode-geojson-to-string
365 (with-connection *postgresql-credentials*
366 (loop
367 for common-table-name in common-table-names
368 for point-table-name = (make-symbol
369 (concatenate
370 'string "dat-"
371 common-table-name "-point"))
372 append
373 (query
374 (:select
375 (:as
376 (:st_x (:st_transform 'coordinates *standard-coordinates*))
377 'x)
378 (:as
379 (:st_y (:st_transform 'coordinates *standard-coordinates*))
380 'y)
381 (:as
382 (:st_z (:st_transform 'coordinates *standard-coordinates*))
383 'z)
384 (:as 'point-id 'id) ;becomes fid on client
385 :from point-table-name
386 :where (:&&
387 (:st_transform 'coordinates *standard-coordinates*)
388 (:st_setsrid (:type (box3d bbox) box3d)
389 *standard-coordinates*)))
390 :plists)))))
391 (condition (c)
392 (cl-log:log-message
393 :server "While fetching points from inside bbox ~S: ~A"
394 bbox c)))))
395
396 (define-easy-handler (user-points :uri "/phoros-lib/user-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 ((user-point-table-name
401 (user-point-table-name (session-value 'presentation-project-name))))
402 (encode-geojson-to-string
403 (with-connection *postgresql-credentials*
404 (query
405 (:select
406 (:as
407 (:st_x (:st_transform 'coordinates *standard-coordinates*))
408 'x)
409 (:as
410 (:st_y (:st_transform 'coordinates *standard-coordinates*))
411 'y)
412 (:as
413 (:st_z (:st_transform 'coordinates *standard-coordinates*))
414 'z)
415 (:as 'user-point-id 'id) ;becomes fid on client
416 'attribute
417 'description
418 'numeric-description
419 (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
420 'creation-date)
421 :from user-point-table-name
422 :where (:&&
423 (:st_transform 'coordinates *standard-coordinates*)
424 (:st_setsrid (:type (box3d bbox) box3d)
425 *standard-coordinates*)))
426 :plists))))
427 (condition (c)
428 (cl-log:log-message
429 :server "While fetching user-points from inside bbox ~S: ~A"
430 bbox c)))))
431
432 (define-easy-handler photo-handler
433 ((bayer-pattern :init-form "#00ff00,#ff0000")
434 (color-raiser :init-form "1,1,1"))
435 "Serve an image from a .pictures file."
436 (when (session-value 'authenticated-p)
437 (handler-case
438 (let* ((s (cdr (cl-utilities:split-sequence #\/ (script-name*)
439 :remove-empty-subseqs t)))
440 (directory (last (butlast s 2)))
441 (file-name-and-type (cl-utilities:split-sequence
442 #\. (first (last s 2))))
443 (byte-position (parse-integer (car (last s)) :junk-allowed t))
444 (path-to-file
445 (car
446 (directory
447 (make-pathname
448 :directory (append (pathname-directory *common-root*)
449 directory '(:wild-inferiors))
450 :name (first file-name-and-type)
451 :type (second file-name-and-type)))))
452 stream)
453 (setf (content-type*) "image/png")
454 (setf stream (send-headers))
455 (send-png stream path-to-file byte-position
456 :bayer-pattern (canonicalize-bayer-pattern bayer-pattern)
457 :color-raiser (canonicalize-color-raiser color-raiser)))
458 (condition (c)
459 (cl-log:log-message
460 :server "While serving image ~S: ~A" (request-uri*) c)))))
461
462 (pushnew (create-prefix-dispatcher "/phoros-lib/photo" 'photo-handler)
463 *dispatch-table*)
464
465 ;;; for debugging; this is the multi-file OpenLayers
466 (pushnew (create-folder-dispatcher-and-handler
467 "/phoros-lib/openlayers/" "OpenLayers-2.10/")
468 *dispatch-table*)
469
470 (pushnew (create-folder-dispatcher-and-handler "/phoros-lib/ol/" "ol/")
471 *dispatch-table*)
472
473 (pushnew (create-folder-dispatcher-and-handler "/phoros-lib/css/" "css/") ;TODO: merge this style.css into public_html/style.css
474 *dispatch-table*)
475
476 (pushnew (create-folder-dispatcher-and-handler
477 "/phoros-lib/public_html/" "public_html/")
478 *dispatch-table*)
479
480 (pushnew (create-static-file-dispatcher-and-handler
481 "/favicon.ico" "public_html/favicon.ico")
482 *dispatch-table*)
483
484 (define-easy-handler (phoros.js :uri "/phoros-lib/phoros.js") ()
485 "Serve some Javascript."
486 (when (session-value 'authenticated-p)
487 (ps
488
489 (setf debug-info (@ *open-layers *console info))
490
491 (setf
492 click-control
493 (chain
494 *open-layers
495 (*class
496 (@ *open-layers *control)
497 (create
498 :default-handler-options
499 (create :single t
500 :double false
501 :pixel-tolerance 0
502 :stop-single false
503 :stop-double false)
504 :initialize
505 (lambda (options)
506 (setf
507 (@ this handler-options)
508 (chain *open-layers
509 *util
510 (extend
511 (create)
512 (@ this default-handler-options))))
513 (chain *open-layers
514 *control
515 prototype
516 initialize
517 (apply this arguments))
518 (setf (@ this handler)
519 (new (chain *open-layers
520 *handler
521 (*click this
522 (create
523 :click (@ this trigger))
524 (@ this handler-options))))))))))
525
526 (defvar geographic
527 (new (chain *open-layers (*projection "EPSG:4326"))))
528 (defvar spherical-mercator
529 (new (chain *open-layers (*projection "EPSG:900913"))))
530 (defvar user-role (lisp (string-downcase (session-value 'user-role)))
531 "User's permissions")
532 (defvar images (array) "Collection of the photos currently shown.")
533 (defvar streetmap "The streetmap shown to the user.")
534 (defvar streetmap-estimated-position-layer)
535 (defvar point-attributes-select
536 "The HTML element for selecting user point attributes.")
537
538 (defun *image ()
539 "Anything necessary to deal with a photo."
540 (setf (getprop this 'map)
541 (new ((getprop *open-layers '*map)
542 (create projection spherical-mercator
543 all-overlays t)))
544 (getprop this 'dummy) false ;TODO why? (omitting splices map components directly into *image)
545 ))
546
547 (setf (getprop *image 'prototype 'show-photo) show-photo)
548 (setf (getprop *image 'prototype 'draw-epipolar-line) draw-epipolar-line)
549 (setf (getprop *image 'prototype 'draw-active-point) draw-active-point)
550 (setf (getprop *image 'prototype 'draw-estimated-positions)
551 draw-estimated-positions)
552
553 (defun photo-path (photo-parameters)
554 "Create from stuff found in photo-parameters a path for use in
555 an image url."
556 (+ "/phoros-lib/photo/" (@ photo-parameters directory) "/"
557 (@ photo-parameters filename) "/"
558 (@ photo-parameters byte-position) ".png"))
559
560 (defun has-layer-p (map layer-name)
561 "False if map doesn't have a layer called layer-name."
562 (chain map (get-layers-by-name layer-name) length))
563
564 (defun some-active-point-p ()
565 "False if no image in images has an Active Point."
566 (loop
567 for i across images
568 sum (has-layer-p (getprop i 'map) "Active Point")))
569
570 (defun remove-layer (map layer-name)
571 "Destroy layer layer-name in map."
572 (when (has-layer-p map layer-name)
573 (chain map (get-layers-by-name layer-name) 0 (destroy))))
574
575 (defun remove-any-layers (layer-name)
576 "Destroy in all images and in streetmap the layer named layer-name."
577 (loop
578 for i across images do (remove-layer (getprop i 'map) layer-name))
579 (remove-layer streetmap layer-name))
580
581 (defun remove-work-layers ()
582 "Destroy user-generated layers in streetmap and in all images."
583 (disable-element-with-id "finish-point-button")
584 (disable-element-with-id "remove-work-layers-button")
585 (remove-any-layers "Epipolar Line")
586 (remove-any-layers "Active Point")
587 (remove-any-layers "Estimated Position")
588 (setf pristine-images-p t))
589
590 (defun enable-element-with-id (id)
591 "Activate HTML element with id=\"id\"."
592 (setf (chain document (get-element-by-id id) disabled) nil))
593
594 (defun disable-element-with-id (id)
595 "Grey out HTML element with id=\"id\"."
596 (setf (chain document (get-element-by-id id) disabled) t))
597
598 (defun refresh-layer (layer)
599 "Have layer re-request and redraw features."
600 (chain layer (refresh (create :force t))))
601
602 (defun present-photos ()
603 "Handle the response triggered by request-photos."
604 (let ((photo-parameters ((@ *json* parse)
605 (@ photo-request-response response-text))))
606 (loop
607 for p across photo-parameters
608 for i across images
609 do
610 (setf (getprop i 'photo-parameters) p)
611 ((getprop i 'show-photo)))
612 ;; (setf (@ (aref photo-parameters 0) angle180) 1) ; Debug: coordinate flipping
613 ))
614
615 (defun request-photos (event)
616 "Handle the response to a click into streetmap; fetch photo data."
617 (disable-element-with-id "finish-point-button")
618 (disable-element-with-id "remove-work-layers-button")
619 (remove-any-layers "Estimated Position")
620 (let ((lonlat
621 ((@ ((@ streetmap get-lon-lat-from-pixel) (@ event xy)) transform)
622 spherical-mercator ; why?
623 geographic)))
624 (setf content
625 ((@ *json* stringify)
626 (create :longitude (@ lonlat lon) ; TODO: use OpenLayer's JSON.
627 :latitude (@ lonlat lat)
628 :zoom ((@ streetmap get-zoom))
629 :count (lisp *number-of-images*))))
630 (setf photo-request-response
631 ((@ *open-layers *Request *POST*)
632 (create :url "/phoros-lib/local-data"
633 :data content
634 :headers (create "Content-type" "text/plain"
635 "Content-length" (@ content length))
636 :success present-photos)))))
637
638 (defun draw-epipolar-line ()
639 "Draw an epipolar line from response triggered by clicking
640 into a (first) photo."
641 (enable-element-with-id "remove-work-layers-button")
642 (disable-element-with-id "delete-point-button")
643 (setf (chain document (get-element-by-id "point-creation-date") inner-h-t-m-l) nil) ;TODO: unselect feature in streetmap which in turn should make this line unnecessary
644 (let ((epipolar-line ((@ *json* parse)
645 (@ this epipolar-request-response response-text))))
646 (chain this epipolar-layer
647 (add-features
648 (new ((@ *open-layers *feature *vector)
649 (new ((@ *open-layers *geometry *line-string)
650 ((@ epipolar-line map)
651 (lambda (x)
652 (new ((@ *open-layers *geometry *point)
653 (@ x :m) (@ x :n)))))))))))))
654 ;; either *line-string or *multi-point are usable
655
656 (defvar global-position "Coordinates of the current estimated position")
657
658 (defun draw-estimated-positions ()
659 "Draw into streetmap and into all images points at Estimated
660 Position. Estimated Position is the point returned so far from
661 photogrammetric calculations that are triggered by clicking into
662 another photo."
663 (unless (== user-role "read")
664 (enable-element-with-id "finish-point-button"))
665 (let* ((estimated-positions-request-response
666 ((@ *json* parse)
667 (getprop this
668 'estimated-positions-request-response
669 'response-text)))
670 (estimated-positions
671 (aref estimated-positions-request-response 1)))
672 (setf global-position
673 (aref estimated-positions-request-response 0))
674 (setf streetmap-estimated-position-layer
675 (new ((@ *open-layers *layer *vector) "Estimated Position")))
676 (chain streetmap-estimated-position-layer
677 (add-features
678 (new ((@ *open-layers *feature *vector)
679 ((@ (new ((@ *open-layers *geometry *point)
680 (getprop global-position 'longitude)
681 (getprop global-position 'latitude)))
682 transform) geographic spherical-mercator)))))
683 ((@ streetmap add-layer) streetmap-estimated-position-layer)
684 (loop
685 for i in images
686 for p in estimated-positions
687 do
688 (setf (@ i estimated-position-layer)
689 (new
690 ((@ *open-layers *layer *vector) "Estimated Position")))
691 ((@ i map add-layer) (@ i estimated-position-layer))
692 (chain i estimated-position-layer
693 (add-features
694 (new ((@ *open-layers *feature *vector)
695 (new ((@ *open-layers *geometry *point)
696 (getprop p 'm)
697 (getprop p 'n))))))))))
698
699 (defun finish-point ()
700 "Send current global-position as a user point to the database."
701 (let ((global-position-etc global-position))
702 (setf (chain global-position-etc attribute)
703 (chain
704 (elt (chain point-attributes-select options)
705 (chain point-attributes-select options selected-index))
706 text))
707 (setf (chain global-position-etc description)
708 (chain document (get-element-by-id "point-description") value))
709 (setf (chain global-position-etc numeric-description)
710 (chain document
711 (get-element-by-id "point-numeric-description")
712 value))
713 (setf content
714 ((@ *json* stringify) global-position-etc)) ; TODO: use OpenLayer's JSON.
715 (setf photo-request-response ;TODO: this shouldn't be here
716 ((@ *open-layers *Request *POST*)
717 (create :url "/phoros-lib/store-point"
718 :data content
719 :headers (create "Content-type" "text/plain"
720 "Content-length" (@ content length))
721 :success (lambda ()
722 (refresh-layer user-point-layer)
723 (remove-work-layers)))))
724 (let* ((previous-numeric-description ;increment if possible
725 (chain global-position-etc numeric-description))
726 (current-numeric-description
727 (1+ (parse-int previous-numeric-description 10))))
728 (setf (chain document
729 (get-element-by-id "point-numeric-description")
730 value)
731 (if (is-finite current-numeric-description)
732 current-numeric-description
733 previous-numeric-description)))))
734
735 (defun delete-point ()
736 (let ((user-point-id (chain current-user-point fid)))
737 (setf content
738 ((@ *json* stringify) user-point-id)) ; TODO: use OpenLayer's JSON.
739 ((@ *open-layers *Request *POST*)
740 (create :url "/phoros-lib/delete-point"
741 :data content
742 :headers (create "Content-type" "text/plain"
743 "Content-length" (@ content length))
744 :success (lambda ()
745 (refresh-layer user-point-layer)
746 (setf (chain document (get-element-by-id "point-creation-date") inner-h-t-m-l) nil))))))
747
748 (defun draw-active-point ()
749 "Draw an Active Point, i.e. a point used in subsequent
750 photogrammetric calculations."
751 (chain this active-point-layer
752 (add-features
753 (new ((@ *open-layers *feature *vector)
754 (new ((@ *open-layers *geometry *point)
755 (getprop this 'photo-parameters 'm)
756 (getprop this 'photo-parameters 'n))))))))
757
758 (defun image-click-action (clicked-image)
759 (lambda (event)
760 "Do appropriate things when an image is clicked into."
761 (let* ((lonlat
762 ((@ (@ clicked-image map) get-lon-lat-from-view-port-px)
763 (@ event xy)))
764 (photo-parameters
765 (getprop clicked-image 'photo-parameters))
766 pristine-image-p content request)
767 (setf (@ photo-parameters m) (@ lonlat lon)
768 (@ photo-parameters n) (@ lonlat lat))
769 (remove-layer (getprop clicked-image 'map) "Active Point")
770 (remove-any-layers "Epipolar Line")
771 (setf pristine-images-p (not (some-active-point-p)))
772 (setf (@ clicked-image active-point-layer)
773 (new ((@ *open-layers *layer *vector) "Active Point")))
774 ((@ clicked-image map add-layer)
775 (@ clicked-image active-point-layer))
776 ((getprop clicked-image 'draw-active-point))
777 (if
778 pristine-images-p
779 (progn
780 (loop
781 for i across images do
782 (unless (== i clicked-image)
783 (setf
784 (@ i epipolar-layer) (new ((@ *open-layers *layer *vector)
785 "Epipolar Line"))
786 content ((@ *json* stringify)
787 (append (array photo-parameters)
788 (@ i photo-parameters)))
789 (@ i epipolar-request-response)
790 ((@ *open-layers *Request *POST*)
791 (create :url "/phoros-lib/epipolar-line"
792 :data content
793 :headers (create "Content-type" "text/plain"
794 "Content-length"
795 (@ content length))
796 :success (getprop i 'draw-epipolar-line)
797 :scope i)))
798 ((@ i map add-layer) (@ i epipolar-layer)))))
799 (progn
800 (remove-any-layers "Epipolar Line")
801 (remove-any-layers "Estimated Position")
802 (let* ((active-pointed-photo-parameters
803 (loop
804 for i across images
805 when (has-layer-p (getprop i 'map) "Active Point")
806 collect (getprop i 'photo-parameters)))
807 (content
808 ((@ *json* stringify)
809 (list active-pointed-photo-parameters
810 (chain images
811 (map #'(lambda (x)
812 (getprop
813 x 'photo-parameters))))))))
814 (setf (@ clicked-image estimated-positions-request-response)
815 ((@ *open-layers *Request *POST*)
816 (create :url "/phoros-lib/estimated-positions"
817 :data content
818 :headers (create "Content-type" "text/plain"
819 "Content-length"
820 (@ content length))
821 :success (getprop clicked-image
822 'draw-estimated-positions)
823 :scope clicked-image)))))))))
824
825 (defun show-photo ()
826 "Show the photo described in this object's photo-parameters."
827 (loop
828 repeat ((getprop this 'map 'get-num-layers))
829 do ((getprop this 'map 'layers 0 'destroy)))
830 ((getprop this 'map 'add-layer)
831 (new ((@ *open-layers *layer *image)
832 "Photo"
833 (photo-path (getprop this 'photo-parameters))
834 (new ((@ *open-layers *bounds) -.5 -.5
835 (+ (getprop this 'photo-parameters 'sensor-width-pix)
836 .5)
837 (+ (getprop this 'photo-parameters 'sensor-height-pix)
838 .5))) ; coordinates shown
839 (new ((@ *open-layers *size) 512 256))
840 (create))))
841 ((getprop this 'map 'zoom-to-extent)
842 (new ((@ *open-layers *bounds) -.5 -.5
843 (1+ (getprop this 'photo-parameters 'sensor-width-pix))
844 (1+ (getprop this 'photo-parameters 'sensor-height-pix)))))) ; in coordinates shown
845
846 (defun initialize-image (image-index)
847 "Create an image usable for displaying photos at position
848 image-index in array images."
849 (setf (aref images image-index) (new *image))
850 (setf (@ (aref images image-index) image-click-action)
851 (image-click-action (aref images image-index)))
852 (setf (@ (aref images image-index) click)
853 (new (click-control
854 (create :trigger (@ (aref images image-index)
855 image-click-action)))))
856 ((@ (aref images image-index) map add-control)
857 (@ (aref images image-index) click))
858 ((@ (aref images image-index) click activate))
859 ((@ (aref images image-index) map add-control)
860 (new ((@ *open-layers *control *mouse-position))))
861 ((@ (aref images image-index) map add-control)
862 (new ((@ *open-layers *control *layer-switcher))))
863 ((@ (aref images image-index) map render) (+ image-index "")))
864
865 (defvar help-topics
866 (create
867 :user-role
868 (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."))
869 :presentation-project-name
870 (who-ps-html (:p "Presentation project name."))
871 :h2-controls
872 (who-ps-html (:p "Next action."))
873 :finish-point-button
874 (who-ps-html (:p "Store point with its attribute, description and numeric description into database. Afterwards, increment the numeric description if possible."))
875 :point-attribute
876 (who-ps-html (:p "One of a few possible point attributes.")
877 (:p "TODO: currently only the hard-coded ones are available."))
878 :point-description
879 (who-ps-html (:p "Optional verbal description of point."))
880 :point-numeric-description
881 (who-ps-html (:p "Optional additional description of point. Preferrably numeric and if so, automatically incremented after finishing point."))
882 :remove-work-layers-button
883 (who-ps-html (:p "Discard the current, unstored point but let the rest of the workspace untouched."))
884 :blurb-button
885 (who-ps-html (:p "View some info about phoros."))
886 :logout-button
887 (who-ps-html (:p "Finish this session. Fresh login is required to continue."))
888 :streetmap
889 (who-ps-html (:p "Clicking into the streetmap fetches images which most probably feature the clicked point.")
890 (:p "TODO: This is not quite so. Currently images taken from points nearest to the clicked one are displayed."))
891 :images
892 (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."))
893 :help-display
894 (who-ps-html (:p "Hints on Phoros' displays and controls are shown here while hovering over the respective elements."))))
895
896 (defun add-help-events ()
897 "Add mouse events to DOM elements that initiate display of a
898 help message."
899 (for-in (topic help-topics)
900 (setf (chain document (get-element-by-id topic) onmouseover)
901 ((lambda (x)
902 (lambda () (show-help x)))
903 topic))
904 (setf (chain document (get-element-by-id topic) onmouseout) show-help)))
905
906 (defun show-help (&optional topic)
907 "Put text on topic into help-display"
908 (setf (chain document (get-element-by-id "help-display") inner-h-t-m-l)
909 (+ (who-ps-html (:h2 "Help"))
910 (let ((help-body (getprop help-topics topic)))
911 (if (undefined help-body)
912 ""
913 help-body)))))
914
915 (defvar bbox-strategy (chain *open-layers *strategy *bbox*))
916 (setf (chain bbox-strategy prototype ratio) 1.1)
917
918 (defvar geojson-format (chain *open-layers *format *geo-j-s-o-n))
919 (setf (chain geojson-format prototype ignore-extra-dims) t) ;doesn't handle height anyway
920 (setf (chain geojson-format prototype external-projection) geographic)
921 (setf (chain geojson-format prototype internal-projection) geographic)
922
923 (defvar http-protocol (chain *open-layers *protocol *http*))
924 (setf (chain http-protocol prototype format) (new geojson-format))
925
926 (defvar survey-layer
927 (new (chain
928 *open-layers *layer
929 (*vector
930 "Survey"
931 (create
932 :strategies (array (new (bbox-strategy)))
933 :protocol
934 (new (http-protocol
935 (create :url "/phoros-lib/points"))))))))
936
937 (defvar user-point-layer
938 (new (chain
939 *open-layers *layer
940 (*vector
941 "User Points"
942 (create
943 :strategies (array (new bbox-strategy))
944 :protocol
945 (new (http-protocol
946 (create :url "/phoros-lib/user-points"))))))))
947
948 (defvar current-user-point
949 "The currently selected user-point.")
950
951 (defun user-point-selected (event)
952 (enable-element-with-id "delete-point-button")
953 (setf current-user-point (chain event feature))
954 (setf (chain document (get-element-by-id "point-attribute") value) (chain event feature attributes attribute))
955 (setf (chain document (get-element-by-id "point-description") value) (chain event feature attributes description))
956 (setf (chain document (get-element-by-id "point-numeric-description") value) (chain event feature attributes numeric-description))
957 (setf (chain document (get-element-by-id "point-creation-date") inner-h-t-m-l) (chain event feature attributes creation-date))
958 )
959
960 (defun user-point-unselected (event)
961 (disable-element-with-id "delete-point-button")
962 (setf (chain document (get-element-by-id "point-creation-date") inner-h-t-m-l) nil))
963
964 (defun init ()
965 "Prepare user's playground."
966 (unless (== user-role "read")
967 (enable-element-with-id "point-attribute")
968 (enable-element-with-id "point-description")
969 (enable-element-with-id "point-numeric-description"))
970 (setf point-attributes-select (chain document (get-element-by-id "point-attribute")))
971
972 (loop for i in '("solitary" "polyline" "polygon") do
973 (setf point-attribute-item (chain document (create-element "option")))
974 (setf (chain point-attribute-item text) i)
975 (chain point-attributes-select (add point-attribute-item null))) ;TODO: input of user-defined attributes
976 (setf streetmap
977 (new (chain
978 *open-layers
979 (*map "streetmap"
980 (create projection geographic
981 display-projection geographic)))))
982
983 (add-help-events)
984 ;;(defvar google (new ((@ *open-layers *Layer *google) "Google Streets")))
985 (defvar osm-layer (new (chain *open-layers *layer (*osm*))))
986 (defvar streetmap-overview
987 (new (chain *open-layers *control (*overview-map
988 (create maximized t
989 min-ratio 14
990 max-ratio 16)))))
991 (defvar click-streetmap
992 (new (click-control (create :trigger request-photos))))
993 (chain streetmap (add-control click-streetmap))
994 (chain click-streetmap (activate))
995
996 (defvar select-control
997 (new (chain *open-layers *control (*select-feature user-point-layer))))
998 (chain user-point-layer events (register "featureselected" user-point-layer user-point-selected))
999 (chain user-point-layer events (register "featureunselected" user-point-layer user-point-unselected))
1000 (chain streetmap (add-control select-control))
1001 (chain select-control (activate))
1002
1003 ;;((@ map add-layers) (array osm-layer google survey-layer))
1004 (chain streetmap (add-layers (array survey-layer osm-layer user-point-layer)))
1005 (chain streetmap
1006 (add-control
1007 (new (chain *open-layers *control (*layer-switcher)))))
1008 (chain streetmap
1009 (add-control
1010 (new (chain *open-layers *control (*mouse-position)))))
1011 (chain streetmap (add-control streetmap-overview))
1012 (chain streetmap
1013 (zoom-to-extent
1014 (chain (new (chain *open-layers
1015 (*bounds
1016 14.32066 51.72693 14.32608 51.72862)))
1017 (transform geographic spherical-mercator))))
1018 (loop
1019 for i from 0 to (lisp (1- *number-of-images*))
1020 do (initialize-image i))))))
1021
1022 (define-easy-handler
1023 (view :uri "/phoros-lib/view" :default-request-type :post) ()
1024 "Serve the client their main workspace."
1025 (if
1026 (session-value 'authenticated-p)
1027 (who:with-html-output-to-string (s nil :indent t)
1028 (:html
1029 :xmlns "http://www.w3.org/1999/xhtml"
1030 (:head
1031 (:title (who:str
1032 (concatenate
1033 'string
1034 "Phoros: " (session-value 'presentation-project-name))))
1035 (if *use-multi-file-openlayers*
1036 (who:htm
1037 (:script :src "/phoros-lib/openlayers/lib/Firebug/firebug.js")
1038 (:script :src "/phoros-lib/openlayers/lib/OpenLayers.js")
1039 ;;(:script :src "/phoros-lib/openlayers/lib/proj4js.js") ;TODO: we don't seem to use this
1040 )
1041 (who:htm (:script :src "/phoros-lib/ol/OpenLayers.js")))
1042 (:link :rel "stylesheet" :href "/phoros-lib/css/style.css" :type "text/css")
1043 (:script :src "/phoros-lib/phoros.js")
1044 ;;(:script :src "http://maps.google.com/maps/api/js?sensor=false")
1045 )
1046 (:body
1047 :onload (ps (init))
1048 (:h1 :id "title"
1049 "Phoros: " (who:str (session-value 'user-full-name))
1050 (who:fmt " (~A)" (session-value 'user-name))
1051 "with " (:span :id "user-role"
1052 (who:str (session-value 'user-role)))
1053 "permission on "
1054 (:span :id "presentation-project-name"
1055 (who:str (session-value 'presentation-project-name))))
1056 (:div :id "streetmap" :class "smallmap" :style "cursor:crosshair")
1057 (:div :class "phoros-controls"
1058 (:button :id "blurb-button"
1059 :type "button"
1060 :onclick "self.location.href = \"/phoros-lib/blurb\""
1061 "blurb")
1062 (:button :id "logout-button"
1063 :type "button"
1064 :onclick "self.location.href = \"/phoros-lib/logout\""
1065 "bye")
1066 :br
1067 (:button :id "remove-work-layers-button" :disabled t
1068 :type "button" :onclick (ps-inline (remove-work-layers))
1069 "start over")
1070 (:h2 :id "h2-controls" "Create Point") ;TODO: change text programmatically
1071 (:select :id "point-attribute" :disabled t
1072 :size 1 :name "point-attribute")
1073 :br
1074 (:input :id "point-description" :disabled t
1075 :type "text" :size 20 :name "point-description")
1076 :br
1077 (:input :id "point-numeric-description" :disabled t
1078 :type "text" :size 6 :name "point-numeric-description")
1079 (:code :id "point-creation-date" :disabled t
1080 :type "text" :name "point-creation-date")
1081 :br
1082 (:button :disabled t :id "finish-point-button"
1083 :type "button"
1084 :onclick (ps-inline (finish-point))
1085 "finish point")
1086 (:button :id "delete-point-button" :disabled t
1087 :type "button" :onclick (ps-inline (delete-point))
1088 "delete"))
1089 (:div :id "help-display" :class "smalltext")
1090 (:div :id "images" :style "clear:both"
1091 (loop
1092 for i from 0 below *number-of-images* do
1093 (who:htm (:div :id i :class "image" :style "cursor:crosshair"
1094 )))))))
1095 (redirect
1096 (concatenate 'string "/phoros/" (session-value 'presentation-project-name))
1097 :add-session-id t)))
1098
1099 (define-easy-handler (epipolar-line :uri "/phoros-lib/epipolar-line") ()
1100 "Receive vector of two sets of picture parameters, respond with
1101 JSON encoded epipolar-lines."
1102 (when (session-value 'authenticated-p)
1103 (let* ((data (json:decode-json-from-string (raw-post-data))))
1104 (json:encode-json-to-string (photogrammetry :epipolar-line (first data) (second data))))))
1105
1106 (define-easy-handler (estimated-positions :uri "/phoros-lib/estimated-positions") ()
1107 "Receive a two-part JSON vector comprising (1) a vector containing
1108 sets of picture-parameters including clicked points stored in :m, :n;
1109 and (2) a vector containing sets of picture-parameters; respond with
1110 a JSON encoded two-part vector comprising (1) a point in global
1111 coordinates; and (2) a vector of image coordinates (m, n) for the
1112 global point that correspond to the images from the received second
1113 vector. TODO: report error on bad data (ex: points too far apart)."
1114 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1115 (when (session-value 'authenticated-p)
1116 (let* ((data (json:decode-json-from-string (raw-post-data)))
1117 (active-point-photo-parameters (first data))
1118 (destination-photo-parameters (second data))
1119 (cartesian-system (cdr (assoc :cartesian-system (first active-point-photo-parameters))))
1120 (global-point-cartesian (photogrammetry :multi-position-intersection active-point-photo-parameters))
1121 (global-point-geographic-radians
1122 (proj:cs2cs (list (cdr (assoc :x-global global-point-cartesian))
1123 (cdr (assoc :y-global global-point-cartesian))
1124 (cdr (assoc :z-global global-point-cartesian)))
1125 :source-cs cartesian-system))
1126 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1127 (pairlis '(:longitude :latitude :ellipsoid-height
1128 :stdx-global :stdy-global :stdz-global)
1129 (list
1130 (proj:radians-to-degrees (first global-point-geographic-radians))
1131 (proj:radians-to-degrees (second global-point-geographic-radians))
1132 (third global-point-geographic-radians)
1133 (cdr (assoc :stdx-global global-point-cartesian))
1134 (cdr (assoc :stdy-global global-point-cartesian))
1135 (cdr (assoc :stdz-global global-point-cartesian)))))
1136 (image-coordinates
1137 (loop
1138 for i in destination-photo-parameters
1139 collect (photogrammetry :reprojection i global-point-cartesian))))
1140 (json:encode-json-to-string
1141 (list global-point-for-display image-coordinates)))))
1142
1143 (define-easy-handler (multi-position-intersection :uri "/phoros-lib/intersection") ()
1144 "Receive vector of sets of picture parameters, respond with stuff."
1145 (when (session-value 'authenticated-p)
1146 (let* ((data (json:decode-json-from-string (raw-post-data))))
1147 (json:encode-json-to-string (photogrammetry :multi-position-intersection data)))))
1148
1149 (defgeneric photogrammetry (mode photo-1 &optional photo-2)
1150 (:documentation "Call to photogrammetry library. Dispatch on mode."))
1151
1152 (defmethod photogrammetry :around (mode clicked-photo &optional other-photo)
1153 "Prepare and clean up a run of photogrammetry."
1154 (declare (ignore other-photo))
1155 (bt:with-lock-held (*photogrammetry-mutex*)
1156 (del-all)
1157 (unwind-protect
1158 (call-next-method)
1159 (del-all))))
1160
1161 (defmethod photogrammetry ((mode (eql :epipolar-line)) clicked-photo &optional other-photo)
1162 "Return in an alist an epipolar line in coordinates of other-photo from m and n in clicked-photo."
1163 (add-cam* clicked-photo)
1164 (add-bpoint* clicked-photo)
1165 (add-global-car-reference-point* clicked-photo t)
1166 (add-cam* other-photo)
1167 (add-global-car-reference-point* other-photo t)
1168 (loop
1169 for i = 2d0 then (* i 1.4) until (> i 50)
1170 do
1171 (set-distance-for-epipolar-line i)
1172 when (ignore-errors (calculate))
1173 collect (pairlis '(:m :n) (list (flip-m-maybe (get-m) other-photo)
1174 (flip-n-maybe (get-n) other-photo)))))
1175
1176 (defmethod photogrammetry ((mode (eql :reprojection)) photo &optional global-point)
1177 "Calculate reprojection from photo."
1178 (add-cam* photo)
1179 (add-global-measurement-point* global-point)
1180 (add-global-car-reference-point* photo)
1181 (set-global-reference-frame)
1182 (calculate)
1183 (pairlis '(:m :n)
1184 (list (flip-m-maybe (get-m) photo) (flip-n-maybe (get-n) photo))))
1185
1186 (defmethod photogrammetry ((mode (eql :multi-position-intersection)) photos &optional other-photo)
1187 "Calculate intersection from photos."
1188 (declare (ignore other-photo))
1189 (set-global-reference-frame)
1190 (loop
1191 for photo in photos
1192 do
1193 (add-cam* photo)
1194 (add-bpoint* photo)
1195 (add-global-car-reference-point* photo t))
1196 (calculate)
1197 (pairlis '(:x-global :y-global :z-global
1198 :stdx-global :stdy-global :stdz-global)
1199 (list
1200 (get-x-global) (get-y-global) (get-z-global)
1201 (get-stdx-global) (get-stdy-global) (get-stdz-global))))
1202
1203 (defmethod photogrammetry ((mode (eql :intersection)) photo &optional other-photo)
1204 "Calculate intersection from two photos that are taken out of the
1205 same local coordinate system. (Used for debugging only)."
1206 (add-cam* photo)
1207 (add-bpoint* photo)
1208 (add-cam* other-photo)
1209 (add-bpoint* other-photo)
1210 (calculate)
1211 (pairlis '(:x-local :y-local :z-local
1212 :stdx-local :stdy-local :stdz-local)
1213 (list
1214 (get-x-local) (get-y-local) (get-z-local)
1215 (get-stdx-local) (get-stdy-local) (get-stdz-local)
1216 (get-x-global) (get-y-global) (get-z-global))))
1217
1218 (defmethod photogrammetry ((mode (eql :mono)) photo &optional floor)
1219 "Return in an alist the intersection point of the ray through m and n in photo, and floor."
1220 (add-cam* photo)
1221 (add-bpoint* photo)
1222 (add-ref-ground-surface* floor)
1223 (add-global-car-reference-point* photo)
1224 (set-global-reference-frame)
1225 (calculate)
1226 (pairlis '(:x-global :y-global :z-global)
1227 (list
1228 (get-x-global) (get-y-global) (get-z-global))))
1229
1230 (defun flip-m-maybe (m photo)
1231 "Flip coordinate m when :mounting-angle in photo suggests it necessary."
1232 (if (= 180 (cdr (assoc :mounting-angle photo)))
1233 (- (cdr (assoc :sensor-width-pix photo)) m)
1234 m))
1235 (defun flip-n-maybe (n photo)
1236 "Flip coordinate n when :mounting-angle in photo suggests it necessary."
1237 (if (zerop (cdr (assoc :mounting-angle photo)))
1238 (- (cdr (assoc :sensor-height-pix photo)) n)
1239 n))
1240
1241 (defun photogrammetry-arglist (alist &rest keys)
1242 "Construct an arglist from alist values corresponding to keys."
1243 (mapcar #'(lambda (x) (cdr (assoc x alist))) keys))
1244
1245 (defun add-cam* (photo-alist)
1246 "Call add-cam with arguments taken from photo-alist."
1247 (let ((integer-args
1248 (photogrammetry-arglist
1249 photo-alist :sensor-height-pix :sensor-width-pix))
1250 (double-float-args
1251 (mapcar #'(lambda (x) (coerce x 'double-float))
1252 (photogrammetry-arglist photo-alist
1253 :pix-size
1254 :dx :dy :dz :omega :phi :kappa
1255 :c :xh :yh
1256 :a-1 :a-2 :a-3 :b-1 :b-2 :c-1 :c-2 :r-0
1257 :b-dx :b-dy :b-dz :b-ddx :b-ddy :b-ddz
1258 :b-rotx :b-roty :b-rotz
1259 :b-drotx :b-droty :b-drotz))))
1260 (apply #'add-cam (nconc integer-args double-float-args))))
1261
1262 (defun add-bpoint* (photo-alist)
1263 "Call add-bpoint with arguments taken from photo-alist."
1264 (add-bpoint (coerce (flip-m-maybe (cdr (assoc :m photo-alist)) photo-alist) 'double-float)
1265 (coerce (flip-n-maybe (cdr (assoc :n photo-alist)) photo-alist) 'double-float)))
1266
1267 (defun add-ref-ground-surface* (floor-alist)
1268 "Call add-ref-ground-surface with arguments taken from floor-alist."
1269 (let ((double-float-args
1270 (mapcar #'(lambda (x) (coerce x 'double-float))
1271 (photogrammetry-arglist floor-alist
1272 :nx :ny :nz :d))))
1273 (apply #'add-ref-ground-surface double-float-args)))
1274
1275 (defun add-global-car-reference-point* (photo-alist &optional cam-set-global-p)
1276 "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."
1277 (let* ((longitude-radians (proj:degrees-to-radians (car (photogrammetry-arglist photo-alist :longitude))))
1278 (latitude-radians (proj:degrees-to-radians (car (photogrammetry-arglist photo-alist :latitude))))
1279 (ellipsoid-height (car (photogrammetry-arglist photo-alist :ellipsoid-height)))
1280 (destination-cs (car (photogrammetry-arglist photo-alist :cartesian-system)))
1281 (cartesian-coordinates
1282 (proj:cs2cs (list longitude-radians latitude-radians ellipsoid-height)
1283 :destination-cs destination-cs))
1284 (other-args
1285 (mapcar #'(lambda (x) (coerce x 'double-float))
1286 (photogrammetry-arglist photo-alist
1287 :roll :pitch :heading
1288 :latitude :longitude)))
1289 (double-float-args
1290 (nconc cartesian-coordinates other-args)))
1291 (apply (if cam-set-global-p
1292 #'add-global-car-reference-point-cam-set-global
1293 #'add-global-car-reference-point)
1294 double-float-args)))
1295
1296 (defun add-global-measurement-point* (point)
1297 "Call add-global-measurement-point with arguments taken from point."
1298 (let ((double-float-args
1299 (mapcar #'(lambda (x) (coerce x 'double-float))
1300 (photogrammetry-arglist point
1301 :x-global :y-global :z-global))))
1302 (apply #'add-global-measurement-point double-float-args)))
1303
A Tool for Photogrammetric Road Survey