1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 2 of the License, or
7 ;;; (at your option) any later version.
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
14 ;;; You should have received a copy of the GNU General Public License along
15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 (setf *js-target-version
* 1.8)
22 ;;; Debug helpers. TODO: remove them.
23 (defparameter *t
* nil
)
24 (defparameter *tt
* nil
)
26 (cffi:define-foreign-library photogrammetrie
27 (:unix
(:or
"./libphotogrammetrie.so"
28 "../photogrammetrie/lib/libphotogrammetrie.so"))
29 (t (:default
"libphotogrammetrie")))
31 (defparameter *standard-coordinates
* 4326
32 "EPSG code of the coordinate system that we use for communication.")
34 (defparameter *postgresql-credentials
* nil
35 "A list: (database user password host &key (port 5432) use-ssl)")
37 (defparameter *photogrammetry-mutex
* (bt:make-lock
"photogrammetry"))
39 (setf *read-default-float-format
* 'double-float
)
41 (defparameter *phoros-server
* nil
"Hunchentoot acceptor.")
43 (defparameter *common-root
* nil
44 "Root directory; contains directories of measuring data.")
46 (defparameter *verbose
* 0
47 "Integer (interpreted as a bit mask) denoting various kinds of debugging output.")
49 (defparameter *number-of-images
* 4
50 "Number of photos shown to the HTTP client.")
52 (defun check-db (db-credentials)
53 "Check postgresql connection. Return t if successful; show error on
54 *error-output* otherwise. db-credentials is a list like so: (database
55 user password host &key (port 5432) use-ssl)."
58 (setf connection
(apply #'connect db-credentials
))
59 (error (e) (format *error-output
* "Database connection ~S failed: ~A~&"
62 (disconnect connection
)
65 (defmethod hunchentoot:session-cookie-name
(acceptor)
66 (declare (ignore acceptor
))
69 (defun start-server (&key
(server-port 8080) (common-root "/"))
70 (setf *phoros-server
* (make-instance 'hunchentoot
:acceptor
:port server-port
))
71 (setf *session-max-time
* (* 3600 24))
72 (setf *common-root
* common-root
)
73 (setf *show-lisp-errors-p
* (logbitp 16 *verbose
*))
74 (setf *ps-print-pretty
* (logbitp 15 *verbose
*))
75 ;; Doesn't seem to exist(setf *show-lisp-backtraces-p* t) ;TODO: tie this to --debug option
76 (setf *message-log-pathname
* "hunchentoot-messages.log") ;TODO: try using cl-log
77 (setf *access-log-pathname
* "hunchentoot-access.log") ;TODO: try using cl-log
78 (check-db *postgresql-credentials
*)
79 (with-connection *postgresql-credentials
*
80 (assert-phoros-db-major-version))
81 (hunchentoot:start
*phoros-server
*))
83 (defun stop-server () (hunchentoot:stop
*phoros-server
*))
85 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
86 (register-sql-operators :2+-ary
:&& :overlaps
))
88 (define-easy-handler phoros-handler
()
89 "First HTTP contact: if necessary, check credentials, establish new session."
90 (with-connection *postgresql-credentials
*
91 (let* ((presentation-project-name
92 (second (cl-utilities:split-sequence
#\
/ (script-name*) :remove-empty-subseqs t
)))
93 (presentation-project-id
96 (:select
'presentation-project-id
97 :from
'sys-presentation-project
98 :where
(:= 'presentation-project-name presentation-project-name
))
101 ((null presentation-project-id
) "No such project.")
102 ((and (equal (session-value 'presentation-project-name
) presentation-project-name
)
103 (session-value 'authenticated-p
))
104 (redirect "/view" :add-session-id t
))
107 (setf (session-value 'presentation-project-name
) presentation-project-name
108 (session-value 'presentation-project-id
) presentation-project-id
)
109 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
110 (:form
:method
"post" :enctype
"multipart/form-data"
111 :action
"/authenticate"
113 (:input
:type
"text" :name
"user-name") :br
115 (:input
:type
"password" :name
"user-password") :br
116 (:input
:type
"submit" :value
"Submit")))))))))
118 (pushnew (create-prefix-dispatcher "/phoros/" 'phoros-handler
)
121 (define-easy-handler (authenticate-handler :uri
"/authenticate" :default-request-type
:post
) ()
122 (with-connection *postgresql-credentials
*
123 (let* ((user-name (post-parameter "user-name"))
124 (user-password (post-parameter "user-password"))
125 (presentation-project-id (session-value 'presentation-project-id
))
127 (when presentation-project-id
129 (:select
'user-full-name
130 :from
'sys-user-role
'sys-user
132 (:= 'presentation-project-id presentation-project-id
)
133 (:= 'sys-user-role.user-id
'sys-user.user-id
)
134 (:= 'user-name user-name
)
135 (:= 'user-password user-password
)))
139 (setf (session-value 'authenticated-p
) t
140 (session-value 'user-name
) user-name
141 (session-value 'user-full-name
) user-full-name
)
142 (redirect "/view" :add-session-id t
))
145 (define-easy-handler (logout :uri
"/logout") ()
146 (if (session-verify *request
*)
147 (progn (remove-session *session
*)
151 (define-easy-handler (test :uri
"/test") ()
154 (define-easy-handler (local-data :uri
"/local-data" :default-request-type
:post
) ()
155 "Receive coordinates, respond with the count nearest json objects containing picture url, calibration parameters, and car position, wrapped in an array."
156 (when (session-value 'authenticated-p
)
157 (let* ((presentation-project-id (session-value 'presentation-project-id
))
158 (common-table-names (common-table-names presentation-project-id
))
159 (data (json:decode-json-from-string
(raw-post-data)))
160 (longitude-input (cdr (assoc :longitude data
)))
161 (latitude-input (cdr (assoc :latitude data
)))
162 (count (cdr (assoc :count data
)))
163 (zoom-input (cdr (assoc :zoom data
)))
164 ;;(snap-distance (* 10d-5 (expt 2 (- 18 zoom-input)))) ; assuming geographic coordinates
165 (snap-distance (* 10d-1
(expt 2 (- 18 zoom-input
)))) ; assuming geographic coordinates
167 (format nil
"POINT(~F ~F)" longitude-input latitude-input
))
170 (with-connection *postgresql-credentials
*
172 for common-table-name in common-table-names
178 'date
;TODO: debug only
179 'measurement-id
'recorded-device-id
'device-stage-of-life-id
;TODO: debug only
181 'filename
'byte-position
'point-id
183 ;'coordinates ;the search target
184 'longitude
'latitude
'ellipsoid-height
186 'east-sd
'north-sd
'height-sd
187 'roll
'pitch
'heading
'roll-sd
'pitch-sd
'heading-sd
188 'sensor-width-pix
'sensor-height-pix
'pix-size
190 'dx
'dy
'dz
'omega
'phi
'kappa
191 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
192 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
193 'b-ddx
'b-ddy
'b-ddz
'b-drotx
'b-droty
'b-drotz
195 (aggregate-view-name common-table-name
)
197 (:and
(:= 'presentation-project-id presentation-project-id
)
198 (:st_dwithin
'coordinates
199 (:st_geomfromtext point-form
*standard-coordinates
*)
201 (:st_distance
'coordinates
202 (:st_geomfromtext point-form
*standard-coordinates
*)))
205 (json:encode-json-to-string result
))))
207 (defun common-table-names (presentation-project-id)
208 "Return a list of common-table-names of table sets that contain data
209 of presentation project with presentation-project-id."
211 (with-connection *postgresql-credentials
*
213 (:select
'common-table-name
215 :from
'sys-presentation
'sys-measurement
'sys-acquisition-project
217 (:= 'sys-presentation.presentation-project-id presentation-project-id
)
218 (:= 'sys-presentation.measurement-id
'sys-measurement.measurement-id
)
219 (:= 'sys-measurement.acquisition-project-id
'sys-acquisition-project.acquisition-project-id
)))
221 (condition (c) (cl-log:log-message
:server
"While fetching common-table-names of presentation-project-id ~D: ~A" presentation-project-id c
))))
223 (define-easy-handler (points :uri
"/points") (bbox)
224 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
225 (when (session-value 'authenticated-p
)
228 (concatenate 'string
"BOX3D("
229 (substitute #\Space
#\
,
230 (substitute #\Space
#\
, bbox
:count
1)
231 :from-end t
:count
1)
233 (common-table-names (common-table-names (session-value 'presentation-project-id
))))
234 (with-connection *postgresql-credentials
*
235 (json:encode-json-alist-to-string
237 'type
'*geometry-collection
242 (acons 'coordinates x nil
)))
244 for common-table-name in common-table-names
245 for point-table-name
= (make-symbol (concatenate 'string
"dat-" common-table-name
"-point"))
247 (query (:select
(:st_x
(:st_transform
'coordinates
*standard-coordinates
*))
248 (:st_y
(:st_transform
'coordinates
*standard-coordinates
*))
249 :from point-table-name
250 :where
(:&& (:st_transform
'coordinates
*standard-coordinates
*)
251 (:st_setsrid
(:type box3d-form box3d
) *standard-coordinates
*))))))
253 (condition (c) (cl-log:log-message
:server
"While fetching points from inside bbox ~S: ~A" bbox c
)))))
255 (define-easy-handler photo-handler
256 ((bayer-pattern :init-form
"#00ff00,#ff0000")
257 (color-raiser :init-form
"1,1,1"))
258 "Serve an image from a .pictures file."
259 (when (session-value 'authenticated-p
)
261 (let* ((s (cdr (cl-utilities:split-sequence
#\
/ (script-name*)
262 :remove-empty-subseqs t
)))
263 (directory (butlast s
2))
264 (file-name-and-type (cl-utilities:split-sequence
265 #\.
(first (last s
2))))
266 (byte-position (parse-integer (car (last s
)) :junk-allowed t
))
271 :directory
(append (pathname-directory *common-root
*)
272 directory
'(:wild-inferiors
))
273 :name
(first file-name-and-type
)
274 :type
(second file-name-and-type
)))))
276 (setf (content-type*) "image/png")
277 (setf stream
(send-headers))
278 (send-png stream path-to-file byte-position
279 :bayer-pattern
(canonicalize-bayer-pattern bayer-pattern
)
280 :color-raiser
(canonicalize-color-raiser color-raiser
)))
281 (condition (c) (cl-log:log-message
:server
"While serving image ~S: ~A" (request-uri*) c
)))))
283 (pushnew (create-prefix-dispatcher "/photo" 'photo-handler
)
286 (pushnew (create-folder-dispatcher-and-handler "/lib/" "") ;TODO: is this secure enough?
289 (define-easy-handler (phoros.js
:uri
"/phoros.js") ()
290 "Serve some Javascript."
291 (when (session-value 'authenticated-p
)
294 (setf debug-info
(@ *open-layers
*console info
))
297 (@ *open-layers
*control
*click
)
298 ((@ *open-layers
*class
)
299 (@ *open-layers
*control
)
300 (create :default-handler-options
309 (@ this handler-options
) ((@ *open-layers
*util extend
)
311 (@ this default-handler-options
)))
312 ((@ *open-layers
*control prototype initialize apply
)
314 (setf (@ this handler
)
315 (new ((@ *open-layers
*handler
*click
) this
316 (create :click
(@ this trigger
))
317 (@ this handler-options
))))))))
320 (new ((@ *open-layers
*projection
) "EPSG:4326")))
321 (setf spherical-mercator
322 (new ((@ *open-layers
*projection
) "EPSG:900913")))
324 (defvar images
(array) "Collection of the photos currently shown.")
325 (defvar streetmap
"The streetmap shown to the user.")
326 (defvar streetmap-estimated-position-layer
)
329 "Anything necessary to deal with a photo."
330 (setf (getprop this
'map
)
331 (new ((getprop *open-layers
'*map
)
332 (create projection spherical-mercator
334 (getprop this
'dummy
) false
;TODO why? (omitting splices map components directly into *image)
337 (setf (getprop *image
'prototype
'show-photo
) show-photo
)
338 (setf (getprop *image
'prototype
'draw-epipolar-line
) draw-epipolar-line
)
339 (setf (getprop *image
'prototype
'draw-active-point
) draw-active-point
)
340 (setf (getprop *image
'prototype
'draw-estimated-positions
)
341 draw-estimated-positions
)
343 (defun photo-path (photo-parameters)
344 "Create from stuff found in photo-parameters a path for use in
346 (+ "/photo/" (@ photo-parameters directory
) "/"
347 (@ photo-parameters filename
) "/"
348 (@ photo-parameters byte-position
) ".png"))
350 (defun has-layer-p (map layer-name
)
351 "False if map doesn't have a layer called layer-name."
352 (chain map
(get-layers-by-name layer-name
) length
))
354 (defun some-active-point-p ()
355 "False if no image in images has an Active Point."
358 sum
(has-layer-p (getprop i
'map
) "Active Point")))
360 (defun remove-layer (map layer-name
)
361 "Destroy layer layer-name in map."
362 (when (has-layer-p map layer-name
)
363 (chain map
(get-layers-by-name layer-name
) 0 (destroy))))
365 (defun remove-any-layers (layer-name)
366 "Destroy in all images and in streetmap the layer named layer-name."
368 for i across images do
(remove-layer (getprop i
'map
) layer-name
))
369 (remove-layer streetmap layer-name
))
371 (defun remove-work-layers ()
372 "Destroy user-generated layers in streetmap and in all images."
373 (remove-any-layers "Epipolar Line")
374 (remove-any-layers "Active Point")
375 (remove-any-layers "Estimated Position")
376 (setf pristine-images-p t
))
378 (defun present-photos ()
379 "Handle the response triggered by request-photos."
380 (let ((photo-parameters ((@ *json
* parse
)
381 (@ photo-request-response response-text
))))
383 for p across photo-parameters
386 (setf (getprop i
'photo-parameters
) p
)
387 ((getprop i
'show-photo
)))
388 ;; (setf (@ (aref photo-parameters 0) angle180) 1) ; Debug: coordinate flipping
391 (defun request-photos (event)
392 "Handle the response to a click into streetmap; fetch photo data."
393 (remove-any-layers "Estimated Position")
395 ((@ ((@ streetmap get-lon-lat-from-pixel
) (@ event xy
)) transform
)
396 spherical-mercator
; why?
399 ((@ *json
* stringify
)
400 (create :longitude
(@ lonlat lon
) ; TODO: use OpenLayer's JSON.
401 :latitude
(@ lonlat lat
)
402 :zoom
((@ streetmap get-zoom
))
403 :count
(lisp *number-of-images
*))))
404 (setf photo-request-response
405 ((@ *open-layers
*Request
*POST
*)
406 (create :url
"local-data"
408 :headers
(create "Content-type" "text/plain"
409 "Content-length" (@ content length
))
410 :success present-photos
)))))
412 (defun draw-epipolar-line ()
413 "Draw an epipolar line from response triggered by clicking
414 into a (first) photo."
415 (let ((epipolar-line ((@ *json
* parse
)
416 (@ this epipolar-request-response response-text
))))
417 (chain this epipolar-layer
419 (new ((@ *open-layers
*feature
*vector
)
420 (new ((@ *open-layers
*geometry
*line-string
)
421 ((@ epipolar-line map
)
423 (new ((@ *open-layers
*geometry
*point
)
424 (@ x
:m
) (@ x
:n
)))))))))))))
425 ;; either *line-string or *multi-point are usable
427 (defun draw-estimated-positions ()
428 "Draw into streetmap and into all images points at Estimated
429 Position. Estimated Position is the point returned so far from
430 photogrammetric calculations that are triggered by clicking into
432 (let* ((estimated-positions-request-response
435 'estimated-positions-request-response
438 (aref estimated-positions-request-response
0))
440 (aref estimated-positions-request-response
1)))
441 (debug-info global-position
)
442 (setf streetmap-estimated-position-layer
443 (new ((@ *open-layers
*layer
*vector
) "Estimated Position")))
444 (chain streetmap-estimated-position-layer
446 (new ((@ *open-layers
*feature
*vector
)
447 ((@ (new ((@ *open-layers
*geometry
*point
)
448 (getprop global-position
'longitude
)
449 (getprop global-position
'latitude
)))
450 transform
) geographic spherical-mercator
)))))
451 ((@ streetmap add-layer
) streetmap-estimated-position-layer
)
454 for p in estimated-positions
456 (setf (@ i estimated-position-layer
)
457 (new ((@ *open-layers
*layer
*vector
) "Estimated Position")))
458 ((@ i map add-layer
) (@ i estimated-position-layer
))
459 (chain i estimated-position-layer
461 (new ((@ *open-layers
*feature
*vector
)
462 (new ((@ *open-layers
*geometry
*point
)
464 (getprop p
'n
))))))))))
466 (defun draw-active-point ()
467 "Draw an Active Point, i.e. a point used in subsequent
468 photogrammetric calculations."
469 (chain this active-point-layer
471 (new ((@ *open-layers
*feature
*vector
)
472 (new ((@ *open-layers
*geometry
*point
)
473 (getprop this
'photo-parameters
'm
)
474 (getprop this
'photo-parameters
'n
))))))))
476 (defun image-click-action (clicked-image)
478 "Do appropriate things when an image is clicked into."
480 ((@ (@ clicked-image map
) get-lon-lat-from-view-port-px
)
483 (getprop clicked-image
'photo-parameters
))
484 pristine-image-p content request
)
485 (setf (@ photo-parameters m
) (@ lonlat lon
)
486 (@ photo-parameters n
) (@ lonlat lat
))
487 (remove-layer (getprop clicked-image
'map
) "Active Point")
488 (remove-any-layers "Epipolar Line")
489 (setf pristine-images-p
(not (some-active-point-p)))
490 (setf (@ clicked-image active-point-layer
)
491 (new ((@ *open-layers
*layer
*vector
) "Active Point")))
492 ((@ clicked-image map add-layer
)
493 (@ clicked-image active-point-layer
))
494 ((getprop clicked-image
'draw-active-point
))
499 for i across images do
500 (unless (== i clicked-image
)
502 (@ i epipolar-layer
) (new ((@ *open-layers
*layer
*vector
)
504 content
((@ *json
* stringify
)
505 (append (array photo-parameters
)
506 (@ i photo-parameters
)))
507 (@ i epipolar-request-response
)
508 ((@ *open-layers
*Request
*POST
*)
509 (create :url
"epipolar-line"
511 :headers
(create "Content-type" "text/plain"
514 :success
(getprop i
'draw-epipolar-line
)
516 ((@ i map add-layer
) (@ i epipolar-layer
)))))
518 (remove-any-layers "Epipolar Line")
519 (remove-any-layers "Estimated Position")
520 (let* ((active-pointed-photo-parameters
523 when
(has-layer-p (getprop i
'map
) "Active Point")
524 collect
(getprop i
'photo-parameters
)))
526 ((@ *json
* stringify
)
527 (list active-pointed-photo-parameters
531 x
'photo-parameters
))))))))
532 (setf (@ clicked-image estimated-positions-request-response
)
533 ((@ *open-layers
*Request
*POST
*)
534 (create :url
"estimated-positions"
536 :headers
(create "Content-type" "text/plain"
539 :success
(getprop clicked-image
540 'draw-estimated-positions
)
541 :scope clicked-image
)))))))))
543 "Show the photo described in this object's photo-parameters."
545 repeat
((getprop this
'map
'get-num-layers
))
546 do
((getprop this
'map
'layers
0 'destroy
)))
547 ((getprop this
'map
'add-layer
)
548 (new ((@ *open-layers
*layer
*image
)
550 (photo-path (getprop this
'photo-parameters
))
551 (new ((@ *open-layers
*bounds
) -
.5 -
.5
552 (+ (getprop this
'photo-parameters
'sensor-width-pix
)
554 (+ (getprop this
'photo-parameters
'sensor-height-pix
)
555 .5))) ; coordinates shown
556 (new ((@ *open-layers
*size
) 512 256))
558 ((getprop this
'map
'zoom-to-extent
)
559 (new ((@ *open-layers
*bounds
) -
.5 -
.5
560 (1+ (getprop this
'photo-parameters
'sensor-width-pix
))
561 (1+ (getprop this
'photo-parameters
'sensor-height-pix
)))))) ; in coordinates shown
563 (defun initialize-image (image-index)
564 "Create an image usable for displaying photos at position
565 image-index in array images."
566 (setf (aref images image-index
) (new *image
))
567 (setf (@ (aref images image-index
) image-click-action
)
568 (image-click-action (aref images image-index
)))
569 (setf (@ (aref images image-index
) click
)
570 (new ((@ *open-layers
*control
*click
)
571 (create :trigger
(@ (aref images image-index
)
572 image-click-action
)))))
573 ((@ (aref images image-index
) map add-control
)
574 (@ (aref images image-index
) click
))
575 ((@ (aref images image-index
) click activate
))
576 ((@ (aref images image-index
) map add-control
)
577 (new ((@ *open-layers
*control
*mouse-position
))))
578 ((@ (aref images image-index
) map add-control
)
579 (new ((@ *open-layers
*control
*layer-switcher
))))
580 ((@ (aref images image-index
) map render
) (+ image-index
"")))
583 "Prepare user's playground."
588 (create projection geographic
589 display-projection geographic
)))))
591 (new (chain *open-layers
*layer
597 (chain *open-layers
*strategy
598 (*bbox
* (create :ratio
1.1)))))
601 *open-layers
*protocol
607 (chain *open-layers
*format
610 external-projection geographic
611 internal-projection geographic
)))))))))))))
612 ;;(google (new ((@ *open-layers *Layer *google) "Google Streets")))
613 (osm-layer (new (chain *open-layers
*layer
(*osm
*))))
615 (new (chain *open-layers
*control
(*overview-map
620 (new (chain *open-layers
*control
621 (*click
(create :trigger request-photos
))))))
622 (chain streetmap
(add-control click-streetmap
))
623 (chain click-streetmap
(activate))
624 ;;((@ map add-layers) (array osm-layer google survey-layer))
625 (chain streetmap
(add-layers (array survey-layer osm-layer
)))
628 (new (chain *open-layers
*control
(*layer-switcher
)))))
631 (new (chain *open-layers
*control
(*mouse-position
)))))
632 (chain streetmap
(add-control streetmap-overview
))
635 (chain (new (chain *open-layers
637 14.32066 51.72693 14.32608 51.72862)))
638 (transform geographic spherical-mercator
)))))
640 for i from
0 to
(lisp (1- *number-of-images
*))
642 (initialize-image i
))))))
644 (define-easy-handler (view :uri
"/view" :default-request-type
:post
) ()
645 "Serve the client their main workspace."
647 (session-value 'authenticated-p
)
648 (who:with-html-output-to-string
(s nil
:indent t
)
650 :xmlns
"http://www.w3.org/1999/xhtml"
655 "Phoros: " (session-value 'presentation-project-name
))))
656 ;;(:link :rel "stylesheet" :href "lib/theme/default/style.css" :type "text/css")
657 (:link
:rel
"stylesheet" :href
"lib/style.css" :type
"text/css")
658 (:script
:src
"lib/openlayers/lib/Firebug/firebug.js") ;TODO: tie to --verbose
659 (:script
:src
"lib/openlayers/lib/OpenLayers.js")
660 (:script
:src
"lib/openlayers/lib/proj4js.js") ;TODO: we should be able to make this redundant.
661 (:script
:src
"/phoros.js")
662 ;;(:script :src "http://maps.google.com/maps/api/js?sensor=false")
664 (:body
:onload
(ps (init))
665 (:h1
:id
"title" (who:str
(concatenate 'string
"Phoros: " (session-value 'presentation-project-name
))))
667 "unfinished prototype")
668 (:div
:id
"finish-point-button" :style
"float:left" (:button
:type
"button" :onclick
(ps ()) "finish point"))
669 (:div
:id
"remove-work-layers-button" :style
"float:left" (:button
:type
"button" :onclick
(ps (remove-work-layers)) "start over (keep photos)"))
670 (:div
:id
"blurb-button" :style
"float:left" (:button
:type
"button" :onclick
"self.location.href = \"/blurb\"" "blurb"))
671 (:div
:id
"logout-button" :style
"float:left" (:button
:type
"button" :onclick
"self.location.href = \"/logout\"" "bye"))
673 (:div
:style
"clear:both"
674 (:div
:id
"streetmap" :class
"smallmap" :style
"float:left")
676 for i from
0 to
(1- *number-of-images
*) do
677 (who:htm
(:div
:id i
:class
"image" :style
"float:left")))))))
679 (concatenate 'string
"/phoros/" (session-value 'presentation-project-name
))
682 (define-easy-handler (epipolar-line :uri
"/epipolar-line") ()
683 "Receive vector of two sets of picture parameters, respond with
684 JSON encoded epipolar-lines."
685 (when (session-value 'authenticated-p
)
686 (let* ((data (json:decode-json-from-string
(raw-post-data))))
687 (json:encode-json-to-string
(photogrammetry :epipolar-line
(first data
) (second data
))))))
689 (define-easy-handler (estimated-positions :uri
"/estimated-positions") ()
690 "Receive a two-part JSON vector comprising (1) a vector containing
691 sets of picture-parameters including clicked points stored in :m, :n;
692 and (2) a vector containing sets of picture-parameters; respond with
693 a JSON encoded two-part vector comprising (1) a point in global
694 coordinates; and (2) a vector of image coordinates (m, n) for the
695 global point that correspond to the images from the received second
696 vector. TODO: report error on bad data (ex: points too far apart)."
697 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
698 (when (session-value 'authenticated-p
)
699 (let* ((data (json:decode-json-from-string
(raw-post-data)))
700 (active-point-photo-parameters (first data
))
701 (destination-photo-parameters (second data
))
702 (cartesian-system (cdr (assoc :cartesian-system
(first active-point-photo-parameters
))))
703 (global-point-cartesian (photogrammetry :multi-position-intersection active-point-photo-parameters
))
704 (global-point-geographic-radians
705 (proj:cs2cs
(list (cdr (assoc :x-global global-point-cartesian
))
706 (cdr (assoc :y-global global-point-cartesian
))
707 (cdr (assoc :z-global global-point-cartesian
)))
708 :source-cs cartesian-system
))
709 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
710 (pairlis '(:longitude
:latitude
:ellipsoid-height
711 :stdx-global
:stdy-global
:stdz-global
)
713 (proj:radians-to-degrees
(first global-point-geographic-radians
))
714 (proj:radians-to-degrees
(second global-point-geographic-radians
))
715 (third global-point-geographic-radians
)
716 (cdr (assoc :stdx-global global-point-cartesian
))
717 (cdr (assoc :stdy-global global-point-cartesian
))
718 (cdr (assoc :stdz-global global-point-cartesian
)))))
721 for i in destination-photo-parameters
722 collect
(photogrammetry :reprojection i global-point-cartesian
))))
723 (json:encode-json-to-string
724 (list global-point-for-display image-coordinates
)))))
726 (define-easy-handler (multi-position-intersection :uri
"/intersection") ()
727 "Receive vector of sets of picture parameters, respond with stuff."
728 (when (session-value 'authenticated-p
)
729 (let* ((data (json:decode-json-from-string
(raw-post-data))))
730 (json:encode-json-to-string
(photogrammetry :multi-position-intersection data
)))))
732 (defgeneric photogrammetry
(mode photo-1
&optional photo-2
)
733 (:documentation
"Call to photogrammetry library. Dispatch on mode."))
735 (defmethod photogrammetry :around
(mode clicked-photo
&optional other-photo
)
736 "Prepare and clean up a run of photogrammetry."
737 (declare (ignore other-photo
))
738 (bt:with-lock-held
(*photogrammetry-mutex
*)
744 (defmethod photogrammetry ((mode (eql :epipolar-line
)) clicked-photo
&optional other-photo
)
745 "Return in an alist an epipolar line in coordinates of other-photo from m and n in clicked-photo."
746 (add-cam* clicked-photo
)
747 (add-bpoint* clicked-photo
)
748 (add-global-car-reference-point* clicked-photo t
)
749 (add-cam* other-photo
)
750 (add-global-car-reference-point* other-photo t
)
752 for i
= 2d0 then
(* i
1.4) until
(> i
50)
754 (set-distance-for-epipolar-line i
)
755 when
(ignore-errors (calculate))
756 collect
(pairlis '(:m
:n
) (list (flip-m-maybe (get-m) other-photo
)
757 (flip-n-maybe (get-n) other-photo
)))))
759 (defmethod photogrammetry ((mode (eql :reprojection
)) photo
&optional global-point
)
760 "Calculate reprojection from photo."
762 (add-global-measurement-point* global-point
)
763 (add-global-car-reference-point* photo
)
764 (set-global-reference-frame)
767 (list (flip-m-maybe (get-m) photo
) (flip-n-maybe (get-n) photo
))))
769 (defmethod photogrammetry ((mode (eql :multi-position-intersection
)) photos
&optional other-photo
)
770 "Calculate intersection from photos."
771 (declare (ignore other-photo
))
772 (set-global-reference-frame)
778 (add-global-car-reference-point* photo t
))
780 (pairlis '(:x-global
:y-global
:z-global
781 :stdx-global
:stdy-global
:stdz-global
)
783 (get-x-global) (get-y-global) (get-z-global)
784 (get-stdx-global) (get-stdy-global) (get-stdz-global))))
786 (defmethod photogrammetry ((mode (eql :intersection
)) photo
&optional other-photo
)
787 "Calculate intersection from two photos that are taken out of the
788 same local coordinate system. (Used for debugging only)."
791 (add-cam* other-photo
)
792 (add-bpoint* other-photo
)
794 (pairlis '(:x-local
:y-local
:z-local
795 :stdx-local
:stdy-local
:stdz-local
)
797 (get-x-local) (get-y-local) (get-z-local)
798 (get-stdx-local) (get-stdy-local) (get-stdz-local)
799 (get-x-global) (get-y-global) (get-z-global))))
801 (defmethod photogrammetry ((mode (eql :mono
)) photo
&optional floor
)
802 "Return in an alist the intersection point of the ray through m and n in photo, and floor."
805 (add-ref-ground-surface* floor
)
806 (add-global-car-reference-point* photo
)
807 (set-global-reference-frame)
809 (pairlis '(:x-global
:y-global
:z-global
)
811 (get-x-global) (get-y-global) (get-z-global))))
813 (defun flip-m-maybe (m photo
)
814 "Flip coordinate m when :mounting-angle in photo suggests it necessary."
815 (if (= 180 (cdr (assoc :mounting-angle photo
)))
816 (- (cdr (assoc :sensor-width-pix photo
)) m
)
818 (defun flip-n-maybe (n photo
)
819 "Flip coordinate n when :mounting-angle in photo suggests it necessary."
820 (if (zerop (cdr (assoc :mounting-angle photo
)))
821 (- (cdr (assoc :sensor-height-pix photo
)) n
)
824 (defun photogrammetry-arglist (alist &rest keys
)
825 "Construct an arglist from alist values corresponding to keys."
826 (mapcar #'(lambda (x) (cdr (assoc x alist
))) keys
))
828 (defun add-cam* (photo-alist)
829 "Call add-cam with arguments taken from photo-alist."
831 (photogrammetry-arglist
832 photo-alist
:sensor-height-pix
:sensor-width-pix
))
834 (mapcar #'(lambda (x) (coerce x
'double-float
))
835 (photogrammetry-arglist photo-alist
837 :dx
:dy
:dz
:omega
:phi
:kappa
839 :a-1
:a-2
:a-3
:b-1
:b-2
:c-1
:c-2
:r-0
840 :b-dx
:b-dy
:b-dz
:b-ddx
:b-ddy
:b-ddz
841 :b-rotx
:b-roty
:b-rotz
842 :b-drotx
:b-droty
:b-drotz
))))
843 (apply #'add-cam
(nconc integer-args double-float-args
))))
845 (defun add-bpoint* (photo-alist)
846 "Call add-bpoint with arguments taken from photo-alist."
847 (add-bpoint (coerce (flip-m-maybe (cdr (assoc :m photo-alist
)) photo-alist
) 'double-float
)
848 (coerce (flip-n-maybe (cdr (assoc :n photo-alist
)) photo-alist
) 'double-float
)))
850 (defun add-ref-ground-surface* (floor-alist)
851 "Call add-ref-ground-surface with arguments taken from floor-alist."
852 (let ((double-float-args
853 (mapcar #'(lambda (x) (coerce x
'double-float
))
854 (photogrammetry-arglist floor-alist
856 (apply #'add-ref-ground-surface double-float-args
)))
858 (defun add-global-car-reference-point* (photo-alist &optional cam-set-global-p
)
859 "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."
860 (let* ((longitude-radians (proj:degrees-to-radians
(car (photogrammetry-arglist photo-alist
:longitude
))))
861 (latitude-radians (proj:degrees-to-radians
(car (photogrammetry-arglist photo-alist
:latitude
))))
862 (ellipsoid-height (car (photogrammetry-arglist photo-alist
:ellipsoid-height
)))
863 (destination-cs (car (photogrammetry-arglist photo-alist
:cartesian-system
)))
864 (cartesian-coordinates
865 (proj:cs2cs
(list longitude-radians latitude-radians ellipsoid-height
)
866 :destination-cs destination-cs
))
868 (mapcar #'(lambda (x) (coerce x
'double-float
))
869 (photogrammetry-arglist photo-alist
870 :roll
:pitch
:heading
871 :latitude
:longitude
)))
873 (nconc cartesian-coordinates other-args
)))
874 (apply (if cam-set-global-p
875 #'add-global-car-reference-point-cam-set-global
876 #'add-global-car-reference-point
)
879 (defun add-global-measurement-point* (point)
880 "Call add-global-measurement-point with arguments taken from point."
881 (let ((double-float-args
882 (mapcar #'(lambda (x) (coerce x
'double-float
))
883 (photogrammetry-arglist point
884 :x-global
:y-global
:z-global
))))
885 (apply #'add-global-measurement-point double-float-args
)))