stuff-db.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2012, 2017 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           (unless (stringp body)
 270             (setf body (flexi-streams:octets-to-string body)))
 271           (assert (= status-code 200))
 272           (with-open-file (stream *time-steps-history-file*
 273                                   :direction :output
 274                                   :if-exists :supersede
 275                                   :if-does-not-exist :create)
 276             (write-string body stream)
 277             (cl-log:log-message
 278              :debug "Downloaded leap second information from ~A." uri)))
 279       (error (e)
 280         (cl-log:log-message
 281          :warning
 282          "Couldn't get the latest leap seconds information from ~A. (~A)  ~
 283           Falling back to cached data in ~A."
 284          *time-steps-history-url* e *time-steps-history-file*)))
 285     (with-open-file (stream *time-steps-history-file*
 286                             :direction :input :if-does-not-exist :error)
 287       (let ((leap-second-records
 288              (sort                      ;just in case
 289               (loop
 290                  for raw-time-record = (read-line stream nil nil)
 291                  while raw-time-record
 292                  for (raw-year raw-month raw-date raw-sign raw-seconds)
 293                    = (cl-utilities:split-sequence
 294                       #\Space
 295                       (nsubstitute #\Space #\Tab raw-time-record)
 296                       :remove-empty-subseqs t)
 297                  for year = (when raw-year
 298                               (parse-integer raw-year :junk-allowed t))
 299                  for month = (when raw-month
 300                                (cdr (assoc (string-trim "." raw-month)
 301                                            leap-second-months
 302                                            :test #'string-equal)))
 303                  for date = (when raw-date
 304                               (parse-integer raw-date :junk-allowed t))
 305                  for sign = (when raw-sign
 306                               (if (string-equal raw-sign "-") -1 1))
 307                  for seconds = (when raw-seconds
 308                                  (parse-integer raw-seconds :junk-allowed t))
 309                  when (and year (< 1980 year))
 310                  collect (list (encode-universal-time 0 0 0 date month year 0)
 311                                (* sign seconds)))
 312               #'<
 313               :key #'car)))
 314         (setf *leap-seconds*
 315               (loop
 316                  for (leap-date leap) in leap-second-records
 317                  sum leap into leap-sum
 318                  collect leap-date into leap-dates
 319                  collect leap-sum into leap-sums
 320                  finally
 321                    (return (reverse (pairlis leap-dates leap-sums)))))))))
 322
 323 (defparameter *gps-epoch* (encode-universal-time 0 0 0 6 1 1980 0))
 324 (defparameter *unix-epoch* (encode-universal-time 0 0 0 1 1 1970 0))
 325
 326 (defun gps-start-of-week (time)
 327   "Begin of a GPS week (approximately Sunday 00:00)"
 328   (let ((week-length (* 7 24 3600))
 329         (leap-seconds (cdr (find time *leap-seconds*
 330                                  :key #'car :test #'> :from-end t))))
 331     (assert leap-seconds ()
 332             "Couldn't determine leap seconds for ~A" (timestring (round time)))
 333     (+ (* (floor (- time *gps-epoch*) week-length)
 334           week-length)
 335        *gps-epoch*
 336        leap-seconds)))
 337
 338 (defun utc-from-gps (utc-approximately gps-week-time)
 339   "Convert GPS week time into UTC.  gps-week-time may be of type
 340 float; in this case a non-integer is returned which can't be fed into
 341 decode-universal-time."
 342   (+ (gps-start-of-week utc-approximately) gps-week-time))
 343
 344 (defun utc-from-unix (unix-time)
 345   "Convert UNIX UTC to Lisp time."
 346   (when unix-time (+ unix-time *unix-epoch*)))
 347
 348 (let (event-number-storage)
 349   (defun device-event-number (recorded-device-id utc)
 350     "Return the GPS event number (a string) corresponding to
 351 recorded-device-id (a string) of camera (etc.)"
 352     (let ((device-event-number
 353            (cdr (assoc recorded-device-id event-number-storage
 354                        :test #'string-equal))))
 355       (if device-event-number
 356           device-event-number
 357           (let* ((date (simple-date:universal-time-to-timestamp (round utc)))
 358                  (device-stage-of-life
 359                   (car
 360                    (select-dao
 361                     'sys-device-stage-of-life
 362                     (:and (:overlaps
 363                            (:set 'mounting-date
 364                                  (:least :current-date 'unmounting-date))
 365                            (:set (:date date) (:date date)))
 366                           (:= 'recorded-device-id recorded-device-id))))))
 367             (assert device-stage-of-life
 368                     ()
 369                     "Can't figure out what event-number belongs to ~
 370                     recorded-device-id ~S of (approx.) ~A.  ~
 371                     There should be some entry in table ~
 372                     sys-device-stage-of-life to this end."
 373                     recorded-device-id (timestring (round utc)))
 374             (push (cons recorded-device-id (event-number device-stage-of-life))
 375                   event-number-storage)
 376             (event-number device-stage-of-life))))))
 377
 378 (defun almost= (x y epsilon)
 379   (< (abs (- x y)) epsilon))
 380
 381 (defun geographic-to-utm (utm-zone longitude latitude &optional (height 0d0))
 382   "Return UTM utm-zone representation of geographic coordinates."
 383   (let ((utm-coordinate-system
 384          (format nil "+proj=utm +ellps=WGS84 +zone=~D" utm-zone)))
 385     (proj:cs2cs (list (proj:degrees-to-radians longitude)
 386                       (proj:degrees-to-radians latitude) height)
 387                 :destination-cs utm-coordinate-system)))
 388
 389 (defun utm-zone (longitude)
 390   "Return UTM zone number belonging to longitude."
 391   (1+ (floor (+ longitude 180) 6)))
 392
 393 (defun assert-utm-zone (longitude-median longitude-leeway longitude latitude
 394                         geographic-height easting northing cartesian-height)
 395   "Check if, given longitude and latitude, easting and northing are
 396 calculated in the UTM zone belonging to longitude-median."
 397   (let ((epsilon 1d-1))
 398     (unless
 399         (or (every #'(lambda (x y) (almost= x y epsilon))
 400                    (geographic-to-utm (utm-zone (- longitude-median
 401                                                    longitude-leeway))
 402                                       longitude latitude geographic-height)
 403                    (list easting northing cartesian-height))
 404             (every #'(lambda (x y) (almost= x y epsilon))
 405                    (geographic-to-utm (utm-zone (+ longitude-median
 406                                                    longitude-leeway))
 407                                       longitude latitude geographic-height)
 408                    (list easting northing cartesian-height)))
 409       (error "The longitude median ~A should be in or near UTM zone ~D.  ~
 410               This is inconsistent with the easting values I was given.  ~
 411               Offending coordinates: (~A ~A ~A) (~A ~A ~A)."
 412              longitude-median (utm-zone longitude-median) longitude latitude
 413              geographic-height easting northing cartesian-height))))
 414
 415 (defun assert-gps-points-sanity (gps-points)
 416   "Check if gps-points (as returned by collect-gps-data) are ok.
 417 Return the Proj.4 string describing the cartesian coordinate system
 418 used."
 419   (loop
 420      for gps-event in gps-points
 421      for gps-event-vector = (cdr gps-event)
 422      for first-longitude = (longitude (aref gps-event-vector 0))
 423      for first-latitude = (latitude (aref gps-event-vector 0))
 424      for first-geographic-height = (ellipsoid-height (aref gps-event-vector 0))
 425      for first-easting = (easting (aref gps-event-vector 0))
 426      for first-northing = (northing (aref gps-event-vector 0))
 427      for first-cartesian-height = (cartesian-height (aref gps-event-vector 0))
 428      for longitude-median =
 429        (loop
 430           for point across gps-event-vector
 431           for i from 1
 432           sum (longitude point) into longitude-sum
 433           finally (return (/ longitude-sum i)))
 434      do (assert-utm-zone longitude-median 1
 435                          first-longitude first-latitude
 436                          first-geographic-height
 437                          first-easting first-northing
 438                          first-cartesian-height)
 439      finally (return (format nil "+proj=utm +ellps=WGS84 +zone=~D"
 440                              (utm-zone longitude-median)))))
 441
 442 (defun get-measurement-id (common-table-name dir-path cartesian-system)
 443   "Get measurement-id associated with dir-path and
 444 acquisition-project-id.  Create a fresh matching record if necessary."
 445   (let ((acquisition-project
 446          (car (select-dao 'sys-acquisition-project
 447                           (:= 'common-table-name common-table-name)))))
 448     (assert acquisition-project)
 449     (let* ((acquisition-project-id (acquisition-project-id acquisition-project))
 450            (measurement
 451             (or (car (select-dao
 452                       'sys-measurement
 453                       (:and (:= 'acquisition-project-id acquisition-project-id)
 454                             (:= 'directory dir-path))))
 455                 (insert-dao
 456                  (make-instance 'sys-measurement
 457                                 :acquisition-project-id acquisition-project-id
 458                                 :directory dir-path
 459                                 :cartesian-system cartesian-system
 460                                 :fetch-defaults t)))))
 461       (measurement-id measurement))))
 462
 463 (defun store-images-and-points (common-table-name dir-path
 464                                 &key (epsilon 1d-3)
 465                                 (root-dir (user-homedir-pathname))
 466                                 aggregate-events)
 467   "Link images to GPS points; store both into their respective DB
 468 tables.  Images become linked to GPS points when their respective
 469 times differ by less than epsilon seconds, and when the respective
 470 events match.  dir-path is a (probably absolute) path to a directory
 471 that contains one set of measuring data.  root-dir must be equal for
 472 all pojects."
 473   ;; TODO: epsilon could be a range.  We would do a raw mapping by (a bigger) time epsilon and then take speed into account.
 474   (assert
 475    (every #'string= (namestring root-dir) (namestring dir-path))
 476    () "~A is not a leading part of ~A." root-dir dir-path)
 477   (assert-phoros-db-major-version)
 478   (assert     ;not strictly necessary, but may save the user some time
 479    (select-dao 'sys-acquisition-project
 480                (:= 'common-table-name common-table-name))
 481    () "There is no acquisition project named ~A." common-table-name)
 482   (setf *random-state* (make-random-state t))
 483   (create-data-table-definitions common-table-name)
 484   (initialize-leap-seconds)
 485   (let* ((images
 486           (collect-pictures-directory-data dir-path))
 487          (estimated-time
 488           (loop
 489              for i across images
 490              unless (or (fake-trigger-time-p i)
 491                         (< (trigger-time i) *gps-epoch*))
 492              do (return (trigger-time i))))
 493          (gps-points
 494           (if aggregate-events
 495               (aggregate-gps-events (collect-gps-data dir-path estimated-time))
 496               (collect-gps-data dir-path estimated-time)))
 497          (gps-start-pointers (loop
 498                                 for i in gps-points
 499                                 collect (cons (car i) 0)))
 500          (mapped-image-counter (length images))
 501          (cartesian-system (assert-gps-points-sanity gps-points))
 502          (dir-below-root-dir (enough-namestring dir-path root-dir)))
 503     (cl-log:log-message
 504      :db-dat "I assume this measure was taken approximately ~A."
 505      (timestring (round estimated-time)))
 506     (loop
 507        for i across images
 508        for image-event-number = (or aggregate-events
 509                                     (device-event-number (recorded-device-id i)
 510                                                          estimated-time))
 511        for image-time = (trigger-time i)
 512        for matching-point =
 513          (when image-time               ;otherwise this image is junk
 514            (let ((gps-start-pointer
 515                   (cdr (assoc image-event-number gps-start-pointers
 516                               :test #'equal))))
 517              (assert gps-start-pointer ()
 518                      "Can't find an event number of ~S ~
 519                       (as suggested by the sys tables relevant to the ~
 520                       current image) among ~{~S~#^, ~} ~
 521                       (as derived from the names of the GPS event files).  ~
 522                       Consider using --aggregate-events if you can't ~
 523                       recitfy your data."
 524                      image-event-number (mapcar #'car gps-start-pointers))
 525              (loop
 526                 for gps-pointer from gps-start-pointer
 527                 for gps-point across (subseq (cdr (assoc image-event-number
 528                                                          gps-points
 529                                                          :test #'equal))
 530                                              gps-start-pointer)
 531                 when (almost= (gps-time gps-point) image-time epsilon)
 532                 do (setf (cdr (assoc image-event-number
 533                                      gps-start-pointers :test #'equal))
 534                          gps-pointer) ;remember index of last matching point
 535                 and return gps-point)))
 536        if matching-point
 537        do (let ((point-id               ; TODO: consider using transaction
 538                  (or (point-id matching-point) ; We've hit a point twice.
 539                      (sequence-next (point-id-sequence-name matching-point))))
 540                 (measurement-id (get-measurement-id common-table-name
 541                                                     dir-below-root-dir
 542                                                     cartesian-system)))
 543             (setf (point-id i) point-id
 544                   (point-id matching-point) point-id
 545                   (measurement-id matching-point) measurement-id
 546                   (measurement-id i) measurement-id
 547                   (trigger-time matching-point) image-time)
 548             (save-dao matching-point)
 549             (execute (:update (dao-table-name (class-of matching-point))
 550                               :set 'coordinates
 551                               (:st_geomfromewkt
 552                                (format nil "SRID=4326; POINT(~S ~S ~S)"
 553                                        (longitude matching-point)
 554                                        (latitude matching-point)
 555                                        (ellipsoid-height matching-point)))
 556                               :where (:= 'point-id (point-id matching-point))))
 557             (save-dao i))
 558        else do
 559          (decf mapped-image-counter)
 560          (cl-log:log-message
 561           :orphan
 562           "Couldn't map to any point: ~A~A, byte ~S. ~
 563            ~:[~; It didn't have a decent trigger time anyway.~]"
 564           dir-path (filename i) (image-byte-position i)
 565           (fake-trigger-time-p i)))
 566     (cl-log:log-message
 567      :db-dat
 568      "Tried to map ~D images to GPS points.  ~
 569       The attempt has been successful in ~:[~D~;all~] cases.~
 570       ~1@*~:[  See file ~3@*~A for details on the failures.~;~]"
 571      (length images)
 572      (= (length images) mapped-image-counter)
 573      mapped-image-counter
 574      (truename
 575       (cl-log:text-file-messenger-file (cl-log:find-messenger :orphan))))))
 576
 577 (defun assert-user-points-version (user-points-version)
 578   "Check if user-points-version is compatible with the current
 579 user-point table definition."
 580   (multiple-value-bind (major minor revision)
 581       (version-number-parts user-points-version)
 582     (declare (ignore minor revision))
 583     (cond              ;insert more interesting clauses when necessary
 584       ((null user-points-version)
 585        (warn "Storing user-points which don't have a version number."))
 586       ((> major (phoros-version :major t))
 587        (warn  "User-point file was created by Phoros ~A ~
 588               which is newer than the current version ~A."
 589               user-points-version (phoros-version)))
 590       ((< major 13)
 591        (error "User-point file was created by Phoros ~A ~
 592               which is incompatible with the current version ~A.  ~
 593               Please edit the file like so: ~
 594               (1) Change any occurence of the name \"attribute\" to \"kind\". ~
 595               (2) Change the value of name \"phorosVersion\" ~
 596               from ~0@*~S to \"13.0.0\".  Then retry."
 597               user-points-version (phoros-version)))
 598        (t))))
 599
 600 (defun* store-user-points (presentation-project-name &mandatory-key json-file)
 601   "Store in DB user points given in file at json-file, which
 602 supposedly was created by Phoros.  Return number of points stored,
 603 number of points that were already in DB, number of points found in
 604 JSON file, and a list containing user-names from the json file that
 605 don't exist in DB."
 606   (assert-phoros-db-major-version)
 607   (let* ((user-point-table-name
 608           (user-point-table-name presentation-project-name))
 609          (raw-input (with-open-file (stream json-file)
 610                       (json:decode-json stream)))
 611          (raw-input-version (cdr (assoc :phoros-version raw-input)))
 612          (raw-features (cdr (assoc :features raw-input))))
 613     (assert-user-points-version raw-input-version)
 614     (loop
 615        for i in raw-features
 616        for coordinates = (cdr (assoc :coordinates (cdr (assoc :geometry i))))
 617        for point-form = (format nil "SRID=4326; POINT(~{~S ~})" coordinates)
 618        for properties = (cdr (assoc :properties i))
 619        for user-name = (cdr (assoc :user-name properties))
 620        for kind = (cdr (assoc :kind properties))
 621        for description = (cdr (assoc :description properties))
 622        for numeric-description = (cdr (assoc :numeric-description properties))
 623        for creation-date = (cdr (assoc :creation-date properties))
 624        ;; for stdx-global = (cdr (assoc :stdx-global properties))
 625        ;; for stdy-global = (cdr (assoc :stdy-global properties))
 626        ;; for stdz-global = (cdr (assoc :stdz-global properties))
 627        for input-size = (cdr (assoc :input-size properties))
 628        for aux-numeric = (cdr (assoc :aux-numeric properties))
 629        for aux-text = (cdr (assoc :aux-text properties))
 630        for aux-numeric-comparison =
 631          (if aux-numeric
 632              (format nil "(~A = (CAST (ARRAY[~{~S~#^,~}] AS NUMERIC[])))"
 633                      (s-sql:to-sql-name 'aux-numeric) aux-numeric)
 634              (sql (:is-null 'aux-numeric)))
 635        for aux-text-comparison =
 636          (if aux-text
 637              (sql (:= 'aux-text (vector-null aux-text)))
 638              (sql (:is-null 'aux-text)))
 639        with points-stored = 0
 640        with points-already-in-db = 0
 641        with unknown-users = nil
 642        sum 1 into points-tried
 643        do
 644          (if
 645           (query
 646            (:select
 647             t
 648             :from user-point-table-name
 649             :where (:and (:st_equals 'coordinates
 650                                      (:st_geomfromewkt point-form))
 651                          (:= 'kind kind)
 652                          (:= 'description description)
 653                          (:= 'numeric-description numeric-description)
 654                          (:= (:to-char 'creation-date
 655                                        *user-point-creation-date-format*)
 656                              creation-date)
 657                          ;; (:= 'stdx-global stdx-global)
 658                          ;; (:= 'stdy-global stdy-global)
 659                          ;; (:= 'stdz-global stdz-global)
 660                          (:= 'input-size input-size)
 661                          (:raw aux-numeric-comparison)
 662                          (:raw aux-text-comparison))))
 663           (incf points-already-in-db)
 664           (progn
 665             (unless (and user-name
 666                          (query
 667                           (:select t
 668                                    :from 'sys-user
 669                                    :where (:= 'user-name user-name))))
 670               (pushnew user-name unknown-users :test #'equal))
 671             (assert
 672              (= 1
 673                 (execute
 674                  (sql-compile
 675                   `(:insert-into
 676                     ,user-point-table-name :set
 677                     'coordinates (:st_geomfromewkt ,point-form)
 678                     'user-id ,(if user-name
 679                                   `(:select 'user-id
 680                                             :from 'sys-user
 681                                             :where (:= 'user-name
 682                                                        ,user-name))
 683                                   :null)
 684                     'kind ,kind
 685                     'description ,description
 686                     'numeric-description ,numeric-description
 687                     'creation-date ,creation-date
 688                     ;; 'stdx-global ,stdx-global
 689                     ;; 'stdy-global ,stdy-global
 690                     ;; 'stdz-global ,stdz-global
 691                     'input-size ,input-size
 692                     'aux-numeric ,(if aux-numeric
 693                                       (vector-null aux-numeric)
 694                                       :null)
 695                     'aux-text ,(if aux-text
 696                                    (vector-null aux-text)
 697                                    :null)))))
 698              () "Point not stored.  This should not happen.")
 699             (incf points-stored)))
 700        finally (return (values points-stored
 701                                points-already-in-db
 702                                points-tried
 703                                unknown-users)))))
 704
 705 (defun vector-null (elements)
 706   "Return a vector made from list elements, but with any occurrences
 707 of NIL replaced by NULL."
 708   (substitute-if :null #'null (apply #'vector elements)))
 709
 710 (defun update-footprint (common-table-name
 711                          measurement-id filename byte-position)
 712   "Update footprint of an image."
 713   (let* ((aggregate-view-name
 714           (aggregate-view-name common-table-name))
 715          (raw-footprint
 716           (photogrammetry
 717            :footprint
 718            ;; KLUDGE: translate keys, e.g. a1 -> a_1
 719            (json:decode-json-from-string
 720             (json:encode-json-to-string
 721              (query (:select '*
 722                              :from aggregate-view-name
 723                              :where (:and (:= 'measurement-id measurement-id)
 724                                           (:= 'filename filename)
 725                                           (:= 'byte-position byte-position)))
 726                     :alist)))))
 727          (ewkt-footprint
 728           (format nil "SRID=4326; POLYGON((~{~{~A~#^ ~}~#^, ~}))"
 729                   (cdr (assoc :footprint raw-footprint)))))
 730     (execute
 731      (:update aggregate-view-name :set
 732               'footprint (:st_geomfromewkt ewkt-footprint)
 733               :where (:and (:= 'measurement-id measurement-id)
 734                            (:= 'filename filename)
 735                            (:= 'byte-position byte-position))))))
 736
 737
 738 (defun insert-footprints (common-table-name)
 739   "Give images of acquisition project common-table-name that don't
 740 have up-to-date footprints fresh footprints."
 741   (let* ((log-frequency 200)
 742          (aggregate-view-name
 743           (aggregate-view-name common-table-name))
 744          (number-of-image-records
 745           (query (:select (:count '*)
 746                           :from aggregate-view-name
 747                           :where (:and
 748                                   (:or
 749                                    (:is-null 'footprint)
 750                                    (:!= 'footprint-device-stage-of-life-id
 751                                         'device-stage-of-life-id))
 752                                   'usable))
 753                  :single!)))
 754     (loop
 755        for image-records
 756        = (query (:limit
 757                  (:order-by
 758                   (:select 'measurement-id 'filename 'byte-position
 759                            :from aggregate-view-name
 760                            :where (:and
 761                                    (:or
 762                                     (:is-null 'footprint)
 763                                     (:!= 'footprint-device-stage-of-life-id
 764                                          'device-stage-of-life-id))
 765                                    'usable))
 766                   'measurement-id 'filename 'byte-position)
 767                  log-frequency))
 768        while image-records
 769        sum (loop
 770               for (measurement-id filename byte-position) in image-records
 771               sum (update-footprint
 772                    common-table-name measurement-id filename byte-position))
 773        into number-of-updated-footprints
 774        do (cl-log:log-message
 775            :db-dat
 776            "Updating image footprints of acquisition project ~A: ~
 777            ~D out of ~D done."
 778            common-table-name
 779            number-of-updated-footprints number-of-image-records)
 780        finally (return number-of-updated-footprints))))
 781
 782 (defun insert-all-footprints (postgresql-credentials)
 783   "Asynchronously update image footprints of all acquisition projects
 784 where necessarcy."
 785   (let ((common-table-names
 786          (with-connection postgresql-credentials
 787            (query (:select 'common-table-name
 788                            :from 'sys-acquisition-project)
 789                   :list))))
 790     (setf bt:*default-special-bindings*
 791           (acons '*insert-footprints-postgresql-credentials*
 792                  `(list ,@postgresql-credentials)
 793                  nil))
 794     (dolist (common-table-name common-table-names)
 795       (bt:make-thread
 796        #'(lambda ()
 797            (declare (special *insert-footprints-postgresql-credentials*))
 798            (with-connection *insert-footprints-postgresql-credentials*
 799              (insert-footprints common-table-name)))
 800        :name "insert-all-footprints"))))
 801
 802 (defun delete-imageless-points (common-table-name)
 803   "Delete from acquisition project common-table-name points that have
 804 no images."
 805   (let* ((point-data-table-name (point-data-table-name common-table-name))
 806          (image-data-table-name (image-data-table-name common-table-name)))
 807     (execute
 808      (:delete-from point-data-table-name
 809                    :where (:not
 810                            (:exists
 811                             (:select (:dot image-data-table-name 'point-id)
 812                                      :from image-data-table-name
 813                                      :where (:= (:dot image-data-table-name
 814                                                       'point-id)
 815                                                 (:dot point-data-table-name
 816                                                       'point-id)))))))))
 817
 818 (defun delete-all-imageless-points (postgresql-credentials)
 819   "Asynchronously delete imageless footprints of all acquisition
 820 projects."
 821   (let ((common-table-names
 822          (with-connection postgresql-credentials
 823            (query (:select 'common-table-name
 824                            :from 'sys-acquisition-project)
 825                   :list))))
 826     (setf bt:*default-special-bindings*
 827           (acons '*delete-imageless-points-postgresql-credentials*
 828                  `(list ,@postgresql-credentials)
 829                  nil))
 830     (dolist (common-table-name common-table-names)
 831       (bt:make-thread
 832        #'(lambda ()
 833            (declare (special *delete-imageless-points-postgresql-credentials*))
 834            (with-connection *delete-imageless-points-postgresql-credentials*
 835              (delete-imageless-points common-table-name)))
 836        :name "delete-all-imageless-points"))))
 837
 838 (defun* store-camera-hardware (&key
 839                                (try-overwrite t)
 840                                &mandatory-key
 841                                sensor-width-pix
 842                                sensor-height-pix
 843                                pix-size
 844                                channels
 845                                pix-depth
 846                                color-raiser
 847                                bayer-pattern
 848                                serial-number
 849                                description)
 850   "Store a new record in table sys-camera-hardware, or try updating an
 851 existing one.  Return camera-hardware-id of the altered record."
 852   (assert-phoros-db-major-version)
 853   (let ((record
 854          (or (when try-overwrite
 855                (car (select-dao 'sys-camera-hardware
 856                                 (:and (:= 'sensor-width-pix sensor-width-pix)
 857                                       (:= 'sensor-height-pix sensor-height-pix)
 858                                       (:= 'pix-size pix-size)
 859                                       (:= 'channels channels)
 860                                       (:= 'serial-number serial-number)
 861                                       (:= 'pix-depth pix-depth)))))
 862              (make-instance 'sys-camera-hardware :fetch-defaults t))))
 863     (with-slots ((sensor-width-pix-slot sensor-width-pix)
 864                  (sensor-height-pix-slot sensor-height-pix)
 865                  (pix-size-slot pix-size)
 866                  (channels-slot channels)
 867                  (pix-depth-slot pix-depth)
 868                  (color-raiser-slot color-raiser)
 869                  (bayer-pattern-slot bayer-pattern)
 870                  (serial-number-slot serial-number)
 871                  (description-slot description))
 872         record
 873       (setf sensor-width-pix-slot sensor-width-pix
 874             sensor-height-pix-slot sensor-height-pix
 875             pix-size-slot pix-size
 876             channels-slot channels
 877             pix-depth-slot pix-depth
 878             color-raiser-slot color-raiser
 879             bayer-pattern-slot bayer-pattern
 880             serial-number-slot serial-number
 881             description-slot description))
 882     (let ((new-row-p (save-dao record)))
 883       (cl-log:log-message
 884        :db-sys
 885        "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
 886        new-row-p (camera-hardware-id record)))
 887     (camera-hardware-id record)))
 888
 889 (defun* store-lens (&key (try-overwrite t)
 890                          &mandatory-key
 891                          c
 892                          serial-number
 893                          description)
 894   "Store a new record in table sys-lens, or try updating an existing
 895 one.  Return lens-id of the altered record."
 896   (assert-phoros-db-major-version)
 897   (let ((record
 898          (or (when try-overwrite
 899                (car (select-dao 'sys-lens
 900                                 (:and (:= 'c c)
 901                                       (:= 'serial-number serial-number)))))
 902              (make-instance 'sys-lens :fetch-defaults t))))
 903     (with-slots ((c-slot c)
 904                  (serial-number-slot serial-number)
 905                  (description-slot description))
 906         record
 907       (setf c-slot c
 908             serial-number-slot serial-number
 909             description-slot description))
 910     (let ((new-row-p (save-dao record)))
 911       (cl-log:log-message
 912        :db-sys "sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
 913        new-row-p (lens-id record)))
 914     (lens-id record)))
 915
 916 (defun store-generic-device
 917     (&key (camera-hardware-id :null) (lens-id :null) (scanner-id :null))
 918   "Store a new record in table sys-generic-device.  Return
 919 generic-device-id of the new record."
 920   (assert-phoros-db-major-version)
 921   (assert (notevery
 922            #'(lambda (x) (eq :null x))
 923            (list camera-hardware-id lens-id scanner-id))
 924           () "Generic device: not enough components.")
 925   (let ((record (make-instance 'sys-generic-device
 926                                :camera-hardware-id camera-hardware-id
 927                                :lens-id lens-id
 928                                :scanner-id scanner-id
 929                                :fetch-defaults t)))
 930     (let ((new-row-p (save-dao record)))
 931       (cl-log:log-message
 932        :db-sys
 933        "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
 934        new-row-p (generic-device-id record)))
 935     (generic-device-id record)))
 936
 937 (defun* store-device-stage-of-life (&key (unmounting-date :null)
 938                                    (try-overwrite t)
 939                                    &mandatory-key
 940                                    recorded-device-id
 941                                    event-number
 942                                    generic-device-id
 943                                    vehicle-name
 944                                    casing-name
 945                                    computer-name
 946                                    computer-interface-name
 947                                    mounting-date)
 948   "Store a new record in table sys-device-stage-of-life, or try
 949 updating an existing one.  Return device-stage-of-life-id of the
 950 altered record."
 951   (assert-phoros-db-major-version)
 952   (let ((record
 953          (or (when try-overwrite
 954                (car (select-dao
 955                      'sys-device-stage-of-life
 956                      (:and (:= 'recorded-device-id recorded-device-id)
 957                            (:= 'event-number event-number)
 958                            (:= 'generic-device-id generic-device-id)
 959                            (:= 'vehicle-name vehicle-name)
 960                            (:= 'mounting-date mounting-date)))))
 961              (make-instance 'sys-device-stage-of-life :fetch-defaults t))))
 962     (with-slots ((recorded-device-id-slot recorded-device-id)
 963                  (event-number-slot event-number)
 964                  (generic-device-id-slot generic-device-id)
 965                  (vehicle-name-slot vehicle-name)
 966                  (casing-name-slot casing-name)
 967                  (computer-name-slot computer-name)
 968                  (computer-interface-name-slot computer-interface-name)
 969                  (mounting-date-slot mounting-date)
 970                  (unmounting-date-slot unmounting-date))
 971         record
 972       (setf recorded-device-id-slot recorded-device-id
 973             event-number-slot event-number
 974             generic-device-id-slot generic-device-id
 975             vehicle-name-slot vehicle-name
 976             casing-name-slot casing-name
 977             computer-name-slot computer-name
 978             computer-interface-name-slot computer-interface-name
 979             mounting-date-slot mounting-date
 980             unmounting-date-slot unmounting-date))
 981     (let ((new-row-p (save-dao record)))
 982       (cl-log:log-message
 983        :db-sys
 984        "sys-device-stage-of-life: ~:[Updated~;Stored new~] ~
 985        device-stage-of-life-id ~A"
 986        new-row-p (device-stage-of-life-id record)))
 987     (device-stage-of-life-id record)))
 988
 989 (defun* store-device-stage-of-life-end (&mandatory-key device-stage-of-life-id
 990                                                        unmounting-date)
 991   "Update record in table sys-device-stage-of-life with an unmounting
 992 date.  Return device-stage-of-life-id of the altered record."
 993   (assert-phoros-db-major-version)
 994   (let ((record
 995          (get-dao 'sys-device-stage-of-life device-stage-of-life-id)))
 996     (with-slots ((unmounting-date-slot unmounting-date))
 997         record
 998       (setf unmounting-date-slot unmounting-date))
 999     (update-dao record)
1000     (device-stage-of-life-id record)))
1001
1002 (defun* store-camera-calibration (&key
1003                                   (usable t)
1004                                   &mandatory-key
1005                                   device-stage-of-life-id
1006                                   date
1007                                   person
1008                                   main-description
1009                                   debug
1010                                   photogrammetry-version
1011                                   mounting-angle
1012                                   inner-orientation-description
1013                                   c
1014                                   xh
1015                                   yh
1016                                   a1
1017                                   a2
1018                                   a3
1019                                   b1
1020                                   b2
1021                                   c1
1022                                   c2
1023                                   r0
1024                                   outer-orientation-description
1025                                   dx
1026                                   dy
1027                                   dz
1028                                   omega
1029                                   phi
1030                                   kappa
1031                                   boresight-description
1032                                   b-dx
1033                                   b-dy
1034                                   b-dz
1035                                   b-ddx
1036                                   b-ddy
1037                                   b-ddz
1038                                   b-rotx
1039                                   b-roty
1040                                   b-rotz
1041                                   b-drotx
1042                                   b-droty
1043                                   b-drotz
1044                                   nx
1045                                   ny
1046                                   nz
1047                                   d)
1048   "Store a new record of camera-calibration in table
1049 sys-device-stage-of-life, or update an existing one.  Return
1050 device-stage-of-life-id and date of the altered record."
1051   (assert-phoros-db-major-version)
1052   (let ((record
1053          (or (car (select-dao
1054                    'sys-camera-calibration
1055                    (:and (:= 'device-stage-of-life-id device-stage-of-life-id)
1056                          (:= 'date date))))
1057              (make-instance 'sys-camera-calibration :fetch-defaults t))))
1058     (with-slots
1059           ((device-stage-of-life-id-slot device-stage-of-life-id)
1060            (date-slot date)
1061            (person-slot person)
1062            (main-description-slot main-description)
1063            (usable-slot usable)
1064            (debug-slot debug)
1065            (photogrammetry-version-slot photogrammetry-version)
1066            (mounting-angle-slot mounting-angle)
1067            (inner-orientation-description-slot inner-orientation-description)
1068            (c-slot c)
1069            (xh-slot xh)
1070            (yh-slot yh)
1071            (a1-slot a1)
1072            (a2-slot a2)
1073            (a3-slot a3)
1074            (b1-slot b1)
1075            (b2-slot b2)
1076            (c1-slot c1)
1077            (c2-slot c2)
1078            (r0-slot r0)
1079            (outer-orientation-description-slot outer-orientation-description)
1080            (dx-slot dx)
1081            (dy-slot dy)
1082            (dz-slot dz)
1083            (omega-slot omega)
1084            (phi-slot phi)
1085            (kappa-slot kappa)
1086            (boresight-description-slot boresight-description)
1087            (b-dx-slot b-dx)
1088            (b-dy-slot b-dy)
1089            (b-dz-slot b-dz)
1090            (b-ddx-slot b-ddx)
1091            (b-ddy-slot b-ddy)
1092            (b-ddz-slot b-ddz)
1093            (b-rotx-slot b-rotx)
1094            (b-roty-slot b-roty)
1095            (b-rotz-slot b-rotz)
1096            (b-drotx-slot b-drotx)
1097            (b-droty-slot b-droty)
1098            (b-drotz-slot b-drotz)
1099            (nx-slot nx)
1100            (ny-slot ny)
1101            (nz-slot nz)
1102            (d-slot d))
1103         record
1104       (setf device-stage-of-life-id-slot device-stage-of-life-id
1105             date-slot date
1106             person-slot person
1107             main-description-slot main-description
1108             usable-slot usable
1109             debug-slot debug
1110             photogrammetry-version-slot photogrammetry-version
1111             mounting-angle-slot mounting-angle
1112             inner-orientation-description-slot inner-orientation-description
1113             c-slot c
1114             xh-slot xh
1115             yh-slot yh
1116             a1-slot a1
1117             a2-slot a2
1118             a3-slot a3
1119             b1-slot b1
1120             b2-slot b2
1121             c1-slot c1
1122             c2-slot c2
1123             r0-slot r0
1124             outer-orientation-description-slot outer-orientation-description
1125             dx-slot dx
1126             dy-slot dy
1127             dz-slot dz
1128             omega-slot omega
1129             phi-slot phi
1130             kappa-slot kappa
1131             boresight-description-slot boresight-description
1132             b-dx-slot b-dx
1133             b-dy-slot b-dy
1134             b-dz-slot b-dz
1135             b-ddx-slot b-ddx
1136             b-ddy-slot b-ddy
1137             b-ddz-slot b-ddz
1138             b-rotx-slot b-rotx
1139             b-roty-slot b-roty
1140             b-rotz-slot b-rotz
1141             b-drotx-slot b-drotx
1142             b-droty-slot b-droty
1143             b-drotz-slot b-drotz
1144             nx-slot nx
1145             ny-slot ny
1146             nz-slot nz
1147             d-slot d))
1148     (let ((new-row-p (save-dao record)))
1149       (cl-log:log-message
1150        :db-sys
1151        "sys-camera-calibration: ~:[Updated~;Stored new~] record ~
1152         for ~A, device-stage-of-life-id ~A"
1153        new-row-p (date record) (device-stage-of-life-id record)))
1154     (values (device-stage-of-life-id record)
1155             (date record))))