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 "~A"
  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 do (cl-log:log-message
 536                         :debug
 537                         "Mapped image ~A~A, byte ~S, taken ~A, to GPS point ~
 538                          recorded at ~A (difference being ~F s)."
 539                         dir-path (filename i) (image-byte-position i)
 540                         (timestring image-time) (timestring (gps-time gps-point))
 541                         (- image-time (gps-time gps-point)))
 542                 and return gps-point)))
 543        if matching-point
 544        do (let ((point-id               ; TODO: consider using transaction
 545                  (or (point-id matching-point) ; We've hit a point twice.
 546                      (sequence-next (point-id-sequence-name matching-point))))
 547                 (measurement-id (get-measurement-id common-table-name
 548                                                     dir-below-root-dir
 549                                                     cartesian-system)))
 550             (setf (point-id i) point-id
 551                   (point-id matching-point) point-id
 552                   (measurement-id matching-point) measurement-id
 553                   (measurement-id i) measurement-id
 554                   (trigger-time matching-point) image-time)
 555             (save-dao matching-point)
 556             (execute (:update (dao-table-name (class-of matching-point))
 557                               :set 'coordinates
 558                               (:st_geomfromewkt
 559                                (format nil "SRID=4326; POINT(~S ~S ~S)"
 560                                        (longitude matching-point)
 561                                        (latitude matching-point)
 562                                        (ellipsoid-height matching-point)))
 563                               :where (:= 'point-id (point-id matching-point))))
 564             (save-dao i))
 565        else do
 566          (decf mapped-image-counter)
 567          (cl-log:log-message
 568           :orphan
 569           "Couldn't map to any point: ~A*/~A, byte ~S, taken ~A (~F). ~
 570            ~:[~; It didn't have a decent trigger time anyway.~]"
 571           dir-path (filename i) (image-byte-position i)
 572           (timestring image-time) image-time (fake-trigger-time-p i)))
 573     (cl-log:log-message
 574      :db-dat
 575      "Tried to map ~D images to GPS points.  ~
 576       The attempt has been successful in ~:[~D~;all~] cases.~
 577       ~1@*~:[  See file ~3@*~A for details on the failures.~;~]"
 578      (length images)
 579      (= (length images) mapped-image-counter)
 580      mapped-image-counter
 581      (truename
 582       (cl-log:text-file-messenger-file (cl-log:find-messenger :orphan))))))
 583
 584 (defun assert-user-points-version (user-points-version)
 585   "Check if user-points-version is compatible with the current
 586 user-point table definition."
 587   (multiple-value-bind (major minor revision)
 588       (version-number-parts user-points-version)
 589     (declare (ignore minor revision))
 590     (cond              ;insert more interesting clauses when necessary
 591       ((null user-points-version)
 592        (warn "Storing user-points which don't have a version number."))
 593       ((> major (phoros-version :major t))
 594        (warn  "User-point file was created by Phoros ~A ~
 595               which is newer than the current version ~A."
 596               user-points-version (phoros-version)))
 597       ((< major 13)
 598        (error "User-point file was created by Phoros ~A ~
 599               which is incompatible with the current version ~A.  ~
 600               Please edit the file like so: ~
 601               (1) Change any occurence of the name \"attribute\" to \"kind\". ~
 602               (2) Change the value of name \"phorosVersion\" ~
 603               from ~0@*~S to \"13.0.0\".  Then retry."
 604               user-points-version (phoros-version)))
 605        (t))))
 606
 607 (defun* store-user-points (presentation-project-name &mandatory-key json-file)
 608   "Store in DB user points given in file at json-file, which
 609 supposedly was created by Phoros.  Return number of points stored,
 610 number of points that were already in DB, number of points found in
 611 JSON file, and a list containing user-names from the json file that
 612 don't exist in DB."
 613   (assert-phoros-db-major-version)
 614   (let* ((user-point-table-name
 615           (user-point-table-name presentation-project-name))
 616          (raw-input (with-open-file (stream json-file)
 617                       (json:decode-json stream)))
 618          (raw-input-version (cdr (assoc :phoros-version raw-input)))
 619          (raw-features (cdr (assoc :features raw-input))))
 620     (assert-user-points-version raw-input-version)
 621     (loop
 622        for i in raw-features
 623        for coordinates = (cdr (assoc :coordinates (cdr (assoc :geometry i))))
 624        for point-form = (format nil "SRID=4326; POINT(~{~S ~})" coordinates)
 625        for properties = (cdr (assoc :properties i))
 626        for user-name = (cdr (assoc :user-name properties))
 627        for kind = (cdr (assoc :kind properties))
 628        for description = (cdr (assoc :description properties))
 629        for numeric-description = (cdr (assoc :numeric-description properties))
 630        for creation-date = (cdr (assoc :creation-date properties))
 631        ;; for stdx-global = (cdr (assoc :stdx-global properties))
 632        ;; for stdy-global = (cdr (assoc :stdy-global properties))
 633        ;; for stdz-global = (cdr (assoc :stdz-global properties))
 634        for input-size = (cdr (assoc :input-size properties))
 635        for aux-numeric = (cdr (assoc :aux-numeric properties))
 636        for aux-text = (cdr (assoc :aux-text properties))
 637        for aux-numeric-comparison =
 638          (if aux-numeric
 639              (format nil "(~A = (CAST (ARRAY[~{~S~#^,~}] AS NUMERIC[])))"
 640                      (s-sql:to-sql-name 'aux-numeric) aux-numeric)
 641              (sql (:is-null 'aux-numeric)))
 642        for aux-text-comparison =
 643          (if aux-text
 644              (sql (:= 'aux-text (vector-null aux-text)))
 645              (sql (:is-null 'aux-text)))
 646        with points-stored = 0
 647        with points-already-in-db = 0
 648        with unknown-users = nil
 649        sum 1 into points-tried
 650        do
 651          (if
 652           (query
 653            (:select
 654             t
 655             :from user-point-table-name
 656             :where (:and (:st_equals 'coordinates
 657                                      (:st_geomfromewkt point-form))
 658                          (:= 'kind kind)
 659                          (:= 'description description)
 660                          (:= 'numeric-description numeric-description)
 661                          (:= (:to-char 'creation-date
 662                                        *user-point-creation-date-format*)
 663                              creation-date)
 664                          ;; (:= 'stdx-global stdx-global)
 665                          ;; (:= 'stdy-global stdy-global)
 666                          ;; (:= 'stdz-global stdz-global)
 667                          (:= 'input-size input-size)
 668                          (:raw aux-numeric-comparison)
 669                          (:raw aux-text-comparison))))
 670           (incf points-already-in-db)
 671           (progn
 672             (unless (and user-name
 673                          (query
 674                           (:select t
 675                                    :from 'sys-user
 676                                    :where (:= 'user-name user-name))))
 677               (pushnew user-name unknown-users :test #'equal))
 678             (assert
 679              (= 1
 680                 (execute
 681                  (sql-compile
 682                   `(:insert-into
 683                     ,user-point-table-name :set
 684                     'coordinates (:st_geomfromewkt ,point-form)
 685                     'user-id ,(if user-name
 686                                   `(:select 'user-id
 687                                             :from 'sys-user
 688                                             :where (:= 'user-name
 689                                                        ,user-name))
 690                                   :null)
 691                     'kind ,kind
 692                     'description ,description
 693                     'numeric-description ,numeric-description
 694                     'creation-date ,creation-date
 695                     ;; 'stdx-global ,stdx-global
 696                     ;; 'stdy-global ,stdy-global
 697                     ;; 'stdz-global ,stdz-global
 698                     'input-size ,input-size
 699                     'aux-numeric ,(if aux-numeric
 700                                       (vector-null aux-numeric)
 701                                       :null)
 702                     'aux-text ,(if aux-text
 703                                    (vector-null aux-text)
 704                                    :null)))))
 705              () "Point not stored.  This should not happen.")
 706             (incf points-stored)))
 707        finally (return (values points-stored
 708                                points-already-in-db
 709                                points-tried
 710                                unknown-users)))))
 711
 712 (defun vector-null (elements)
 713   "Return a vector made from list elements, but with any occurrences
 714 of NIL replaced by NULL."
 715   (substitute-if :null #'null (apply #'vector elements)))
 716
 717 (defun update-footprint (common-table-name
 718                          measurement-id filename byte-position)
 719   "Update footprint of an image."
 720   (let* ((aggregate-view-name
 721           (aggregate-view-name common-table-name))
 722          (raw-footprint
 723           (photogrammetry
 724            :footprint
 725            ;; KLUDGE: translate keys, e.g. a1 -> a_1
 726            (json:decode-json-from-string
 727             (json:encode-json-to-string
 728              (query (:select '*
 729                              :from aggregate-view-name
 730                              :where (:and (:= 'measurement-id measurement-id)
 731                                           (:= 'filename filename)
 732                                           (:= 'byte-position byte-position)))
 733                     :alist)))))
 734          (ewkt-footprint
 735           (format nil "SRID=4326; POLYGON((~{~{~A~#^ ~}~#^, ~}))"
 736                   (cdr (assoc :footprint raw-footprint)))))
 737     (execute
 738      (:update aggregate-view-name :set
 739               'footprint (:st_geomfromewkt ewkt-footprint)
 740               :where (:and (:= 'measurement-id measurement-id)
 741                            (:= 'filename filename)
 742                            (:= 'byte-position byte-position))))))
 743
 744
 745 (defun insert-footprints (common-table-name)
 746   "Give images of acquisition project common-table-name that don't
 747 have up-to-date footprints fresh footprints."
 748   (let* ((log-frequency 200)
 749          (aggregate-view-name
 750           (aggregate-view-name common-table-name))
 751          (number-of-image-records
 752           (query (:select (:count '*)
 753                           :from aggregate-view-name
 754                           :where (:and
 755                                   (:or
 756                                    (:is-null 'footprint)
 757                                    (:!= 'footprint-device-stage-of-life-id
 758                                         'device-stage-of-life-id))
 759                                   'usable))
 760                  :single!)))
 761     (loop
 762        for image-records
 763        = (query (:limit
 764                  (:order-by
 765                   (:select 'measurement-id 'filename 'byte-position
 766                            :from aggregate-view-name
 767                            :where (:and
 768                                    (:or
 769                                     (:is-null 'footprint)
 770                                     (:!= 'footprint-device-stage-of-life-id
 771                                          'device-stage-of-life-id))
 772                                    'usable))
 773                   'measurement-id 'filename 'byte-position)
 774                  log-frequency))
 775        while image-records
 776        sum (loop
 777               for (measurement-id filename byte-position) in image-records
 778               sum (update-footprint
 779                    common-table-name measurement-id filename byte-position))
 780        into number-of-updated-footprints
 781        do (cl-log:log-message
 782            :db-dat
 783            "Updating image footprints of acquisition project ~A: ~
 784            ~D out of ~D done."
 785            common-table-name
 786            number-of-updated-footprints number-of-image-records)
 787        finally (return number-of-updated-footprints))))
 788
 789 (defun insert-all-footprints (postgresql-credentials)
 790   "Asynchronously update image footprints of all acquisition projects
 791 where necessarcy."
 792   (let ((common-table-names
 793          (with-restarting-connection postgresql-credentials
 794            (query (:select 'common-table-name
 795                            :from 'sys-acquisition-project)
 796                   :list))))
 797     (setf bt:*default-special-bindings*
 798           (acons '*insert-footprints-postgresql-credentials*
 799                  `(list ,@postgresql-credentials)
 800                  nil))
 801     (dolist (common-table-name common-table-names)
 802       (bt:make-thread
 803        #'(lambda ()
 804            (declare (special *insert-footprints-postgresql-credentials*))
 805            (with-restarting-connection *insert-footprints-postgresql-credentials*
 806              (insert-footprints common-table-name)))
 807        :name "insert-all-footprints"))))
 808
 809 (defun delete-imageless-points (common-table-name)
 810   "Delete from acquisition project common-table-name points that have
 811 no images."
 812   (let* ((point-data-table-name (point-data-table-name common-table-name))
 813          (image-data-table-name (image-data-table-name common-table-name)))
 814     (execute
 815      (:delete-from point-data-table-name
 816                    :where (:not
 817                            (:exists
 818                             (:select (:dot image-data-table-name 'point-id)
 819                                      :from image-data-table-name
 820                                      :where (:= (:dot image-data-table-name
 821                                                       'point-id)
 822                                                 (:dot point-data-table-name
 823                                                       'point-id)))))))))
 824
 825 (defun delete-all-imageless-points (postgresql-credentials)
 826   "Asynchronously delete imageless points of all acquisition
 827 projects."
 828   (let ((common-table-names
 829          (with-restarting-connection postgresql-credentials
 830            (query (:select 'common-table-name
 831                            :from 'sys-acquisition-project)
 832                   :list))))
 833     (setf bt:*default-special-bindings*
 834           (acons '*delete-imageless-points-postgresql-credentials*
 835                  `(list ,@postgresql-credentials)
 836                  nil))
 837     (dolist (common-table-name common-table-names)
 838       (bt:make-thread
 839        #'(lambda ()
 840            (declare (special *delete-imageless-points-postgresql-credentials*))
 841            (with-restarting-connection *delete-imageless-points-postgresql-credentials*
 842              (delete-imageless-points common-table-name)))
 843        :name "delete-all-imageless-points"))))
 844
 845 (defun* store-camera-hardware (&key
 846                                (try-overwrite t)
 847                                &mandatory-key
 848                                sensor-width-pix
 849                                sensor-height-pix
 850                                pix-size
 851                                channels
 852                                pix-depth
 853                                color-raiser
 854                                bayer-pattern
 855                                serial-number
 856                                description)
 857   "Store a new record in table sys-camera-hardware, or try updating an
 858 existing one.  Return camera-hardware-id of the altered record."
 859   (assert-phoros-db-major-version)
 860   (let ((record
 861          (or (when try-overwrite
 862                (car (select-dao 'sys-camera-hardware
 863                                 (:and (:= 'sensor-width-pix sensor-width-pix)
 864                                       (:= 'sensor-height-pix sensor-height-pix)
 865                                       (:= 'pix-size pix-size)
 866                                       (:= 'channels channels)
 867                                       (:= 'serial-number serial-number)
 868                                       (:= 'pix-depth pix-depth)))))
 869              (make-instance 'sys-camera-hardware :fetch-defaults t))))
 870     (with-slots ((sensor-width-pix-slot sensor-width-pix)
 871                  (sensor-height-pix-slot sensor-height-pix)
 872                  (pix-size-slot pix-size)
 873                  (channels-slot channels)
 874                  (pix-depth-slot pix-depth)
 875                  (color-raiser-slot color-raiser)
 876                  (bayer-pattern-slot bayer-pattern)
 877                  (serial-number-slot serial-number)
 878                  (description-slot description))
 879         record
 880       (setf sensor-width-pix-slot sensor-width-pix
 881             sensor-height-pix-slot sensor-height-pix
 882             pix-size-slot pix-size
 883             channels-slot channels
 884             pix-depth-slot pix-depth
 885             color-raiser-slot color-raiser
 886             bayer-pattern-slot bayer-pattern
 887             serial-number-slot serial-number
 888             description-slot description))
 889     (let ((new-row-p (save-dao record)))
 890       (cl-log:log-message
 891        :db-sys
 892        "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
 893        new-row-p (camera-hardware-id record)))
 894     (camera-hardware-id record)))
 895
 896 (defun* store-lens (&key (try-overwrite t)
 897                          &mandatory-key
 898                          c
 899                          serial-number
 900                          description)
 901   "Store a new record in table sys-lens, or try updating an existing
 902 one.  Return lens-id of the altered record."
 903   (assert-phoros-db-major-version)
 904   (let ((record
 905          (or (when try-overwrite
 906                (car (select-dao 'sys-lens
 907                                 (:and (:= 'c c)
 908                                       (:= 'serial-number serial-number)))))
 909              (make-instance 'sys-lens :fetch-defaults t))))
 910     (with-slots ((c-slot c)
 911                  (serial-number-slot serial-number)
 912                  (description-slot description))
 913         record
 914       (setf c-slot c
 915             serial-number-slot serial-number
 916             description-slot description))
 917     (let ((new-row-p (save-dao record)))
 918       (cl-log:log-message
 919        :db-sys "sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
 920        new-row-p (lens-id record)))
 921     (lens-id record)))
 922
 923 (defun store-generic-device
 924     (&key (camera-hardware-id :null) (lens-id :null) (scanner-id :null))
 925   "Store a new record in table sys-generic-device.  Return
 926 generic-device-id of the new record."
 927   (assert-phoros-db-major-version)
 928   (assert (notevery
 929            #'(lambda (x) (eq :null x))
 930            (list camera-hardware-id lens-id scanner-id))
 931           () "Generic device: not enough components.")
 932   (let ((record (make-instance 'sys-generic-device
 933                                :camera-hardware-id camera-hardware-id
 934                                :lens-id lens-id
 935                                :scanner-id scanner-id
 936                                :fetch-defaults t)))
 937     (let ((new-row-p (save-dao record)))
 938       (cl-log:log-message
 939        :db-sys
 940        "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
 941        new-row-p (generic-device-id record)))
 942     (generic-device-id record)))
 943
 944 (defun* store-device-stage-of-life (&key (unmounting-date :null)
 945                                    (try-overwrite t)
 946                                    &mandatory-key
 947                                    recorded-device-id
 948                                    event-number
 949                                    generic-device-id
 950                                    vehicle-name
 951                                    casing-name
 952                                    computer-name
 953                                    computer-interface-name
 954                                    mounting-date)
 955   "Store a new record in table sys-device-stage-of-life, or try
 956 updating an existing one.  Return device-stage-of-life-id of the
 957 altered record."
 958   (assert-phoros-db-major-version)
 959   (let ((record
 960          (or (when try-overwrite
 961                (car (select-dao
 962                      'sys-device-stage-of-life
 963                      (:and (:= 'recorded-device-id recorded-device-id)
 964                            (:= 'event-number event-number)
 965                            (:= 'generic-device-id generic-device-id)
 966                            (:= 'vehicle-name vehicle-name)
 967                            (:= 'mounting-date mounting-date)))))
 968              (make-instance 'sys-device-stage-of-life :fetch-defaults t))))
 969     (with-slots ((recorded-device-id-slot recorded-device-id)
 970                  (event-number-slot event-number)
 971                  (generic-device-id-slot generic-device-id)
 972                  (vehicle-name-slot vehicle-name)
 973                  (casing-name-slot casing-name)
 974                  (computer-name-slot computer-name)
 975                  (computer-interface-name-slot computer-interface-name)
 976                  (mounting-date-slot mounting-date)
 977                  (unmounting-date-slot unmounting-date))
 978         record
 979       (setf recorded-device-id-slot recorded-device-id
 980             event-number-slot event-number
 981             generic-device-id-slot generic-device-id
 982             vehicle-name-slot vehicle-name
 983             casing-name-slot casing-name
 984             computer-name-slot computer-name
 985             computer-interface-name-slot computer-interface-name
 986             mounting-date-slot mounting-date
 987             unmounting-date-slot unmounting-date))
 988     (let ((new-row-p (save-dao record)))
 989       (cl-log:log-message
 990        :db-sys
 991        "sys-device-stage-of-life: ~:[Updated~;Stored new~] ~
 992        device-stage-of-life-id ~A"
 993        new-row-p (device-stage-of-life-id record)))
 994     (device-stage-of-life-id record)))
 995
 996 (defun* store-device-stage-of-life-end (&mandatory-key device-stage-of-life-id
 997                                                        unmounting-date)
 998   "Update record in table sys-device-stage-of-life with an unmounting
 999 date.  Return device-stage-of-life-id of the altered record."
1000   (assert-phoros-db-major-version)
1001   (let ((record
1002          (get-dao 'sys-device-stage-of-life device-stage-of-life-id)))
1003     (with-slots ((unmounting-date-slot unmounting-date))
1004         record
1005       (setf unmounting-date-slot unmounting-date))
1006     (update-dao record)
1007     (device-stage-of-life-id record)))
1008
1009 (defun* store-camera-calibration (&key
1010                                   (usable t)
1011                                   &mandatory-key
1012                                   device-stage-of-life-id
1013                                   date
1014                                   person
1015                                   main-description
1016                                   debug
1017                                   photogrammetry-version
1018                                   mounting-angle
1019                                   inner-orientation-description
1020                                   c
1021                                   xh
1022                                   yh
1023                                   a1
1024                                   a2
1025                                   a3
1026                                   b1
1027                                   b2
1028                                   c1
1029                                   c2
1030                                   r0
1031                                   outer-orientation-description
1032                                   dx
1033                                   dy
1034                                   dz
1035                                   omega
1036                                   phi
1037                                   kappa
1038                                   boresight-description
1039                                   b-dx
1040                                   b-dy
1041                                   b-dz
1042                                   b-ddx
1043                                   b-ddy
1044                                   b-ddz
1045                                   b-rotx
1046                                   b-roty
1047                                   b-rotz
1048                                   b-drotx
1049                                   b-droty
1050                                   b-drotz
1051                                   nx
1052                                   ny
1053                                   nz
1054                                   d)
1055   "Store a new record of camera-calibration in table
1056 sys-device-stage-of-life, or update an existing one.  Return
1057 device-stage-of-life-id and date of the altered record."
1058   (assert-phoros-db-major-version)
1059   (let ((record
1060          (or (car (select-dao
1061                    'sys-camera-calibration
1062                    (:and (:= 'device-stage-of-life-id device-stage-of-life-id)
1063                          (:= 'date date))))
1064              (make-instance 'sys-camera-calibration :fetch-defaults t))))
1065     (with-slots
1066           ((device-stage-of-life-id-slot device-stage-of-life-id)
1067            (date-slot date)
1068            (person-slot person)
1069            (main-description-slot main-description)
1070            (usable-slot usable)
1071            (debug-slot debug)
1072            (photogrammetry-version-slot photogrammetry-version)
1073            (mounting-angle-slot mounting-angle)
1074            (inner-orientation-description-slot inner-orientation-description)
1075            (c-slot c)
1076            (xh-slot xh)
1077            (yh-slot yh)
1078            (a1-slot a1)
1079            (a2-slot a2)
1080            (a3-slot a3)
1081            (b1-slot b1)
1082            (b2-slot b2)
1083            (c1-slot c1)
1084            (c2-slot c2)
1085            (r0-slot r0)
1086            (outer-orientation-description-slot outer-orientation-description)
1087            (dx-slot dx)
1088            (dy-slot dy)
1089            (dz-slot dz)
1090            (omega-slot omega)
1091            (phi-slot phi)
1092            (kappa-slot kappa)
1093            (boresight-description-slot boresight-description)
1094            (b-dx-slot b-dx)
1095            (b-dy-slot b-dy)
1096            (b-dz-slot b-dz)
1097            (b-ddx-slot b-ddx)
1098            (b-ddy-slot b-ddy)
1099            (b-ddz-slot b-ddz)
1100            (b-rotx-slot b-rotx)
1101            (b-roty-slot b-roty)
1102            (b-rotz-slot b-rotz)
1103            (b-drotx-slot b-drotx)
1104            (b-droty-slot b-droty)
1105            (b-drotz-slot b-drotz)
1106            (nx-slot nx)
1107            (ny-slot ny)
1108            (nz-slot nz)
1109            (d-slot d))
1110         record
1111       (setf device-stage-of-life-id-slot device-stage-of-life-id
1112             date-slot date
1113             person-slot person
1114             main-description-slot main-description
1115             usable-slot usable
1116             debug-slot debug
1117             photogrammetry-version-slot photogrammetry-version
1118             mounting-angle-slot mounting-angle
1119             inner-orientation-description-slot inner-orientation-description
1120             c-slot c
1121             xh-slot xh
1122             yh-slot yh
1123             a1-slot a1
1124             a2-slot a2
1125             a3-slot a3
1126             b1-slot b1
1127             b2-slot b2
1128             c1-slot c1
1129             c2-slot c2
1130             r0-slot r0
1131             outer-orientation-description-slot outer-orientation-description
1132             dx-slot dx
1133             dy-slot dy
1134             dz-slot dz
1135             omega-slot omega
1136             phi-slot phi
1137             kappa-slot kappa
1138             boresight-description-slot boresight-description
1139             b-dx-slot b-dx
1140             b-dy-slot b-dy
1141             b-dz-slot b-dz
1142             b-ddx-slot b-ddx
1143             b-ddy-slot b-ddy
1144             b-ddz-slot b-ddz
1145             b-rotx-slot b-rotx
1146             b-roty-slot b-roty
1147             b-rotz-slot b-rotz
1148             b-drotx-slot b-drotx
1149             b-droty-slot b-droty
1150             b-drotz-slot b-drotz
1151             nx-slot nx
1152             ny-slot ny
1153             nz-slot nz
1154             d-slot d))
1155     (let ((new-row-p (save-dao record)))
1156       (cl-log:log-message
1157        :db-sys
1158        "sys-camera-calibration: ~:[Updated~;Stored new~] record ~
1159         for ~A, device-stage-of-life-id ~A"
1160        new-row-p (date record) (device-stage-of-life-id record)))
1161     (values (device-stage-of-life-id record)
1162             (date record))))