stuff-db.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2012 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
  19 (in-package :phoros)
  20
  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
  25          (ignore-errors
  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)
  36           (loop
  37              with pictures-data = (make-array '(600) :fill-pointer 0)
  38              for picture-start =
  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
  47                                  (or
  48                                   (img:find-keyword-value
  49                                    path "timeTrigger=" picture-start
  50                                    estimated-header-length)
  51                                   -1))
  52              and timestamp = (img:find-keyword-value
  53                               path "cameraTimestamp=" picture-start
  54                               estimated-header-length)
  55              and recorded-device-id = (format
  56                                        nil "~S"
  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)
  65              while picture-start
  66              do (vector-push-extend
  67                  (make-instance
  68                   'image-data
  69                   :trigger-time time-trigger
  70                   :camera-timestamp timestamp
  71                   :recorded-device-id recorded-device-id
  72                   :filename (file-namestring path)
  73                   :footprint :null
  74                   :footprint-device-stage-of-life-id :null
  75                   :gain gain
  76                   :shutter shutter
  77                   :byte-position picture-start)
  78                  pictures-data)
  79              finally
  80              (repair-missing-trigger-times pictures-data)
  81              (return  pictures-data)))
  82         (cl-log:log-message
  83          :db-dat "Skipping ~A because it looks disgusting." path))))
  84
  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
  89                                                  (- good-index 2))))
  90                    (trigger-time (aref images (+ offending-index
  91                                                  (+ good-index 2)))))
  92                 (- (camera-timestamp (aref images (+ offending-index
  93                                                      (- good-index 2))))
  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
  99                                                            good-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)))
 104                   t-0))))
 105     (dolist (offending-index
 106               (loop
 107                  with previous-trigger-time = 0
 108                  for h across images
 109                  for i from 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)
 113                  else collect i))
 114       (ignore-errors
 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))
 119                   (restart-case
 120                       (fake-trigger-time offending-index good-index-offset)
 121                     (next-try ()
 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)))))))
 125
 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)
 132                                         '(:wild-inferiors))
 133                      :name :wild :type "pictures"))))
 134     (assert pictures-files ()
 135             "Sorry, but I couldn't find a single .pictures file below ~A."
 136             dir-path)
 137     (reduce #'(lambda (x1 x2) (merge 'vector x1 x2 #'< :key #'trigger-time))
 138             (mapcar #'collect-pictures-file-data
 139                     pictures-files))))
 140
 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
 144 number."
 145   (let* ((event-dir
 146           (make-pathname
 147            :directory (append (pathname-directory dir-path)
 148                               '(:wild-inferiors) '("applanix" "points"))
 149            :name :wild
 150            :type :wild))
 151          (gps-files (directory event-dir))
 152          (gps-event-files
 153           (loop
 154              for gps-file in gps-files
 155              for gps-basename = (pathname-name gps-file)
 156              for event-number = (ignore-errors
 157                                   (subseq gps-basename
 158                                           (mismatch
 159                                            gps-basename "event"
 160                                            :start1
 161                                            (search "event" gps-basename
 162                                                    :from-end t))))
 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))
 167     (cl-log:log-message
 168      :db-dat "Digesting GPS data from ~{~A~#^, ~}."
 169      (mapcar #'cadr gps-event-files))
 170     (loop
 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)
 174        collect
 175        (cons
 176         gps-event-number
 177         (with-open-file (stream gps-event-file)
 178           (loop
 179              for line = (read-line stream)
 180              for i from 0 to 35
 181              until (string-equal
 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)")
 184              finally
 185                (read-line stream)
 186              (assert (< i 35) ()
 187                      "Unfamiliar header.  Check Applanix file format." nil))
 188           (loop
 189              with gps-points = (make-array '(1000) :fill-pointer 0)
 190              for line = (read-line stream nil)
 191              while line
 192              do (vector-push-extend
 193                  (let ((point (make-instance 'point-data)))
 194                    (with-slots
 195                          (gps-time
 196                           event-number
 197                           longitude latitude ellipsoid-height
 198                           roll pitch heading
 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)
 203                        point
 204                      (with-input-from-string (line-content line)
 205                        (setf event-number gps-event-number
 206                              gps-time
 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))))
 228                    point)
 229                  gps-points)
 230              finally (return gps-points)))))))
 231
 232 (defun aggregate-gps-events (gps-points)
 233   "Turn an alist of ((event1 . points1) (event2 . points2)...) into
 234 ((t . all-points))."
 235   (cl-log:log-message
 236  :db-sys
 237  "I was asked to aggregate-events so I won't distinguish any event numbers.")
 238   (list
 239    (cons t (reduce #'(lambda (x y) (merge 'vector x y #'< :key #'gps-time))
 240                    (mapcar #'cdr gps-points)))))
 241
 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.")
 245
 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:
 249  1980  Jan.   1              - 1s
 250  1981  Jul.   1              - 1s
 251  ...")
 252
 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.")
 256
 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 ()
 264     (handler-case
 265         (multiple-value-bind
 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*
 271                                   :direction :output
 272                                   :if-exists :supersede
 273                                   :if-does-not-exist :create)
 274             (write-string body stream)
 275             (cl-log:log-message
 276              :debug "Downloaded leap second information from ~A." uri)))
 277       (error (e)
 278         (cl-log:log-message
 279          :warning
 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
 286              (sort                      ;just in case
 287               (loop
 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
 292                       #\Space
 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)
 299                                            leap-second-months
 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)
 309                                (* sign seconds)))
 310               #'<
 311               :key #'car)))
 312         (setf *leap-seconds*
 313               (loop
 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
 318                  finally
 319                    (return (reverse (pairlis leap-dates leap-sums)))))))))
 320
 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))
 323
 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)
 332           week-length)
 333        *gps-epoch*
 334        leap-seconds)))
 335
 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))
 341
 342 (defun utc-from-unix (unix-time)
 343   "Convert UNIX UTC to Lisp time."
 344   (when unix-time (+ unix-time *unix-epoch*)))
 345
 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
 354           device-event-number
 355           (let* ((date (simple-date:universal-time-to-timestamp (round utc)))
 356                  (device-stage-of-life
 357                   (car
 358                    (select-dao
 359                     'sys-device-stage-of-life
 360                     (:and (:overlaps
 361                            (:set 'mounting-date
 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
 366                     ()
 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))))))
 375
 376 (defun almost= (x y epsilon)
 377   (< (abs (- x y)) epsilon))
 378
 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)))
 386
 387 (defun utm-zone (longitude)
 388   "Return UTM zone number belonging to longitude."
 389   (1+ (floor (+ longitude 180) 6)))
 390
 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))
 396     (unless
 397         (or (every #'(lambda (x y) (almost= x y epsilon))
 398                    (geographic-to-utm (utm-zone (- longitude-median
 399                                                    longitude-leeway))
 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
 404                                                    longitude-leeway))
 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))))
 412
 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
 416 used."
 417   (loop
 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 =
 427        (loop
 428           for point across gps-event-vector
 429           for i from 1
 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)))))
 439
 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))
 448            (measurement
 449             (or (car (select-dao
 450                       'sys-measurement
 451                       (:and (:= 'acquisition-project-id acquisition-project-id)
 452                             (:= 'directory dir-path))))
 453                 (insert-dao
 454                  (make-instance 'sys-measurement
 455                                 :acquisition-project-id acquisition-project-id
 456                                 :directory dir-path
 457                                 :cartesian-system cartesian-system
 458                                 :fetch-defaults t)))))
 459       (measurement-id measurement))))
 460
 461 (defun store-images-and-points (common-table-name dir-path
 462                                 &key (epsilon 1d-3)
 463                                 (root-dir (user-homedir-pathname))
 464                                 aggregate-events)
 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
 470 all pojects."
 471   ;; TODO: epsilon could be a range.  We would do a raw mapping by (a bigger) time epsilon and then take speed into account.
 472   (assert
 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)
 483   (let* ((images
 484           (collect-pictures-directory-data dir-path))
 485          (estimated-time
 486           (loop
 487              for i across images
 488              unless (or (fake-trigger-time-p i)
 489                         (< (trigger-time i) *gps-epoch*))
 490              do (return (trigger-time i))))
 491          (gps-points
 492           (if aggregate-events
 493               (aggregate-gps-events (collect-gps-data dir-path estimated-time))
 494               (collect-gps-data dir-path estimated-time)))
 495          (gps-start-pointers (loop
 496                                 for i in gps-points
 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)))
 501     (cl-log:log-message
 502      :db-dat "I assume this measure was taken approximately ~A."
 503      (timestring (round estimated-time)))
 504     (loop
 505        for i across images
 506        for image-event-number = (or aggregate-events
 507                                     (device-event-number (recorded-device-id i)
 508                                                          estimated-time))
 509        for image-time = (trigger-time i)
 510        for matching-point =
 511          (when image-time               ;otherwise this image is junk
 512            (let ((gps-start-pointer
 513                   (cdr (assoc image-event-number gps-start-pointers
 514                               :test #'equal))))
 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 ~
 521                       recitfy your data."
 522                      image-event-number (mapcar #'car gps-start-pointers))
 523              (loop
 524                 for gps-pointer from gps-start-pointer
 525                 for gps-point across (subseq (cdr (assoc image-event-number
 526                                                          gps-points
 527                                                          :test #'equal))
 528                                              gps-start-pointer)
 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)))
 534        if matching-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
 539                                                     dir-below-root-dir
 540                                                     cartesian-system)))
 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))
 548                               :set 'coordinates
 549                               (:st_geomfromewkt
 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))))
 555             (save-dao i))
 556        else do
 557          (decf mapped-image-counter)
 558          (cl-log:log-message
 559           :orphan
 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)))
 564     (cl-log:log-message
 565      :db-dat
 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.~;~]"
 569      (length images)
 570      (= (length images) mapped-image-counter)
 571      mapped-image-counter
 572      (truename
 573       (cl-log:text-file-messenger-file (cl-log:find-messenger :orphan))))))
 574
 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)))
 588       ((< major 13)
 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)))
 596        (t))))
 597
 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
 603 don't exist in DB."
 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)
 612     (loop
 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 =
 629          (if aux-numeric
 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 =
 634          (if aux-text
 635              (sql (:= 'aux-text (apply #'vector 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
 641        do
 642          (if
 643           (query
 644            (:select
 645             t
 646             :from user-point-table-name
 647             :where (:and (:st_equals 'coordinates
 648                                      (:st_geomfromewkt point-form))
 649                          (:= 'kind kind)
 650                          (:= 'description description)
 651                          (:= 'numeric-description numeric-description)
 652                          (:= (:to-char 'creation-date
 653                                        *user-point-creation-date-format*)
 654                              creation-date)
 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)
 662           (progn
 663             (unless (and user-name
 664                          (query
 665                           (:select t
 666                                    :from 'sys-user
 667                                    :where (:= 'user-name user-name))))
 668               (pushnew user-name unknown-users :test #'equal))
 669             (assert
 670              (= 1
 671                 (execute
 672                  (sql-compile
 673                   `(:insert-into
 674                     ,user-point-table-name :set
 675                     'coordinates (:st_geomfromewkt ,point-form)
 676                     'user-id ,(if user-name
 677                                   `(:select 'user-id
 678                                             :from 'sys-user
 679                                             :where (:= 'user-name
 680                                                        ,user-name))
 681                                   :null)
 682                     'kind ,kind
 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                                       (apply #'vector aux-numeric)
 692                                       :null)
 693                     'aux-text ,(if aux-text
 694                                    (apply #'vector aux-text)
 695                                    :null)))))
 696              () "Point not stored.  This should not happen.")
 697             (incf points-stored)))
 698        finally (return (values points-stored
 699                                points-already-in-db
 700                                points-tried
 701                                unknown-users)))))
 702
 703 (defun update-footprint (common-table-name
 704                          measurement-id filename byte-position)
 705   "Update footprint of an image."
 706   (let* ((aggregate-view-name
 707           (aggregate-view-name common-table-name))
 708          (raw-footprint
 709           (photogrammetry
 710            :footprint
 711            ;; KLUDGE: translate keys, e.g. a1 -> a_1
 712            (json:decode-json-from-string
 713             (json:encode-json-to-string
 714              (query (:select '*
 715                              :from aggregate-view-name
 716                              :where (:and (:= 'measurement-id measurement-id)
 717                                           (:= 'filename filename)
 718                                           (:= 'byte-position byte-position)))
 719                     :alist)))))
 720          (ewkt-footprint
 721           (format nil "SRID=4326; POLYGON((~{~{~A~#^ ~}~#^, ~}))"
 722                   (cdr (assoc :footprint raw-footprint)))))
 723     (execute
 724      (:update aggregate-view-name :set
 725               'footprint (:st_geomfromewkt ewkt-footprint)
 726               :where (:and (:= 'measurement-id measurement-id)
 727                            (:= 'filename filename)
 728                            (:= 'byte-position byte-position))))))
 729
 730
 731 (defun insert-footprints (common-table-name)
 732   "Give images of acquisition project common-table-name that don't
 733 have up-to-date footprints fresh footprints."
 734   (let* ((log-frequency 200)
 735          (aggregate-view-name
 736           (aggregate-view-name common-table-name))
 737          (number-of-image-records
 738           (query (:select (:count '*)
 739                           :from aggregate-view-name
 740                           :where (:and
 741                                   (:or
 742                                    (:is-null 'footprint)
 743                                    (:!= 'footprint-device-stage-of-life-id
 744                                         'device-stage-of-life-id))
 745                                   'usable))
 746                  :single!)))
 747     (loop
 748        for image-records
 749        = (query (:limit
 750                  (:order-by
 751                   (:select 'measurement-id 'filename 'byte-position
 752                            :from aggregate-view-name
 753                            :where (:and
 754                                    (:or
 755                                     (:is-null 'footprint)
 756                                     (:!= 'footprint-device-stage-of-life-id
 757                                          'device-stage-of-life-id))
 758                                    'usable))
 759                   'measurement-id 'filename 'byte-position)
 760                  log-frequency))
 761        while image-records
 762        sum (loop
 763               for (measurement-id filename byte-position) in image-records
 764               sum (update-footprint
 765                    common-table-name measurement-id filename byte-position))
 766        into number-of-updated-footprints
 767        do (cl-log:log-message
 768            :db-dat
 769            "Updating image footprints of acquisition project ~A: ~
 770            ~D out of ~D done."
 771            common-table-name
 772            number-of-updated-footprints number-of-image-records)
 773        finally (return number-of-updated-footprints))))
 774
 775 (defun insert-all-footprints (postgresql-credentials)
 776   "Asynchronously update image footprints of all acquisition projects
 777 where necessarcy."
 778   (let ((common-table-names
 779          (with-connection postgresql-credentials
 780            (query (:select 'common-table-name
 781                            :from 'sys-acquisition-project)
 782                   :list))))
 783     (setf bt:*default-special-bindings*
 784           (acons '*insert-footprints-postgresql-credentials*
 785                  `(list ,@postgresql-credentials)
 786                  nil))
 787     (dolist (common-table-name common-table-names)
 788       (bt:make-thread
 789        #'(lambda ()
 790            (declare (special *insert-footprints-postgresql-credentials*))
 791            (with-connection *insert-footprints-postgresql-credentials*
 792              (insert-footprints common-table-name)))
 793        :name "insert-all-footprints"))))
 794
 795 (defun delete-imageless-points (common-table-name)
 796   "Delete from acquisition project common-table-name points that have
 797 no images."
 798   (let* ((point-data-table-name (point-data-table-name common-table-name))
 799          (image-data-table-name (image-data-table-name common-table-name)))
 800     (execute
 801      (:delete-from point-data-table-name
 802                    :where (:not
 803                            (:exists
 804                             (:select (:dot image-data-table-name 'point-id)
 805                                      :from image-data-table-name
 806                                      :where (:= (:dot image-data-table-name
 807                                                       'point-id)
 808                                                 (:dot point-data-table-name
 809                                                       'point-id)))))))))
 810
 811 (defun delete-all-imageless-points (postgresql-credentials)
 812   "Asynchronously delete imageless footprints of all acquisition
 813 projects."
 814   (let ((common-table-names
 815          (with-connection postgresql-credentials
 816            (query (:select 'common-table-name
 817                            :from 'sys-acquisition-project)
 818                   :list))))
 819     (setf bt:*default-special-bindings*
 820           (acons '*delete-imageless-points-postgresql-credentials*
 821                  `(list ,@postgresql-credentials)
 822                  nil))
 823     (dolist (common-table-name common-table-names)
 824       (bt:make-thread
 825        #'(lambda ()
 826            (declare (special *delete-imageless-points-postgresql-credentials*))
 827            (with-connection *delete-imageless-points-postgresql-credentials*
 828              (delete-imageless-points common-table-name)))
 829        :name "delete-all-imageless-points"))))
 830
 831 (defun* store-camera-hardware (&key
 832                                (try-overwrite t)
 833                                &mandatory-key
 834                                sensor-width-pix
 835                                sensor-height-pix
 836                                pix-size
 837                                channels
 838                                pix-depth
 839                                color-raiser
 840                                bayer-pattern
 841                                serial-number
 842                                description)
 843   "Store a new record in table sys-camera-hardware, or try updating an
 844 existing one.  Return camera-hardware-id of the altered record."
 845   (assert-phoros-db-major-version)
 846   (let ((record
 847          (or (when try-overwrite
 848                (car (select-dao 'sys-camera-hardware
 849                                 (:and (:= 'sensor-width-pix sensor-width-pix)
 850                                       (:= 'sensor-height-pix sensor-height-pix)
 851                                       (:= 'pix-size pix-size)
 852                                       (:= 'channels channels)
 853                                       (:= 'serial-number serial-number)
 854                                       (:= 'pix-depth pix-depth)))))
 855              (make-instance 'sys-camera-hardware :fetch-defaults t))))
 856     (with-slots ((sensor-width-pix-slot sensor-width-pix)
 857                  (sensor-height-pix-slot sensor-height-pix)
 858                  (pix-size-slot pix-size)
 859                  (channels-slot channels)
 860                  (pix-depth-slot pix-depth)
 861                  (color-raiser-slot color-raiser)
 862                  (bayer-pattern-slot bayer-pattern)
 863                  (serial-number-slot serial-number)
 864                  (description-slot description))
 865         record
 866       (setf sensor-width-pix-slot sensor-width-pix
 867             sensor-height-pix-slot sensor-height-pix
 868             pix-size-slot pix-size
 869             channels-slot channels
 870             pix-depth-slot pix-depth
 871             color-raiser-slot color-raiser
 872             bayer-pattern-slot bayer-pattern
 873             serial-number-slot serial-number
 874             description-slot description))
 875     (let ((new-row-p (save-dao record)))
 876       (cl-log:log-message
 877        :db-sys
 878        "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
 879        new-row-p (camera-hardware-id record)))
 880     (camera-hardware-id record)))
 881
 882 (defun* store-lens (&key (try-overwrite t)
 883                          &mandatory-key
 884                          c
 885                          serial-number
 886                          description)
 887   "Store a new record in table sys-lens, or try updating an existing
 888 one.  Return lens-id of the altered record."
 889   (assert-phoros-db-major-version)
 890   (let ((record
 891          (or (when try-overwrite
 892                (car (select-dao 'sys-lens
 893                                 (:and (:= 'c c)
 894                                       (:= 'serial-number serial-number)))))
 895              (make-instance 'sys-lens :fetch-defaults t))))
 896     (with-slots ((c-slot c)
 897                  (serial-number-slot serial-number)
 898                  (description-slot description))
 899         record
 900       (setf c-slot c
 901             serial-number-slot serial-number
 902             description-slot description))
 903     (let ((new-row-p (save-dao record)))
 904       (cl-log:log-message
 905        :db-sys "sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
 906        new-row-p (lens-id record)))
 907     (lens-id record)))
 908
 909 (defun store-generic-device
 910     (&key (camera-hardware-id :null) (lens-id :null) (scanner-id :null))
 911   "Store a new record in table sys-generic-device.  Return
 912 generic-device-id of the new record."
 913   (assert-phoros-db-major-version)
 914   (assert (notevery
 915            #'(lambda (x) (eq :null x))
 916            (list camera-hardware-id lens-id scanner-id))
 917           () "Generic device: not enough components.")
 918   (let ((record (make-instance 'sys-generic-device
 919                                :camera-hardware-id camera-hardware-id
 920                                :lens-id lens-id
 921                                :scanner-id scanner-id
 922                                :fetch-defaults t)))
 923     (let ((new-row-p (save-dao record)))
 924       (cl-log:log-message
 925        :db-sys
 926        "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
 927        new-row-p (generic-device-id record)))
 928     (generic-device-id record)))
 929
 930 (defun* store-device-stage-of-life (&key (unmounting-date :null)
 931                                    (try-overwrite t)
 932                                    &mandatory-key
 933                                    recorded-device-id
 934                                    event-number
 935                                    generic-device-id
 936                                    vehicle-name
 937                                    casing-name
 938                                    computer-name
 939                                    computer-interface-name
 940                                    mounting-date)
 941   "Store a new record in table sys-device-stage-of-life, or try
 942 updating an existing one.  Return device-stage-of-life-id of the
 943 altered record."
 944   (assert-phoros-db-major-version)
 945   (let ((record
 946          (or (when try-overwrite
 947                (car (select-dao
 948                      'sys-device-stage-of-life
 949                      (:and (:= 'recorded-device-id recorded-device-id)
 950                            (:= 'event-number event-number)
 951                            (:= 'generic-device-id generic-device-id)
 952                            (:= 'vehicle-name vehicle-name)
 953                            (:= 'mounting-date mounting-date)))))
 954              (make-instance 'sys-device-stage-of-life :fetch-defaults t))))
 955     (with-slots ((recorded-device-id-slot recorded-device-id)
 956                  (event-number-slot event-number)
 957                  (generic-device-id-slot generic-device-id)
 958                  (vehicle-name-slot vehicle-name)
 959                  (casing-name-slot casing-name)
 960                  (computer-name-slot computer-name)
 961                  (computer-interface-name-slot computer-interface-name)
 962                  (mounting-date-slot mounting-date)
 963                  (unmounting-date-slot unmounting-date))
 964         record
 965       (setf recorded-device-id-slot recorded-device-id
 966             event-number-slot event-number
 967             generic-device-id-slot generic-device-id
 968             vehicle-name-slot vehicle-name
 969             casing-name-slot casing-name
 970             computer-name-slot computer-name
 971             computer-interface-name-slot computer-interface-name
 972             mounting-date-slot mounting-date
 973             unmounting-date-slot unmounting-date))
 974     (let ((new-row-p (save-dao record)))
 975       (cl-log:log-message
 976        :db-sys
 977        "sys-device-stage-of-life: ~:[Updated~;Stored new~] ~
 978        device-stage-of-life-id ~A"
 979        new-row-p (device-stage-of-life-id record)))
 980     (device-stage-of-life-id record)))
 981
 982 (defun* store-device-stage-of-life-end (&mandatory-key device-stage-of-life-id
 983                                                        unmounting-date)
 984   "Update record in table sys-device-stage-of-life with an unmounting
 985 date.  Return device-stage-of-life-id of the altered record."
 986   (assert-phoros-db-major-version)
 987   (let ((record
 988          (get-dao 'sys-device-stage-of-life device-stage-of-life-id)))
 989     (with-slots ((unmounting-date-slot unmounting-date))
 990         record
 991       (setf unmounting-date-slot unmounting-date))
 992     (update-dao record)
 993     (device-stage-of-life-id record)))
 994
 995 (defun* store-camera-calibration (&key
 996                                   (usable t)
 997                                   &mandatory-key
 998                                   device-stage-of-life-id
 999                                   date
1000                                   person
1001                                   main-description
1002                                   debug
1003                                   photogrammetry-version
1004                                   mounting-angle
1005                                   inner-orientation-description
1006                                   c
1007                                   xh
1008                                   yh
1009                                   a1
1010                                   a2
1011                                   a3
1012                                   b1
1013                                   b2
1014                                   c1
1015                                   c2
1016                                   r0
1017                                   outer-orientation-description
1018                                   dx
1019                                   dy
1020                                   dz
1021                                   omega
1022                                   phi
1023                                   kappa
1024                                   boresight-description
1025                                   b-dx
1026                                   b-dy
1027                                   b-dz
1028                                   b-ddx
1029                                   b-ddy
1030                                   b-ddz
1031                                   b-rotx
1032                                   b-roty
1033                                   b-rotz
1034                                   b-drotx
1035                                   b-droty
1036                                   b-drotz
1037                                   nx
1038                                   ny
1039                                   nz
1040                                   d)
1041   "Store a new record of camera-calibration in table
1042 sys-device-stage-of-life, or update an existing one.  Return
1043 device-stage-of-life-id and date of the altered record."
1044   (assert-phoros-db-major-version)
1045   (let ((record
1046          (or (car (select-dao
1047                    'sys-camera-calibration
1048                    (:and (:= 'device-stage-of-life-id device-stage-of-life-id)
1049                          (:= 'date date))))
1050              (make-instance 'sys-camera-calibration :fetch-defaults t))))
1051     (with-slots
1052           ((device-stage-of-life-id-slot device-stage-of-life-id)
1053            (date-slot date)
1054            (person-slot person)
1055            (main-description-slot main-description)
1056            (usable-slot usable)
1057            (debug-slot debug)
1058            (photogrammetry-version-slot photogrammetry-version)
1059            (mounting-angle-slot mounting-angle)
1060            (inner-orientation-description-slot inner-orientation-description)
1061            (c-slot c)
1062            (xh-slot xh)
1063            (yh-slot yh)
1064            (a1-slot a1)
1065            (a2-slot a2)
1066            (a3-slot a3)
1067            (b1-slot b1)
1068            (b2-slot b2)
1069            (c1-slot c1)
1070            (c2-slot c2)
1071            (r0-slot r0)
1072            (outer-orientation-description-slot outer-orientation-description)
1073            (dx-slot dx)
1074            (dy-slot dy)
1075            (dz-slot dz)
1076            (omega-slot omega)
1077            (phi-slot phi)
1078            (kappa-slot kappa)
1079            (boresight-description-slot boresight-description)
1080            (b-dx-slot b-dx)
1081            (b-dy-slot b-dy)
1082            (b-dz-slot b-dz)
1083            (b-ddx-slot b-ddx)
1084            (b-ddy-slot b-ddy)
1085            (b-ddz-slot b-ddz)
1086            (b-rotx-slot b-rotx)
1087            (b-roty-slot b-roty)
1088            (b-rotz-slot b-rotz)
1089            (b-drotx-slot b-drotx)
1090            (b-droty-slot b-droty)
1091            (b-drotz-slot b-drotz)
1092            (nx-slot nx)
1093            (ny-slot ny)
1094            (nz-slot nz)
1095            (d-slot d))
1096         record
1097       (setf device-stage-of-life-id-slot device-stage-of-life-id
1098             date-slot date
1099             person-slot person
1100             main-description-slot main-description
1101             usable-slot usable
1102             debug-slot debug
1103             photogrammetry-version-slot photogrammetry-version
1104             mounting-angle-slot mounting-angle
1105             inner-orientation-description-slot inner-orientation-description
1106             c-slot c
1107             xh-slot xh
1108             yh-slot yh
1109             a1-slot a1
1110             a2-slot a2
1111             a3-slot a3
1112             b1-slot b1
1113             b2-slot b2
1114             c1-slot c1
1115             c2-slot c2
1116             r0-slot r0
1117             outer-orientation-description-slot outer-orientation-description
1118             dx-slot dx
1119             dy-slot dy
1120             dz-slot dz
1121             omega-slot omega
1122             phi-slot phi
1123             kappa-slot kappa
1124             boresight-description-slot boresight-description
1125             b-dx-slot b-dx
1126             b-dy-slot b-dy
1127             b-dz-slot b-dz
1128             b-ddx-slot b-ddx
1129             b-ddy-slot b-ddy
1130             b-ddz-slot b-ddz
1131             b-rotx-slot b-rotx
1132             b-roty-slot b-roty
1133             b-rotz-slot b-rotz
1134             b-drotx-slot b-drotx
1135             b-droty-slot b-droty
1136             b-drotz-slot b-drotz
1137             nx-slot nx
1138             ny-slot ny
1139             nz-slot nz
1140             d-slot d))
1141     (let ((new-row-p (save-dao record)))
1142       (cl-log:log-message
1143        :db-sys
1144        "sys-camera-calibration: ~:[Updated~;Stored new~] record ~
1145         for ~A, device-stage-of-life-id ~A"
1146        new-row-p (date record) (device-stage-of-life-id record)))
1147     (values (device-stage-of-life-id record)
1148             (date record))))