1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011, 2012, 2017 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.
21 (defun collect-pictures-file-data (path)
22 "Return vector of image-data objects containing data from the
23 picture-headers of the .pictures file in path."
24 (let ((estimated-header-length
26 (- (img:find-keyword path
"PICTUREHEADER_END")
27 (img:find-keyword path
"PICTUREHEADER_BEGIN")
28 ;; allow for variation in dataSize and a few other parameters:
29 img
:*picture-header-length-tolerance
*))))
30 (if estimated-header-length
;otherwise we don't have a decent header.
31 ;; TODO: find-keyword-value causes a lot of open. Try opening
32 ;; the file twice and file-positioning around using
33 ;; find-keyword-value-in-stream which is yet to be written.
34 (with-open-file (stream path
:element-type
'unsigned-byte
)
35 (cl-log:log-message
:db-dat
"Digesting ~A." path
)
37 with pictures-data
= (make-array '(600) :fill-pointer
0)
39 (img:find-keyword-in-stream stream
"PICTUREHEADER_BEGIN" 0) then
40 (img:find-keyword-in-stream stream
"PICTUREHEADER_BEGIN"
41 (+ picture-start picture-length
42 estimated-header-length
))
43 for picture-length
= (img:find-keyword-value
44 path
"dataSize=" picture-start
45 estimated-header-length
)
46 and time-trigger
= (utc-from-unix
48 (img:find-keyword-value
49 path
"timeTrigger=" picture-start
50 estimated-header-length
)
52 and timestamp
= (img:find-keyword-value
53 path
"cameraTimestamp=" picture-start
54 estimated-header-length
)
55 and recorded-device-id
= (format
57 (img:find-keyword-value
58 path
"cam=" picture-start
59 estimated-header-length
))
60 and gain
= (img:find-keyword-value
61 path
"gain=" picture-start estimated-header-length
)
62 and shutter
= (img:find-keyword-value
63 path
"shutter=" picture-start
64 estimated-header-length
)
66 do
(vector-push-extend
69 :trigger-time time-trigger
70 :camera-timestamp timestamp
71 :recorded-device-id recorded-device-id
72 :filename
(file-namestring path
)
74 :footprint-device-stage-of-life-id
:null
77 :byte-position picture-start
)
80 (repair-missing-trigger-times pictures-data
)
81 (return pictures-data
)))
83 :db-dat
"Skipping ~A because it looks disgusting." path
))))
85 (defun repair-missing-trigger-times (images)
86 "Use slot camera-timestamp to fake missing trigger-times."
87 (labels ((slope (offending-index good-index
)
88 (/ (- (trigger-time (aref images
(+ offending-index
90 (trigger-time (aref images
(+ offending-index
92 (- (camera-timestamp (aref images
(+ offending-index
94 (camera-timestamp (aref images
(+ offending-index
95 (+ good-index
2)))))))
96 (intercept (offending-index good-index slope
)
97 (- (trigger-time (aref images
(+ offending-index good-index
)))
98 (* slope
(camera-timestamp (aref images
(+ offending-index
100 (fake-trigger-time (offending-index good-index
)
101 (let* ((m (slope offending-index good-index
))
102 (t-0 (intercept offending-index good-index m
)))
103 (+ (* m
(camera-timestamp (aref images offending-index
)))
105 (dolist (offending-index
107 with previous-trigger-time
= 0
110 for trigger-time
= (trigger-time h
)
111 if
(> (+ trigger-time
1d-4
) previous-trigger-time
)
112 do
(setf previous-trigger-time trigger-time
)
115 (let ((good-index-offset -
3))
116 (handler-bind ((error #'(lambda (x) (declare (ignore x
))
117 (invoke-restart 'next-try
))))
118 (setf (trigger-time (aref images offending-index
))
120 (fake-trigger-time offending-index good-index-offset
)
122 (incf good-index-offset
6)
123 (fake-trigger-time offending-index good-index-offset
)))
124 (fake-trigger-time-p (aref images offending-index
)) t
)))))))
126 (defun collect-pictures-directory-data (dir-path)
127 "Return vector of instances of class image-data with data from the
128 .pictures files in dir-path."
129 (let ((pictures-files
130 (directory (make-pathname
131 :directory
(append (pathname-directory dir-path
)
133 :name
:wild
:type
"pictures"))))
134 (assert pictures-files
()
135 "Sorry, but I couldn't find a single .pictures file below ~A."
137 (reduce #'(lambda (x1 x2
) (merge 'vector x1 x2
#'< :key
#'trigger-time
))
138 (mapcar #'collect-pictures-file-data
141 (defun collect-gps-data (dir-path estimated-utc
)
142 "Put content of files in dir-path/**/applanix/*eventN.txt into
143 vectors. Return a list of elements (N vector) where N is the event
147 :directory
(append (pathname-directory dir-path
)
148 '(:wild-inferiors
) '("applanix" "points"))
151 (gps-files (directory event-dir
))
154 for gps-file in gps-files
155 for gps-basename
= (pathname-name gps-file
)
156 for event-number
= (ignore-errors
161 (search "event" gps-basename
163 when event-number collect
(list event-number gps-file
))))
164 (assert gps-event-files
()
165 "Sorry, but I couldn't find a single GPS event file in ~A."
166 (directory-namestring event-dir
))
168 :db-dat
"Digesting GPS data from ~{~A~#^, ~}."
169 (mapcar #'cadr gps-event-files
))
171 for gps-event-file-entry in gps-event-files
172 for gps-event-number
= (first gps-event-file-entry
)
173 for gps-event-file
= (second gps-event-file-entry
)
177 (with-open-file (stream gps-event-file
)
179 for line
= (read-line stream
)
182 (string-trim "
" line
)
183 "(time in Sec, distance in Meters, position in Meters, lat, long in Degrees, orientation angles and SD in Degrees, velocity in Meter/Sec, position SD in Meters)")
187 "Unfamiliar header. Check Applanix file format." nil
))
189 with gps-points
= (make-array '(1000) :fill-pointer
0)
190 for line
= (read-line stream nil
)
192 do
(vector-push-extend
193 (let ((point (make-instance 'point-data
)))
197 longitude latitude ellipsoid-height
199 east-velocity north-velocity up-velocity
200 east-sd north-sd height-sd
201 roll-sd pitch-sd heading-sd
202 easting northing cartesian-height
)
204 (with-input-from-string (line-content line
)
205 (setf event-number gps-event-number
207 (utc-from-gps estimated-utc
;From GPS week time.
208 (read line-content nil
)))
209 (read line-content nil
) ;Discard distance.
210 (setf easting
(read line-content nil
)
211 northing
(read line-content nil
)
212 cartesian-height
(read line-content nil
)
213 latitude
(read line-content nil
)
214 longitude
(read line-content nil
)
215 ellipsoid-height
(read line-content nil
)
216 roll
(read line-content nil
)
217 pitch
(read line-content nil
)
218 heading
(read line-content nil
)
219 east-velocity
(read line-content nil
)
220 north-velocity
(read line-content nil
)
221 up-velocity
(read line-content nil
)
222 east-sd
(read line-content nil
)
223 north-sd
(read line-content nil
)
224 height-sd
(read line-content nil
)
225 roll-sd
(read line-content nil
)
226 pitch-sd
(read line-content nil
)
227 heading-sd
(read line-content nil
))))
230 finally
(return gps-points
)))))))
232 (defun aggregate-gps-events (gps-points)
233 "Turn an alist of ((event1 . points1) (event2 . points2)...) into
237 "I was asked to aggregate-events so I won't distinguish any event numbers.")
239 (cons t
(reduce #'(lambda (x y
) (merge 'vector x y
#'< :key
#'gps-time
))
240 (mapcar #'cdr gps-points
)))))
242 (defparameter *leap-seconds
* nil
243 "An alist of (time . leap-seconds) elements. leap-seconds are to be
244 added to GPS time to get UTC.")
246 (defparameter *time-steps-history-url
*
247 "http://hpiers.obspm.fr/eoppc/bul/bulc/TimeSteps.history"
248 "URL of the leap second table which should contain lines like this:
253 (defparameter *time-steps-history-file
*
254 (make-pathname :directory
'(:relative
) :name
"TimeSteps" :type
"history")
255 "Fallback in case *time-steps-history-url* is unavailable.")
257 (let ((leap-second-months
258 (pairlis '("Jan" "Feb" "March" "Apr" "May" "Jun"
259 "Jul" "Aug" "Sept" "Oct" "Nov" "Dec")
260 '(1 2 3 4 5 6 7 8 9 10 11 12))))
261 ;; Month names (sans any `.') as used in
262 ;; http://hpiers.obspm.fr/eoppc/bul/bulc/TimeSteps.history."
263 (defun initialize-leap-seconds ()
266 (body status-code headers uri stream must-close reason-phrase
)
267 (drakma:http-request
*time-steps-history-url
*)
268 (declare (ignore headers stream must-close reason-phrase
))
269 (assert (= status-code
200))
270 (with-open-file (stream *time-steps-history-file
*
272 :if-exists
:supersede
273 :if-does-not-exist
:create
)
274 (write-string body stream
)
276 :debug
"Downloaded leap second information from ~A." uri
)))
280 "Couldn't get the latest leap seconds information from ~A. (~A) ~
281 Falling back to cached data in ~A."
282 *time-steps-history-url
* e
*time-steps-history-file
*)))
283 (with-open-file (stream *time-steps-history-file
*
284 :direction
:input
:if-does-not-exist
:error
)
285 (let ((leap-second-records
288 for raw-time-record
= (read-line stream nil nil
)
289 while raw-time-record
290 for
(raw-year raw-month raw-date raw-sign raw-seconds
)
291 = (cl-utilities:split-sequence
293 (nsubstitute #\Space
#\Tab raw-time-record
)
294 :remove-empty-subseqs t
)
295 for year
= (when raw-year
296 (parse-integer raw-year
:junk-allowed t
))
297 for month
= (when raw-month
298 (cdr (assoc (string-trim "." raw-month
)
300 :test
#'string-equal
)))
301 for date
= (when raw-date
302 (parse-integer raw-date
:junk-allowed t
))
303 for sign
= (when raw-sign
304 (if (string-equal raw-sign
"-") -
1 1))
305 for seconds
= (when raw-seconds
306 (parse-integer raw-seconds
:junk-allowed t
))
307 when
(and year
(< 1980 year
))
308 collect
(list (encode-universal-time 0 0 0 date month year
0)
314 for
(leap-date leap
) in leap-second-records
315 sum leap into leap-sum
316 collect leap-date into leap-dates
317 collect leap-sum into leap-sums
319 (return (reverse (pairlis leap-dates leap-sums
)))))))))
321 (defparameter *gps-epoch
* (encode-universal-time 0 0 0 6 1 1980 0))
322 (defparameter *unix-epoch
* (encode-universal-time 0 0 0 1 1 1970 0))
324 (defun gps-start-of-week (time)
325 "Begin of a GPS week (approximately Sunday 00:00)"
326 (let ((week-length (* 7 24 3600))
327 (leap-seconds (cdr (find time
*leap-seconds
*
328 :key
#'car
:test
#'> :from-end t
))))
329 (assert leap-seconds
()
330 "Couldn't determine leap seconds for ~A" (timestring (round time
)))
331 (+ (* (floor (- time
*gps-epoch
*) week-length
)
336 (defun utc-from-gps (utc-approximately gps-week-time
)
337 "Convert GPS week time into UTC. gps-week-time may be of type
338 float; in this case a non-integer is returned which can't be fed into
339 decode-universal-time."
340 (+ (gps-start-of-week utc-approximately
) gps-week-time
))
342 (defun utc-from-unix (unix-time)
343 "Convert UNIX UTC to Lisp time."
344 (when unix-time
(+ unix-time
*unix-epoch
*)))
346 (let (event-number-storage)
347 (defun device-event-number (recorded-device-id utc
)
348 "Return the GPS event number (a string) corresponding to
349 recorded-device-id (a string) of camera (etc.)"
350 (let ((device-event-number
351 (cdr (assoc recorded-device-id event-number-storage
352 :test
#'string-equal
))))
353 (if device-event-number
355 (let* ((date (simple-date:universal-time-to-timestamp
(round utc
)))
356 (device-stage-of-life
359 'sys-device-stage-of-life
362 (:least
:current-date
'unmounting-date
))
363 (:set
(:date date
) (:date date
)))
364 (:= 'recorded-device-id recorded-device-id
))))))
365 (assert device-stage-of-life
367 "Can't figure out what event-number belongs to ~
368 recorded-device-id ~S of (approx.) ~A. ~
369 There should be some entry in table ~
370 sys-device-stage-of-life to this end."
371 recorded-device-id
(timestring (round utc
)))
372 (push (cons recorded-device-id
(event-number device-stage-of-life
))
373 event-number-storage
)
374 (event-number device-stage-of-life
))))))
376 (defun almost= (x y epsilon
)
377 (< (abs (- x y
)) epsilon
))
379 (defun geographic-to-utm (utm-zone longitude latitude
&optional
(height 0d0
))
380 "Return UTM utm-zone representation of geographic coordinates."
381 (let ((utm-coordinate-system
382 (format nil
"+proj=utm +ellps=WGS84 +zone=~D" utm-zone
)))
383 (proj:cs2cs
(list (proj:degrees-to-radians longitude
)
384 (proj:degrees-to-radians latitude
) height
)
385 :destination-cs utm-coordinate-system
)))
387 (defun utm-zone (longitude)
388 "Return UTM zone number belonging to longitude."
389 (1+ (floor (+ longitude
180) 6)))
391 (defun assert-utm-zone (longitude-median longitude-leeway longitude latitude
392 geographic-height easting northing cartesian-height
)
393 "Check if, given longitude and latitude, easting and northing are
394 calculated in the UTM zone belonging to longitude-median."
395 (let ((epsilon 1d-1
))
397 (or (every #'(lambda (x y
) (almost= x y epsilon
))
398 (geographic-to-utm (utm-zone (- longitude-median
400 longitude latitude geographic-height
)
401 (list easting northing cartesian-height
))
402 (every #'(lambda (x y
) (almost= x y epsilon
))
403 (geographic-to-utm (utm-zone (+ longitude-median
405 longitude latitude geographic-height
)
406 (list easting northing cartesian-height
)))
407 (error "The longitude median ~A should be in or near UTM zone ~D. ~
408 This is inconsistent with the easting values I was given. ~
409 Offending coordinates: (~A ~A ~A) (~A ~A ~A)."
410 longitude-median
(utm-zone longitude-median
) longitude latitude
411 geographic-height easting northing cartesian-height
))))
413 (defun assert-gps-points-sanity (gps-points)
414 "Check if gps-points (as returned by collect-gps-data) are ok.
415 Return the Proj.4 string describing the cartesian coordinate system
418 for gps-event in gps-points
419 for gps-event-vector
= (cdr gps-event
)
420 for first-longitude
= (longitude (aref gps-event-vector
0))
421 for first-latitude
= (latitude (aref gps-event-vector
0))
422 for first-geographic-height
= (ellipsoid-height (aref gps-event-vector
0))
423 for first-easting
= (easting (aref gps-event-vector
0))
424 for first-northing
= (northing (aref gps-event-vector
0))
425 for first-cartesian-height
= (cartesian-height (aref gps-event-vector
0))
426 for longitude-median
=
428 for point across gps-event-vector
430 sum
(longitude point
) into longitude-sum
431 finally
(return (/ longitude-sum i
)))
432 do
(assert-utm-zone longitude-median
1
433 first-longitude first-latitude
434 first-geographic-height
435 first-easting first-northing
436 first-cartesian-height
)
437 finally
(return (format nil
"+proj=utm +ellps=WGS84 +zone=~D"
438 (utm-zone longitude-median
)))))
440 (defun get-measurement-id (common-table-name dir-path cartesian-system
)
441 "Get measurement-id associated with dir-path and
442 acquisition-project-id. Create a fresh matching record if necessary."
443 (let ((acquisition-project
444 (car (select-dao 'sys-acquisition-project
445 (:= 'common-table-name common-table-name
)))))
446 (assert acquisition-project
)
447 (let* ((acquisition-project-id (acquisition-project-id acquisition-project
))
451 (:and
(:= 'acquisition-project-id acquisition-project-id
)
452 (:= 'directory dir-path
))))
454 (make-instance 'sys-measurement
455 :acquisition-project-id acquisition-project-id
457 :cartesian-system cartesian-system
458 :fetch-defaults t
)))))
459 (measurement-id measurement
))))
461 (defun store-images-and-points (common-table-name dir-path
463 (root-dir (user-homedir-pathname))
465 "Link images to GPS points; store both into their respective DB
466 tables. Images become linked to GPS points when their respective
467 times differ by less than epsilon seconds, and when the respective
468 events match. dir-path is a (probably absolute) path to a directory
469 that contains one set of measuring data. root-dir must be equal for
471 ;; TODO: epsilon could be a range. We would do a raw mapping by (a bigger) time epsilon and then take speed into account.
473 (every #'string
= (namestring root-dir
) (namestring dir-path
))
474 () "~A is not a leading part of ~A." root-dir dir-path
)
475 (assert-phoros-db-major-version)
476 (assert ;not strictly necessary, but may save the user some time
477 (select-dao 'sys-acquisition-project
478 (:= 'common-table-name common-table-name
))
479 () "There is no acquisition project named ~A." common-table-name
)
480 (setf *random-state
* (make-random-state t
))
481 (create-data-table-definitions common-table-name
)
482 (initialize-leap-seconds)
484 (collect-pictures-directory-data dir-path
))
488 unless
(or (fake-trigger-time-p i
)
489 (< (trigger-time i
) *gps-epoch
*))
490 do
(return (trigger-time i
))))
493 (aggregate-gps-events (collect-gps-data dir-path estimated-time
))
494 (collect-gps-data dir-path estimated-time
)))
495 (gps-start-pointers (loop
497 collect
(cons (car i
) 0)))
498 (mapped-image-counter (length images
))
499 (cartesian-system (assert-gps-points-sanity gps-points
))
500 (dir-below-root-dir (enough-namestring dir-path root-dir
)))
502 :db-dat
"I assume this measure was taken approximately ~A."
503 (timestring (round estimated-time
)))
506 for image-event-number
= (or aggregate-events
507 (device-event-number (recorded-device-id i
)
509 for image-time
= (trigger-time i
)
511 (when image-time
;otherwise this image is junk
512 (let ((gps-start-pointer
513 (cdr (assoc image-event-number gps-start-pointers
515 (assert gps-start-pointer
()
516 "Can't find an event number of ~S ~
517 (as suggested by the sys tables relevant to the ~
518 current image) among ~{~S~#^, ~} ~
519 (as derived from the names of the GPS event files). ~
520 Consider using --aggregate-events if you can't ~
522 image-event-number
(mapcar #'car gps-start-pointers
))
524 for gps-pointer from gps-start-pointer
525 for gps-point across
(subseq (cdr (assoc image-event-number
529 when
(almost= (gps-time gps-point
) image-time epsilon
)
530 do
(setf (cdr (assoc image-event-number
531 gps-start-pointers
:test
#'equal
))
532 gps-pointer
) ;remember index of last matching point
533 and return gps-point
)))
535 do
(let ((point-id ; TODO: consider using transaction
536 (or (point-id matching-point
) ; We've hit a point twice.
537 (sequence-next (point-id-sequence-name matching-point
))))
538 (measurement-id (get-measurement-id common-table-name
541 (setf (point-id i
) point-id
542 (point-id matching-point
) point-id
543 (measurement-id matching-point
) measurement-id
544 (measurement-id i
) measurement-id
545 (trigger-time matching-point
) image-time
)
546 (save-dao matching-point
)
547 (execute (:update
(dao-table-name (class-of matching-point
))
550 (format nil
"SRID=4326; POINT(~S ~S ~S)"
551 (longitude matching-point
)
552 (latitude matching-point
)
553 (ellipsoid-height matching-point
)))
554 :where
(:= 'point-id
(point-id matching-point
))))
557 (decf mapped-image-counter
)
560 "Couldn't map to any point: ~A~A, byte ~S. ~
561 ~:[~; It didn't have a decent trigger time anyway.~]"
562 dir-path
(filename i
) (image-byte-position i
)
563 (fake-trigger-time-p i
)))
566 "Tried to map ~D images to GPS points. ~
567 The attempt has been successful in ~:[~D~;all~] cases.~
568 ~1@*~:[ See file ~3@*~A for details on the failures.~;~]"
570 (= (length images
) mapped-image-counter
)
573 (cl-log:text-file-messenger-file
(cl-log:find-messenger
:orphan
))))))
575 (defun assert-user-points-version (user-points-version)
576 "Check if user-points-version is compatible with the current
577 user-point table definition."
578 (multiple-value-bind (major minor revision
)
579 (version-number-parts user-points-version
)
580 (declare (ignore minor revision
))
581 (cond ;insert more interesting clauses when necessary
582 ((null user-points-version
)
583 (warn "Storing user-points which don't have a version number."))
584 ((> major
(phoros-version :major t
))
585 (warn "User-point file was created by Phoros ~A ~
586 which is newer than the current version ~A."
587 user-points-version
(phoros-version)))
589 (error "User-point file was created by Phoros ~A ~
590 which is incompatible with the current version ~A. ~
591 Please edit the file like so: ~
592 (1) Change any occurence of the name \"attribute\" to \"kind\". ~
593 (2) Change the value of name \"phorosVersion\" ~
594 from ~0@*~S to \"13.0.0\". Then retry."
595 user-points-version
(phoros-version)))
598 (defun* store-user-points
(presentation-project-name &mandatory-key json-file
)
599 "Store in DB user points given in file at json-file, which
600 supposedly was created by Phoros. Return number of points stored,
601 number of points that were already in DB, number of points found in
602 JSON file, and a list containing user-names from the json file that
604 (assert-phoros-db-major-version)
605 (let* ((user-point-table-name
606 (user-point-table-name presentation-project-name
))
607 (raw-input (with-open-file (stream json-file
)
608 (json:decode-json stream
)))
609 (raw-input-version (cdr (assoc :phoros-version raw-input
)))
610 (raw-features (cdr (assoc :features raw-input
))))
611 (assert-user-points-version raw-input-version
)
613 for i in raw-features
614 for coordinates
= (cdr (assoc :coordinates
(cdr (assoc :geometry i
))))
615 for point-form
= (format nil
"SRID=4326; POINT(~{~S ~})" coordinates
)
616 for properties
= (cdr (assoc :properties i
))
617 for user-name
= (cdr (assoc :user-name properties
))
618 for kind
= (cdr (assoc :kind properties
))
619 for description
= (cdr (assoc :description properties
))
620 for numeric-description
= (cdr (assoc :numeric-description properties
))
621 for creation-date
= (cdr (assoc :creation-date properties
))
622 ;; for stdx-global = (cdr (assoc :stdx-global properties))
623 ;; for stdy-global = (cdr (assoc :stdy-global properties))
624 ;; for stdz-global = (cdr (assoc :stdz-global properties))
625 for input-size
= (cdr (assoc :input-size properties
))
626 for aux-numeric
= (cdr (assoc :aux-numeric properties
))
627 for aux-text
= (cdr (assoc :aux-text properties
))
628 for aux-numeric-comparison
=
630 (format nil
"(~A = (CAST (ARRAY[~{~S~#^,~}] AS NUMERIC[])))"
631 (s-sql:to-sql-name
'aux-numeric
) aux-numeric
)
632 (sql (:is-null
'aux-numeric
)))
633 for aux-text-comparison
=
635 (sql (:= 'aux-text
(vector-null aux-text
)))
636 (sql (:is-null
'aux-text
)))
637 with points-stored
= 0
638 with points-already-in-db
= 0
639 with unknown-users
= nil
640 sum
1 into points-tried
646 :from user-point-table-name
647 :where
(:and
(:st_equals
'coordinates
648 (:st_geomfromewkt point-form
))
650 (:= 'description description
)
651 (:= 'numeric-description numeric-description
)
652 (:= (:to-char
'creation-date
653 *user-point-creation-date-format
*)
655 ;; (:= 'stdx-global stdx-global)
656 ;; (:= 'stdy-global stdy-global)
657 ;; (:= 'stdz-global stdz-global)
658 (:= 'input-size input-size
)
659 (:raw aux-numeric-comparison
)
660 (:raw aux-text-comparison
))))
661 (incf points-already-in-db
)
663 (unless (and user-name
667 :where
(:= 'user-name user-name
))))
668 (pushnew user-name unknown-users
:test
#'equal
))
674 ,user-point-table-name
:set
675 'coordinates
(:st_geomfromewkt
,point-form
)
676 'user-id
,(if user-name
679 :where
(:= 'user-name
683 'description
,description
684 'numeric-description
,numeric-description
685 'creation-date
,creation-date
686 ;; 'stdx-global ,stdx-global
687 ;; 'stdy-global ,stdy-global
688 ;; 'stdz-global ,stdz-global
689 'input-size
,input-size
690 'aux-numeric
,(if aux-numeric
691 (vector-null aux-numeric
)
693 'aux-text
,(if aux-text
694 (vector-null aux-text
)
696 () "Point not stored. This should not happen.")
697 (incf points-stored
)))
698 finally
(return (values points-stored
703 (defun vector-null (elements)
704 "Return a vector made from list elements, but with any occurrences
705 of NIL replaced by NULL."
706 (substitute-if :null
#'null
(apply #'vector elements
)))
708 (defun update-footprint (common-table-name
709 measurement-id filename byte-position
)
710 "Update footprint of an image."
711 (let* ((aggregate-view-name
712 (aggregate-view-name common-table-name
))
716 ;; KLUDGE: translate keys, e.g. a1 -> a_1
717 (json:decode-json-from-string
718 (json:encode-json-to-string
720 :from aggregate-view-name
721 :where
(:and
(:= 'measurement-id measurement-id
)
722 (:= 'filename filename
)
723 (:= 'byte-position byte-position
)))
726 (format nil
"SRID=4326; POLYGON((~{~{~A~#^ ~}~#^, ~}))"
727 (cdr (assoc :footprint raw-footprint
)))))
729 (:update aggregate-view-name
:set
730 'footprint
(:st_geomfromewkt ewkt-footprint
)
731 :where
(:and
(:= 'measurement-id measurement-id
)
732 (:= 'filename filename
)
733 (:= 'byte-position byte-position
))))))
736 (defun insert-footprints (common-table-name)
737 "Give images of acquisition project common-table-name that don't
738 have up-to-date footprints fresh footprints."
739 (let* ((log-frequency 200)
741 (aggregate-view-name common-table-name
))
742 (number-of-image-records
743 (query (:select
(:count
'*)
744 :from aggregate-view-name
747 (:is-null
'footprint
)
748 (:!= 'footprint-device-stage-of-life-id
749 'device-stage-of-life-id
))
756 (:select
'measurement-id
'filename
'byte-position
757 :from aggregate-view-name
760 (:is-null
'footprint
)
761 (:!= 'footprint-device-stage-of-life-id
762 'device-stage-of-life-id
))
764 'measurement-id
'filename
'byte-position
)
768 for
(measurement-id filename byte-position
) in image-records
769 sum
(update-footprint
770 common-table-name measurement-id filename byte-position
))
771 into number-of-updated-footprints
772 do
(cl-log:log-message
774 "Updating image footprints of acquisition project ~A: ~
777 number-of-updated-footprints number-of-image-records
)
778 finally
(return number-of-updated-footprints
))))
780 (defun insert-all-footprints (postgresql-credentials)
781 "Asynchronously update image footprints of all acquisition projects
783 (let ((common-table-names
784 (with-connection postgresql-credentials
785 (query (:select
'common-table-name
786 :from
'sys-acquisition-project
)
788 (setf bt
:*default-special-bindings
*
789 (acons '*insert-footprints-postgresql-credentials
*
790 `(list ,@postgresql-credentials
)
792 (dolist (common-table-name common-table-names
)
795 (declare (special *insert-footprints-postgresql-credentials
*))
796 (with-connection *insert-footprints-postgresql-credentials
*
797 (insert-footprints common-table-name
)))
798 :name
"insert-all-footprints"))))
800 (defun delete-imageless-points (common-table-name)
801 "Delete from acquisition project common-table-name points that have
803 (let* ((point-data-table-name (point-data-table-name common-table-name
))
804 (image-data-table-name (image-data-table-name common-table-name
)))
806 (:delete-from point-data-table-name
809 (:select
(:dot image-data-table-name
'point-id
)
810 :from image-data-table-name
811 :where
(:= (:dot image-data-table-name
813 (:dot point-data-table-name
816 (defun delete-all-imageless-points (postgresql-credentials)
817 "Asynchronously delete imageless footprints of all acquisition
819 (let ((common-table-names
820 (with-connection postgresql-credentials
821 (query (:select
'common-table-name
822 :from
'sys-acquisition-project
)
824 (setf bt
:*default-special-bindings
*
825 (acons '*delete-imageless-points-postgresql-credentials
*
826 `(list ,@postgresql-credentials
)
828 (dolist (common-table-name common-table-names
)
831 (declare (special *delete-imageless-points-postgresql-credentials
*))
832 (with-connection *delete-imageless-points-postgresql-credentials
*
833 (delete-imageless-points common-table-name
)))
834 :name
"delete-all-imageless-points"))))
836 (defun* store-camera-hardware
(&key
848 "Store a new record in table sys-camera-hardware, or try updating an
849 existing one. Return camera-hardware-id of the altered record."
850 (assert-phoros-db-major-version)
852 (or (when try-overwrite
853 (car (select-dao 'sys-camera-hardware
854 (:and
(:= 'sensor-width-pix sensor-width-pix
)
855 (:= 'sensor-height-pix sensor-height-pix
)
856 (:= 'pix-size pix-size
)
857 (:= 'channels channels
)
858 (:= 'serial-number serial-number
)
859 (:= 'pix-depth pix-depth
)))))
860 (make-instance 'sys-camera-hardware
:fetch-defaults t
))))
861 (with-slots ((sensor-width-pix-slot sensor-width-pix
)
862 (sensor-height-pix-slot sensor-height-pix
)
863 (pix-size-slot pix-size
)
864 (channels-slot channels
)
865 (pix-depth-slot pix-depth
)
866 (color-raiser-slot color-raiser
)
867 (bayer-pattern-slot bayer-pattern
)
868 (serial-number-slot serial-number
)
869 (description-slot description
))
871 (setf sensor-width-pix-slot sensor-width-pix
872 sensor-height-pix-slot sensor-height-pix
873 pix-size-slot pix-size
874 channels-slot channels
875 pix-depth-slot pix-depth
876 color-raiser-slot color-raiser
877 bayer-pattern-slot bayer-pattern
878 serial-number-slot serial-number
879 description-slot description
))
880 (let ((new-row-p (save-dao record
)))
883 "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
884 new-row-p
(camera-hardware-id record
)))
885 (camera-hardware-id record
)))
887 (defun* store-lens
(&key
(try-overwrite t
)
892 "Store a new record in table sys-lens, or try updating an existing
893 one. Return lens-id of the altered record."
894 (assert-phoros-db-major-version)
896 (or (when try-overwrite
897 (car (select-dao 'sys-lens
899 (:= 'serial-number serial-number
)))))
900 (make-instance 'sys-lens
:fetch-defaults t
))))
901 (with-slots ((c-slot c
)
902 (serial-number-slot serial-number
)
903 (description-slot description
))
906 serial-number-slot serial-number
907 description-slot description
))
908 (let ((new-row-p (save-dao record
)))
910 :db-sys
"sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
911 new-row-p
(lens-id record
)))
914 (defun store-generic-device
915 (&key
(camera-hardware-id :null
) (lens-id :null
) (scanner-id :null
))
916 "Store a new record in table sys-generic-device. Return
917 generic-device-id of the new record."
918 (assert-phoros-db-major-version)
920 #'(lambda (x) (eq :null x
))
921 (list camera-hardware-id lens-id scanner-id
))
922 () "Generic device: not enough components.")
923 (let ((record (make-instance 'sys-generic-device
924 :camera-hardware-id camera-hardware-id
926 :scanner-id scanner-id
928 (let ((new-row-p (save-dao record
)))
931 "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
932 new-row-p
(generic-device-id record
)))
933 (generic-device-id record
)))
935 (defun* store-device-stage-of-life
(&key
(unmounting-date :null
)
944 computer-interface-name
946 "Store a new record in table sys-device-stage-of-life, or try
947 updating an existing one. Return device-stage-of-life-id of the
949 (assert-phoros-db-major-version)
951 (or (when try-overwrite
953 'sys-device-stage-of-life
954 (:and
(:= 'recorded-device-id recorded-device-id
)
955 (:= 'event-number event-number
)
956 (:= 'generic-device-id generic-device-id
)
957 (:= 'vehicle-name vehicle-name
)
958 (:= 'mounting-date mounting-date
)))))
959 (make-instance 'sys-device-stage-of-life
:fetch-defaults t
))))
960 (with-slots ((recorded-device-id-slot recorded-device-id
)
961 (event-number-slot event-number
)
962 (generic-device-id-slot generic-device-id
)
963 (vehicle-name-slot vehicle-name
)
964 (casing-name-slot casing-name
)
965 (computer-name-slot computer-name
)
966 (computer-interface-name-slot computer-interface-name
)
967 (mounting-date-slot mounting-date
)
968 (unmounting-date-slot unmounting-date
))
970 (setf recorded-device-id-slot recorded-device-id
971 event-number-slot event-number
972 generic-device-id-slot generic-device-id
973 vehicle-name-slot vehicle-name
974 casing-name-slot casing-name
975 computer-name-slot computer-name
976 computer-interface-name-slot computer-interface-name
977 mounting-date-slot mounting-date
978 unmounting-date-slot unmounting-date
))
979 (let ((new-row-p (save-dao record
)))
982 "sys-device-stage-of-life: ~:[Updated~;Stored new~] ~
983 device-stage-of-life-id ~A"
984 new-row-p
(device-stage-of-life-id record
)))
985 (device-stage-of-life-id record
)))
987 (defun* store-device-stage-of-life-end
(&mandatory-key device-stage-of-life-id
989 "Update record in table sys-device-stage-of-life with an unmounting
990 date. Return device-stage-of-life-id of the altered record."
991 (assert-phoros-db-major-version)
993 (get-dao 'sys-device-stage-of-life device-stage-of-life-id
)))
994 (with-slots ((unmounting-date-slot unmounting-date
))
996 (setf unmounting-date-slot unmounting-date
))
998 (device-stage-of-life-id record
)))
1000 (defun* store-camera-calibration
(&key
1003 device-stage-of-life-id
1008 photogrammetry-version
1010 inner-orientation-description
1022 outer-orientation-description
1029 boresight-description
1046 "Store a new record of camera-calibration in table
1047 sys-device-stage-of-life, or update an existing one. Return
1048 device-stage-of-life-id and date of the altered record."
1049 (assert-phoros-db-major-version)
1051 (or (car (select-dao
1052 'sys-camera-calibration
1053 (:and
(:= 'device-stage-of-life-id device-stage-of-life-id
)
1055 (make-instance 'sys-camera-calibration
:fetch-defaults t
))))
1057 ((device-stage-of-life-id-slot device-stage-of-life-id
)
1059 (person-slot person
)
1060 (main-description-slot main-description
)
1061 (usable-slot usable
)
1063 (photogrammetry-version-slot photogrammetry-version
)
1064 (mounting-angle-slot mounting-angle
)
1065 (inner-orientation-description-slot inner-orientation-description
)
1077 (outer-orientation-description-slot outer-orientation-description
)
1084 (boresight-description-slot boresight-description
)
1091 (b-rotx-slot b-rotx
)
1092 (b-roty-slot b-roty
)
1093 (b-rotz-slot b-rotz
)
1094 (b-drotx-slot b-drotx
)
1095 (b-droty-slot b-droty
)
1096 (b-drotz-slot b-drotz
)
1102 (setf device-stage-of-life-id-slot device-stage-of-life-id
1105 main-description-slot main-description
1108 photogrammetry-version-slot photogrammetry-version
1109 mounting-angle-slot mounting-angle
1110 inner-orientation-description-slot inner-orientation-description
1122 outer-orientation-description-slot outer-orientation-description
1129 boresight-description-slot boresight-description
1139 b-drotx-slot b-drotx
1140 b-droty-slot b-droty
1141 b-drotz-slot b-drotz
1146 (let ((new-row-p (save-dao record
)))
1149 "sys-camera-calibration: ~:[Updated~;Stored new~] record ~
1150 for ~A, device-stage-of-life-id ~A"
1151 new-row-p
(date record
) (device-stage-of-life-id record
)))
1152 (values (device-stage-of-life-id record
)