stuff-db.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 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 structures containing data from the
  23 picture-headers of the .pictures file in path."
  24   (let ((estimated-header-length
  25          (ignore-errors
  26            (- (find-keyword path "PICTUREHEADER_END")
  27               (find-keyword path "PICTUREHEADER_BEGIN")
  28               *picture-header-length-tolerance*)))) ; allow for variation in dataSize and a few other parameters
  29     (if estimated-header-length ;otherwise we don't have a decent header
  30         (with-open-file (stream path :element-type 'unsigned-byte)
  31           (cl-log:log-message :db-dat "Digesting ~A." path)
  32           (loop
  33              with pictures-data = (make-array '(600) :fill-pointer 0)
  34              for picture-start =
  35              (find-keyword-in-stream stream "PICTUREHEADER_BEGIN" 0) then
  36              (find-keyword-in-stream stream "PICTUREHEADER_BEGIN"
  37                                      (+ picture-start picture-length
  38                                         estimated-header-length))
  39              for picture-length = (find-keyword-value
  40                                    path "dataSize=" picture-start
  41                                    estimated-header-length)
  42              and time-trigger = (utc-from-unix
  43                                  (or
  44                                   (find-keyword-value
  45                                    path "timeTrigger=" picture-start
  46                                    estimated-header-length)
  47                                   -1))
  48              and timestamp = (find-keyword-value
  49                               path "cameraTimestamp=" picture-start
  50                               estimated-header-length)
  51              and recorded-device-id = (format
  52                                        nil "~S"
  53                                        (find-keyword-value
  54                                         path "cam=" picture-start
  55                                         estimated-header-length))
  56              and gain = (find-keyword-value
  57                          path "gain=" picture-start estimated-header-length)
  58              and shutter = (find-keyword-value
  59                             path "shutter=" picture-start
  60                             estimated-header-length)
  61              while picture-start
  62              do (vector-push-extend
  63                  (make-instance
  64                   'image-data
  65                   :trigger-time time-trigger
  66                   :camera-timestamp timestamp
  67                   :recorded-device-id recorded-device-id
  68                   :filename (file-namestring path)
  69                   :gain gain
  70                   :shutter shutter
  71                   :byte-position picture-start)
  72                  pictures-data)
  73              finally
  74              (repair-missing-trigger-times pictures-data)
  75              (return  pictures-data)))
  76         (cl-log:log-message
  77          :db-dat "Skipping ~A because it looks disgusting." path))))
  78
  79 (defun repair-missing-trigger-times (images)
  80   "Use slot camera-timestamp to fake missing trigger-times."
  81   (labels ((slope (offending-index good-index)
  82              (/ (- (trigger-time (aref images (+ offending-index
  83                                                  (- good-index 2))))
  84                    (trigger-time (aref images (+ offending-index
  85                                                  (+ good-index 2)))))
  86                 (- (camera-timestamp (aref images (+ offending-index
  87                                                      (- good-index 2))))
  88                    (camera-timestamp (aref images (+ offending-index
  89                                                      (+ good-index 2)))))))
  90            (intercept (offending-index good-index slope)
  91              (- (trigger-time (aref images (+ offending-index good-index)))
  92                 (* slope (camera-timestamp (aref images (+ offending-index
  93                                                            good-index))))))
  94            (fake-trigger-time (offending-index good-index)
  95              (let* ((m (slope offending-index good-index))
  96                     (t-0 (intercept offending-index good-index m)))
  97                (+ (* m (camera-timestamp (aref images offending-index)))
  98                   t-0))))
  99     (dolist (offending-index
 100               (loop
 101                  with previous-trigger-time = 0
 102                  for h across images
 103                  for i from 0
 104                  for trigger-time = (trigger-time h)
 105                  if (> (+ trigger-time 1d-4) previous-trigger-time)
 106                  do (setf previous-trigger-time trigger-time)
 107                  else collect i))
 108       (ignore-errors
 109         (let ((good-index-offset -3))
 110           (handler-bind ((error #'(lambda (x) (declare (ignore x))
 111                                           (invoke-restart 'next-try))))
 112             (setf (trigger-time (aref images offending-index))
 113                   (restart-case
 114                       (fake-trigger-time offending-index good-index-offset)
 115                     (next-try ()
 116                       (incf good-index-offset 6)
 117                       (fake-trigger-time offending-index good-index-offset)))
 118                   (fake-trigger-time-p (aref images offending-index)) t)))))))
 119
 120 (defun collect-pictures-directory-data (dir-path)
 121   "Return vector of instances of class image-data with data from the
 122 .pictures files in dir-path."
 123   (let ((pictures-files
 124          (directory (make-pathname
 125                      :directory (append (pathname-directory dir-path)
 126                                         '(:wild-inferiors))
 127                      :name :wild :type "pictures"))))
 128     (assert pictures-files ()
 129             "Sorry, but I couldn't find a single .pictures file below ~A."
 130             dir-path)
 131     (reduce #'(lambda (x1 x2) (merge 'vector x1 x2 #'< :key #'trigger-time))
 132             (mapcar #'collect-pictures-file-data
 133                     pictures-files))))
 134
 135 (defun collect-gps-data (dir-path estimated-utc)
 136   "Put content of files in dir-path/**/applanix/*eventN.txt into
 137 vectors.  Return a list of elements (N vector) where N is the event
 138 number."
 139   (let* ((event-dir
 140           (make-pathname
 141            :directory (append (pathname-directory dir-path)
 142                               '(:wild-inferiors) '("applanix" "points"))
 143            :name :wild
 144            :type :wild))
 145          (gps-files (directory event-dir))
 146          (gps-event-files
 147           (loop
 148              for gps-file in gps-files
 149              for gps-basename = (pathname-name gps-file)
 150              for event-number = (ignore-errors
 151                                   (subseq gps-basename
 152                                           (mismatch
 153                                            gps-basename "event"
 154                                            :start1
 155                                            (search "event" gps-basename
 156                                                    :from-end t))))
 157              when event-number collect (list event-number gps-file))))
 158     (assert gps-event-files ()
 159             "Sorry, but I couldn't find a single GPS event file in ~A."
 160             (directory-namestring event-dir))
 161     (cl-log:log-message
 162      :db-dat "Digesting GPS data from ~{~A~#^, ~}."
 163      (mapcar #'cadr gps-event-files))
 164     (loop
 165        for gps-event-file-entry in gps-event-files
 166        for gps-event-number = (first gps-event-file-entry)
 167        for gps-event-file = (second gps-event-file-entry)
 168        collect
 169        (cons
 170         gps-event-number
 171         (with-open-file (stream gps-event-file)
 172           (loop
 173              for line = (read-line stream)
 174              for i from 0 to 35
 175              until (string-equal
 176                     (string-trim " 
" line)
 177                     "(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)")
 178              finally
 179                (read-line stream)
 180              (assert (< i 35) ()
 181                      "Unfamiliar header.  Check Applanix file format." nil))
 182           (loop
 183              with gps-points = (make-array '(1000) :fill-pointer 0)
 184              for line = (read-line stream nil)
 185              while line
 186              do (vector-push-extend
 187                  (let ((point (make-instance 'point-data)))
 188                    (with-slots
 189                          (gps-time
 190                           event-number
 191                           longitude latitude ellipsoid-height
 192                           roll pitch heading
 193                           east-velocity north-velocity up-velocity
 194                           east-sd north-sd height-sd
 195                           roll-sd pitch-sd heading-sd
 196                           easting northing cartesian-height)
 197                        point
 198                      (with-input-from-string (line-content line)
 199                        (setf event-number gps-event-number
 200                              gps-time
 201                              (utc-from-gps estimated-utc ; From GPS week time.
 202                                            (read line-content nil)))
 203                        (read line-content nil) ; Discard distance.
 204                        (setf easting (read line-content nil)
 205                              northing (read line-content nil)
 206                              cartesian-height (read line-content nil)
 207                              latitude (read line-content nil)
 208                              longitude (read line-content nil)
 209                              ellipsoid-height (read line-content nil)
 210                              roll (read line-content nil)
 211                              pitch (read line-content nil)
 212                              heading (read line-content nil)
 213                              east-velocity (read line-content nil)
 214                              north-velocity (read line-content nil)
 215                              up-velocity (read line-content nil)
 216                              east-sd (read line-content nil)
 217                              north-sd (read line-content nil)
 218                              height-sd (read line-content nil)
 219                              roll-sd (read line-content nil)
 220                              pitch-sd (read line-content nil)
 221                              heading-sd (read line-content nil))))
 222                    point)
 223                  gps-points)
 224              finally (return gps-points)))))))
 225
 226 (defun aggregate-gps-events (gps-points)
 227   "Turn an alist of ((event1 . points1) (event2 . points2)...) into
 228 ((t . all-points))."
 229   (cl-log:log-message
 230  :db-sys
 231  "I was asked to aggregate-events so I won't distinguish any event numbers.")
 232   (list
 233    (cons t (reduce #'(lambda (x y) (merge 'vector x y #'< :key #'gps-time))
 234                    (mapcar #'cdr gps-points)))))
 235
 236 (defparameter *leap-seconds* nil
 237   "An alist of (time . leap-seconds) elements.  leap-seconds are to be
 238   added to GPS time to get UTC.")
 239
 240 (defparameter *time-steps-history-url*
 241   "http://hpiers.obspm.fr/eoppc/bul/bulc/TimeSteps.history"
 242   "URL of the leap second table which should contain lines like this:
 243  1980  Jan.   1              - 1s
 244  1981  Jul.   1              - 1s
 245  ...")
 246
 247 (defparameter *time-steps-history-file*
 248   (make-pathname :directory '(:relative) :name "TimeSteps" :type "history")
 249   "Fallback in case *time-steps-history-url* is unavailable.")
 250
 251 (let ((leap-second-months
 252        (pairlis '("Jan." "Feb." "March" "Apr." "May" "Jun."
 253                   "Jul." "Aug." "Sept." "Oct." "Nov." "Dec.")
 254                 '(1 2 3 4 5 6 7 8 9 10 11 12))))
 255   ;; Month names as used in
 256   ;; http://hpiers.obspm.fr/eoppc/bul/bulc/TimeSteps.history."
 257   (defun initialize-leap-seconds () ; TODO: Security hole: read-from-string
 258     (handler-case
 259         (multiple-value-bind
 260               (body status-code headers uri stream must-close reason-phrase)
 261             (drakma:http-request *time-steps-history-url*)
 262           (declare (ignore headers stream must-close reason-phrase))
 263           (assert (= status-code 200))
 264           (with-open-file (stream *time-steps-history-file*
 265                                   :direction :output
 266                                   :if-exists :supersede
 267                                   :if-does-not-exist :create)
 268             (write-string body stream)
 269             (cl-log:log-message
 270              :debug "Downloaded leap second information from ~A." uri)))
 271       (error (e)
 272         (cl-log:log-message
 273          :warning
 274          "Couldn't get the latest leap seconds information from ~A. (~A)  Falling back to cached data in ~A."
 275          *time-steps-history-url* e *time-steps-history-file*)))
 276     (with-open-file (stream *time-steps-history-file*
 277                             :direction :input :if-does-not-exist :error)
 278       (loop for time-record = (string-trim "    " (read-line stream))
 279          until (equal 1980 (read-from-string time-record nil)))
 280       (setf
 281        *leap-seconds*
 282        (loop for time-record = (string-trim " s " (read-line stream))
 283           with leap = nil and leap-date = nil
 284           until (string-equal (subseq time-record 1 20)
 285                               (make-string 19 :initial-element #\-))
 286           do (with-input-from-string (line time-record)
 287                (let ((year (read line))
 288                      (month (cdr (assoc
 289                                   (read line)
 290                                   leap-second-months
 291                                   :test #'string-equal)))
 292                      (date (read line))
 293                      (sign (read line))
 294                      (seconds (read line)))
 295                  (setf leap-date (encode-universal-time 0 0 0 date month year 0)
 296                        leap (if (eq sign '-) (- seconds) seconds))))
 297           sum leap into leap-sum
 298           collect leap-date into leap-dates
 299           collect leap-sum into leap-sums
 300           finally (return (sort (pairlis leap-dates leap-sums) #'<
 301                                 :key #'car)))))))
 302
 303 (defparameter *gps-epoch* (encode-universal-time 0 0 0 6 1 1980 0))
 304 (defparameter *unix-epoch* (encode-universal-time 0 0 0 1 1 1970 0))
 305
 306 (defun gps-start-of-week (time)
 307   "Begin of a GPS week (approximately Sunday 00:00)"
 308   (let ((week-length (* 7 24 3600))
 309         (leap-seconds (cdr (find time *leap-seconds*
 310                                  :key #'car :test #'> :from-end t))))
 311     (assert leap-seconds ()
 312             "Couldn't determine leap seconds for ~A" (timestring (round time)))
 313     (+ (* (floor (- time *gps-epoch*) week-length)
 314           week-length)
 315        *gps-epoch*
 316        leap-seconds)))
 317
 318 (defun utc-from-gps (utc-approximately gps-week-time)
 319   "Convert GPS week time into UTC.  gps-week-time may be of type
 320 float; in this case a non-integer is returned which can't be fed into
 321 decode-universal-time."
 322   (+ (gps-start-of-week utc-approximately) gps-week-time))
 323
 324 (defun utc-from-unix (unix-time)
 325   "Convert UNIX UTC to Lisp time."
 326   (when unix-time (+ unix-time *unix-epoch*)))
 327
 328 ;;(defun event-number (recorded-device-id)
 329 ;;  "Return the GPS event number corresponding to recorded-device-id of camera (etc.)"
 330 ;;  (let ((event-table (pairlis '(21 22 11 12 1 2)
 331 ;;                              '("1" "1" "2" "2" "1" "1"))))
 332 ;;    (cdr (assoc recorded-device-id event-table)))) ; TODO: make a saner version
 333
 334
 335 (let (event-number-storage)
 336   (defun device-event-number (recorded-device-id utc)
 337     "Return the GPS event number (a string) corresponding to
 338 recorded-device-id (a string) of camera (etc.)"
 339     (let ((device-event-number
 340            (cdr (assoc recorded-device-id event-number-storage
 341                        :test #'string-equal))))
 342       (if device-event-number
 343           device-event-number
 344           (let* ((date (simple-date:universal-time-to-timestamp (round utc)))
 345                  (device-stage-of-life
 346                   (car
 347                    (select-dao
 348                     'sys-device-stage-of-life
 349                     (:and (:overlaps
 350                            (:set 'mounting-date
 351                                  (:least :current-date 'unmounting-date))
 352                            (:set (:date date) (:date date)))
 353                           (:= 'recorded-device-id recorded-device-id))))))
 354             (assert device-stage-of-life
 355                     ()
 356                     "Can't figure out what event-number belongs to recorded-device-id ~S of (approx.) ~A.  There should be some entry in table sys-device-stage-of-life to this end."
 357                     recorded-device-id (timestring (round utc)))
 358             (push (cons recorded-device-id (event-number device-stage-of-life))
 359                   event-number-storage)
 360             (event-number device-stage-of-life))))))
 361
 362 (defun almost= (x y epsilon)
 363   (< (abs (- x y)) epsilon))
 364
 365 (defun geographic-to-utm (utm-zone longitude latitude &optional (height 0d0))
 366   "Return UTM utm-zone representation of geographic coordinates."
 367   (let ((utm-coordinate-system
 368          (format nil "+proj=utm +ellps=WGS84 +zone=~D" utm-zone)))
 369     (proj:cs2cs (list (proj:degrees-to-radians longitude) (proj:degrees-to-radians latitude) height)
 370                 :destination-cs utm-coordinate-system)))
 371
 372 (defun utm-zone (longitude)
 373   "Return UTM zone number belonging to longitude."
 374   (1+ (floor (+ longitude 180) 6)))
 375
 376 (defun assert-utm-zone (longitude-median longitude-leeway longitude latitude
 377                         geographic-height easting northing cartesian-height)
 378   "Check if, given longitude and latitude, easting and northing are
 379 calculated in the UTM zone belonging to longitude-median."
 380   (let ((epsilon 1d-1))
 381     (unless
 382         (or (every #'(lambda (x y) (almost= x y epsilon))
 383                    (geographic-to-utm (utm-zone (- longitude-median
 384                                                    longitude-leeway))
 385                                       longitude latitude geographic-height)
 386                    (list easting northing cartesian-height))
 387             (every #'(lambda (x y) (almost= x y epsilon))
 388                    (geographic-to-utm (utm-zone (+ longitude-median
 389                                                    longitude-leeway))
 390                                       longitude latitude geographic-height)
 391                    (list easting northing cartesian-height)))
 392       (error "The longitude median ~A should be in or near UTM zone ~D.  ~
 393               This is inconsistent with the easting values I was given.  ~
 394               Offending coordinates: (~A ~A ~A) (~A ~A ~A)."
 395              longitude-median (utm-zone longitude-median) longitude latitude
 396              geographic-height easting northing cartesian-height))))
 397
 398 (defun assert-gps-points-sanity (gps-points)
 399   "Check if gps-points (as returned by collect-gps-data) are ok.
 400 Return the Proj.4 string describing the cartesian coordinate system
 401 used."
 402   (loop
 403      for gps-event in gps-points
 404      for gps-event-vector = (cdr gps-event)
 405      for first-longitude = (longitude (aref gps-event-vector 0))
 406      for first-latitude = (latitude (aref gps-event-vector 0))
 407      for first-geographic-height = (ellipsoid-height (aref gps-event-vector 0))
 408      for first-easting = (easting (aref gps-event-vector 0))
 409      for first-northing = (northing (aref gps-event-vector 0))
 410      for first-cartesian-height = (cartesian-height (aref gps-event-vector 0))
 411      for longitude-median =
 412        (loop
 413           for point across gps-event-vector
 414           for i from 1
 415           sum (longitude point) into longitude-sum
 416           finally (return (/ longitude-sum i)))
 417      do (assert-utm-zone longitude-median 1
 418                          first-longitude first-latitude
 419                          first-geographic-height
 420                          first-easting first-northing
 421                          first-cartesian-height)
 422      finally (return (format nil "+proj=utm +ellps=WGS84 +zone=~D"
 423                              (utm-zone longitude-median)))))
 424
 425 (defun get-measurement-id (common-table-name dir-path cartesian-system)
 426   "Get measurement-id associated with dir-path and
 427 acquisition-project-id.  Create a fresh matching record if necessary."
 428   (let ((acquisition-project
 429          (car (select-dao 'sys-acquisition-project
 430                           (:= 'common-table-name common-table-name)))))
 431     (assert acquisition-project)
 432     (let* ((acquisition-project-id (acquisition-project-id acquisition-project))
 433            (measurement
 434             (or (car (select-dao
 435                       'sys-measurement
 436                       (:and (:= 'acquisition-project-id acquisition-project-id)
 437                             (:= 'directory dir-path))))
 438                 (insert-dao
 439                  (make-instance 'sys-measurement
 440                                 :acquisition-project-id acquisition-project-id
 441                                 :directory dir-path
 442                                 :cartesian-system cartesian-system
 443                                 :fetch-defaults t)))))
 444       (measurement-id measurement))))
 445
 446 (defun store-images-and-points (common-table-name dir-path
 447                                 &key (epsilon 1d-3)
 448                                 (root-dir (user-homedir-pathname))
 449                                 aggregate-events)
 450   "Link images to GPS points; store both into their respective DB
 451 tables.  Images become linked to GPS points when their respective
 452 times differ by less than epsilon seconds, and when the respective
 453 events match.  dir-path is a (probably absolute) path to a directory
 454 that contains one set of measuring data.  root-dir must be equal for
 455 all pojects."
 456   ;; TODO: epsilon could be a range.  We would do a raw mapping by (a bigger) time epsilon and then take speed into account.
 457   (assert-phoros-db-major-version)
 458   (assert     ;not strictly necessary, but may save the user some time
 459    (select-dao 'sys-acquisition-project
 460                (:= 'common-table-name common-table-name))
 461    () "There is no acquisition project named ~A." common-table-name)
 462   (create-data-table-definitions common-table-name)
 463   (initialize-leap-seconds)
 464   (let* ((images
 465           (collect-pictures-directory-data dir-path))
 466          (estimated-time
 467           (loop
 468              for i across images
 469              unless (or (fake-trigger-time-p i)
 470                         (< (trigger-time i) *gps-epoch*))
 471              do (return (trigger-time i))))
 472          (gps-points
 473           (if aggregate-events
 474               (aggregate-gps-events (collect-gps-data dir-path estimated-time))
 475               (collect-gps-data dir-path estimated-time)))
 476          (gps-start-pointers (loop
 477                                 for i in gps-points
 478                                 collect (cons (car i) 0)))
 479          (mapped-image-counter (length images))
 480          (cartesian-system (assert-gps-points-sanity gps-points))
 481          (dir-below-root-dir
 482           (enough-namestring (string-right-trim "/\\ " dir-path) root-dir)))
 483     (cl-log:log-message
 484      :db-dat "I assume this measure was taken approximately ~A."
 485      (timestring (round estimated-time)))
 486     (loop
 487        for i across images
 488        for image-event-number = (or aggregate-events
 489                                     (device-event-number (recorded-device-id i)
 490                                                          estimated-time))
 491        for image-time = (trigger-time i)
 492        for matching-point =
 493          (when image-time               ; otherwise this image is junk
 494            (let ((gps-start-pointer
 495                   (cdr (assoc image-event-number gps-start-pointers
 496                               :test #'equal))))
 497              (assert gps-start-pointer ()
 498                      "Can't find an event number of ~S ~
 499                       (as suggested by the sys tables relevant to the ~
 500                       current image) among ~{~S~#^, ~} ~
 501                       (as derived from the names of the GPS event files).  ~
 502                       Consider using --aggregate-events if you can't ~
 503                       recitfy your data."
 504                      image-event-number (mapcar #'car gps-start-pointers))
 505              (loop
 506                 for gps-pointer from gps-start-pointer
 507                 for gps-point across (subseq (cdr (assoc image-event-number
 508                                                          gps-points
 509                                                          :test #'equal))
 510                                              gps-start-pointer)
 511                 when (almost= (gps-time gps-point) image-time epsilon)
 512                 do (setf (cdr (assoc image-event-number
 513                                      gps-start-pointers :test #'equal))
 514                          gps-pointer) ; remember index of last matching point
 515                 and return gps-point)))
 516        if matching-point
 517        do (let ((point-id               ; TODO: consider using transaction
 518                  (or (point-id matching-point) ; We've hit a point twice.
 519                      (sequence-next (point-id-sequence-name matching-point))))
 520                 (measurement-id (get-measurement-id common-table-name
 521                                                     dir-below-root-dir
 522                                                     cartesian-system)))
 523             (setf (point-id i) point-id
 524                   (point-id matching-point) point-id
 525                   (measurement-id matching-point) measurement-id
 526                   (measurement-id i) measurement-id
 527                   (trigger-time matching-point) image-time)
 528             (save-dao matching-point)
 529             (execute (:update (dao-table-name (class-of matching-point))
 530                               :set 'coordinates
 531                               (:st_geomfromewkt
 532                                (format nil "SRID=4326; POINT(~S ~S ~S)"
 533                                        (longitude matching-point)
 534                                        (latitude matching-point)
 535                                        (ellipsoid-height matching-point)))
 536                               :where (:= 'point-id (point-id matching-point))))
 537             (save-dao i))
 538        else do
 539          (decf mapped-image-counter)
 540          (cl-log:log-message
 541           :orphan
 542           "Couldn't map to any point: ~A~A, byte ~S. ~
 543            ~:[~; It didn't have a decent trigger time anyway.~]"
 544           dir-path (filename i) (image-byte-position i)
 545           (fake-trigger-time-p i)))
 546     (cl-log:log-message
 547      :db-dat
 548      "Tried to map ~D images to GPS points.  ~
 549       The attempt has been successful in ~:[~D~;all~] cases.~
 550       ~1@*~:[  See file orphans.log for details on the failures.~;~]"
 551      (length images) (= (length images) mapped-image-counter)
 552      mapped-image-counter)))
 553
 554 (defun assert-user-points-version (user-points-version)
 555   "Check if user-points-version is compatible with the current
 556 user-point table definition."
 557   (cond                ;insert more interesting clauses when necessary
 558     ((null user-points-version)
 559      (warn "Storing user-points which don't have a version number."))
 560     (t)))
 561
 562 (defun store-user-points (common-table-name json-file-path)
 563   "Store in DB user points given in file at json-file-path, which
 564 supposedly was created by Phoros.  Return number of points stored,
 565 number of points that were already in DB, and number of points found
 566 in JSON file."
 567   (assert-phoros-db-major-version)
 568   (let* ((user-point-table-name (user-point-table-name common-table-name))
 569          (raw-input (with-open-file (stream json-file-path)
 570                       (json:decode-json stream)))
 571          (raw-input-version (cdr (assoc :phoros-version raw-input)))
 572          (raw-features (cdr (assoc :features raw-input))))
 573     (assert-user-points-version raw-input-version)
 574     (loop
 575        for i in raw-features
 576        for coordinates = (cdr (assoc :coordinates (cdr (assoc :geometry i))))
 577        for point-form = (format nil "SRID=4326; POINT(~{~S ~})" coordinates)
 578        for properties = (cdr (assoc :properties i))
 579        for user-name = (cdr (assoc :user-name properties))
 580        for attribute = (cdr (assoc :attribute properties))
 581        for description = (cdr (assoc :description properties))
 582        for numeric-description = (cdr (assoc :numeric-description properties))
 583        for creation-date = (cdr (assoc :creation-date properties))
 584        for stdx-global = (cdr (assoc :stdx-global properties))
 585        for stdy-global = (cdr (assoc :stdy-global properties))
 586        for stdz-global = (cdr (assoc :stdz-global properties))
 587        for input-size = (cdr (assoc :input-size properties))
 588        for aux-numeric = (cdr (assoc :aux-numeric properties))
 589        for aux-text = (cdr (assoc :aux-text properties))
 590        for aux-numeric-comparison =
 591          (if aux-numeric
 592              (format nil "(~A = (CAST (ARRAY[~{~S~#^,~}] AS NUMERIC[])))"
 593                      (s-sql:to-sql-name 'aux-numeric) aux-numeric)
 594              (sql (:is-null 'aux-numeric)))
 595        for aux-text-comparison =
 596          (if aux-text
 597              (sql (:= 'aux-text (apply #'vector aux-text)))
 598              (sql (:is-null 'aux-text)))
 599        with points-stored = 0
 600        with points-already-in-db = 0
 601        sum 1 into points-tried
 602        do
 603          (if
 604           (query
 605            (:select
 606             t
 607             :from user-point-table-name :natural :left-join 'sys-user
 608             :where (:and (:st_equals 'coordinates
 609                                      (:st_geomfromewkt point-form))
 610                          (:= 'user-name user-name)
 611                          (:= 'attribute attribute)
 612                          (:= 'description description)
 613                          (:= 'numeric-description numeric-description)
 614                          (:= (:to-char 'creation-date
 615                                        *user-point-creation-date-format*)
 616                              creation-date)
 617                          (:= 'stdx-global stdx-global)
 618                          (:= 'stdy-global stdy-global)
 619                          (:= 'stdz-global stdz-global)
 620                          (:= 'input-size input-size)
 621                          (:raw aux-numeric-comparison)
 622                          (:raw aux-text-comparison))))
 623           (incf points-already-in-db)
 624           (progn
 625             (assert
 626              (= 1
 627                 (execute
 628                  (:insert-into user-point-table-name :set
 629                                'coordinates (:st_geomfromewkt point-form)
 630                                'user-id (:select 'user-id
 631                                                  :from 'sys-user
 632                                                  :where (:= 'user-name
 633                                                             user-name))
 634                                'attribute attribute
 635                                'description description
 636                                'numeric-description numeric-description
 637                                'creation-date creation-date
 638                                'stdx-global stdx-global
 639                                'stdy-global stdy-global
 640                                'stdz-global stdz-global
 641                                'input-size input-size
 642                                'aux-numeric (if aux-numeric
 643                                                 (apply #'vector aux-numeric)
 644                                                 :null)
 645                                'aux-text (if aux-text
 646                                              (apply #'vector aux-text)
 647                                              :null))))
 648              () "Point not stored.  This should not happen.")
 649             (incf points-stored)))
 650        finally (return (values points-stored
 651                                points-already-in-db
 652                                points-tried)))))
 653
 654 (defun* store-camera-hardware (&key
 655                                (try-overwrite t)
 656                                &mandatory-key
 657                                sensor-width-pix
 658                                sensor-height-pix
 659                                pix-size
 660                                channels
 661                                pix-depth
 662                                color-raiser
 663                                bayer-pattern
 664                                serial-number
 665                                description)
 666   "Store a new record in table sys-camera-hardware, or try updating an
 667 existing one.  Return camera-hardware-id of the altered record."
 668   (assert-phoros-db-major-version)
 669   (let ((record
 670          (or (when try-overwrite
 671                (car (select-dao 'sys-camera-hardware
 672                                 (:and (:= 'sensor-width-pix sensor-width-pix)
 673                                       (:= 'sensor-height-pix sensor-height-pix)
 674                                       (:= 'pix-size pix-size)
 675                                       (:= 'channels channels)
 676                                       (:= 'serial-number serial-number)
 677                                       (:= 'pix-depth pix-depth)))))
 678              (make-instance 'sys-camera-hardware :fetch-defaults t))))
 679     (with-slots ((sensor-width-pix-slot sensor-width-pix)
 680                  (sensor-height-pix-slot sensor-height-pix)
 681                  (pix-size-slot pix-size)
 682                  (channels-slot channels)
 683                  (pix-depth-slot pix-depth)
 684                  (color-raiser-slot color-raiser)
 685                  (bayer-pattern-slot bayer-pattern)
 686                  (serial-number-slot serial-number)
 687                  (description-slot description))
 688         record
 689       (setf sensor-width-pix-slot sensor-width-pix
 690             sensor-height-pix-slot sensor-height-pix
 691             pix-size-slot pix-size
 692             channels-slot channels
 693             pix-depth-slot pix-depth
 694             color-raiser-slot color-raiser
 695             bayer-pattern-slot bayer-pattern
 696             serial-number-slot serial-number
 697             description-slot description))
 698     (let ((new-row-p (save-dao record)))
 699       (cl-log:log-message
 700        :db-sys
 701        "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
 702        new-row-p (camera-hardware-id record)))
 703     (camera-hardware-id record)))
 704
 705 (defun* store-lens (&key (try-overwrite t)
 706                          &mandatory-key
 707                          c
 708                          serial-number
 709                          description)
 710   "Store a new record in table sys-lens, or try updating an existing
 711 one.  Return lens-id of the altered record."
 712   (assert-phoros-db-major-version)
 713   (let ((record
 714          (or (when try-overwrite
 715                (car (select-dao 'sys-lens
 716                                 (:and (:= 'c c)
 717                                       (:= 'serial-number serial-number)))))
 718              (make-instance 'sys-lens :fetch-defaults t))))
 719     (with-slots ((c-slot c)
 720                  (serial-number-slot serial-number)
 721                  (description-slot description))
 722         record
 723       (setf c-slot c
 724             serial-number-slot serial-number
 725             description-slot description))
 726     (let ((new-row-p (save-dao record)))
 727       (cl-log:log-message
 728        :db-sys "sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
 729        new-row-p (lens-id record)))
 730     (lens-id record)))
 731
 732 (defun store-generic-device
 733     (&key (camera-hardware-id :null) (lens-id :null) (scanner-id :null))
 734   "Store a new record in table sys-generic-device.  Return
 735 generic-device-id of the new record."
 736   (assert-phoros-db-major-version)
 737   (assert (notevery
 738            #'(lambda (x) (eq :null x))
 739            (list camera-hardware-id lens-id scanner-id))
 740           () "Generic device: not enough components.")
 741   (let ((record (make-instance 'sys-generic-device
 742                                :camera-hardware-id camera-hardware-id
 743                                :lens-id lens-id
 744                                :scanner-id scanner-id
 745                                :fetch-defaults t)))
 746     (let ((new-row-p (save-dao record)))
 747       (cl-log:log-message
 748        :db-sys
 749        "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
 750        new-row-p (generic-device-id record)))
 751     (generic-device-id record)))
 752
 753 (defun* store-device-stage-of-life (&key (unmounting-date :null)
 754                                    (try-overwrite t)
 755                                    &mandatory-key
 756                                    recorded-device-id
 757                                    event-number
 758                                    generic-device-id
 759                                    vehicle-name
 760                                    casing-name
 761                                    computer-name
 762                                    computer-interface-name
 763                                    mounting-date)
 764   "Store a new record in table sys-device-stage-of-life, or try
 765 updating an existing one.  Return device-stage-of-life-id of the
 766 altered record."
 767   (assert-phoros-db-major-version)
 768   (let ((record
 769          (or (when try-overwrite
 770                (car (select-dao
 771                      'sys-device-stage-of-life
 772                      (:and (:= 'recorded-device-id recorded-device-id)
 773                            (:= 'event-number event-number)
 774                            (:= 'generic-device-id generic-device-id)
 775                            (:= 'vehicle-name vehicle-name)
 776                            (:= 'mounting-date mounting-date)))))
 777              (make-instance 'sys-device-stage-of-life :fetch-defaults t))))
 778     (with-slots ((recorded-device-id-slot recorded-device-id)
 779                  (event-number-slot event-number)
 780                  (generic-device-id-slot generic-device-id)
 781                  (vehicle-name-slot vehicle-name)
 782                  (casing-name-slot casing-name)
 783                  (computer-name-slot computer-name)
 784                  (computer-interface-name-slot computer-interface-name)
 785                  (mounting-date-slot mounting-date)
 786                  (unmounting-date-slot unmounting-date))
 787         record
 788       (setf recorded-device-id-slot recorded-device-id
 789             event-number-slot event-number
 790             generic-device-id-slot generic-device-id
 791             vehicle-name-slot vehicle-name
 792             casing-name-slot casing-name
 793             computer-name-slot computer-name
 794             computer-interface-name-slot computer-interface-name
 795             mounting-date-slot mounting-date
 796             unmounting-date-slot unmounting-date))
 797     (let ((new-row-p (save-dao record)))
 798       (cl-log:log-message
 799        :db-sys
 800        "sys-device-stage-of-life: ~:[Updated~;Stored new~] device-stage-of-life-id ~A"
 801        new-row-p (device-stage-of-life-id record)))
 802     (device-stage-of-life-id record)))
 803
 804 (defun* store-device-stage-of-life-end (&mandatory-key device-stage-of-life-id
 805                                                        unmounting-date)
 806   "Update record in table sys-device-stage-of-life with an unmounting
 807 date.  Return device-stage-of-life-id of the altered record."
 808   (assert-phoros-db-major-version)
 809   (let ((record
 810          (get-dao 'sys-device-stage-of-life device-stage-of-life-id)))
 811     (with-slots ((unmounting-date-slot unmounting-date))
 812         record
 813       (setf unmounting-date-slot unmounting-date))
 814     (update-dao record)
 815     (device-stage-of-life-id record)))
 816
 817 (defun* store-camera-calibration (&mandatory-key
 818                                   device-stage-of-life-id
 819                                   date
 820                                   person
 821                                   main-description
 822                                   debug
 823                                   photogrammetry-version
 824                                   mounting-angle
 825                                   inner-orientation-description
 826                                   c
 827                                   xh
 828                                   yh
 829                                   a1
 830                                   a2
 831                                   a3
 832                                   b1
 833                                   b2
 834                                   c1
 835                                   c2
 836                                   r0
 837                                   outer-orientation-description
 838                                   dx
 839                                   dy
 840                                   dz
 841                                   omega
 842                                   phi
 843                                   kappa
 844                                   boresight-description
 845                                   b-dx
 846                                   b-dy
 847                                   b-dz
 848                                   b-ddx
 849                                   b-ddy
 850                                   b-ddz
 851                                   b-rotx
 852                                   b-roty
 853                                   b-rotz
 854                                   b-drotx
 855                                   b-droty
 856                                   b-drotz
 857                                   nx
 858                                   ny
 859                                   nz
 860                                   d)
 861   "Store a new record of camera-calibration in table
 862 sys-device-stage-of-life, or update an existing one.  Return
 863 device-stage-of-life-id and date of the altered record."
 864   (assert-phoros-db-major-version)
 865   (let ((record
 866          (or (car (select-dao
 867                    'sys-camera-calibration
 868                    (:and (:= 'device-stage-of-life-id device-stage-of-life-id)
 869                          (:= 'date date))))
 870              (make-instance 'sys-camera-calibration :fetch-defaults t))))
 871     (with-slots
 872           ((device-stage-of-life-id-slot device-stage-of-life-id)
 873            (date-slot date)
 874            (person-slot person)
 875            (main-description-slot main-description)
 876            (debug-slot debug)
 877            (photogrammetry-version-slot photogrammetry-version)
 878            (mounting-angle-slot mounting-angle)
 879            (inner-orientation-description-slot inner-orientation-description)
 880            (c-slot c)
 881            (xh-slot xh)
 882            (yh-slot yh)
 883            (a1-slot a1)
 884            (a2-slot a2)
 885            (a3-slot a3)
 886            (b1-slot b1)
 887            (b2-slot b2)
 888            (c1-slot c1)
 889            (c2-slot c2)
 890            (r0-slot r0)
 891            (outer-orientation-description-slot outer-orientation-description)
 892            (dx-slot dx)
 893            (dy-slot dy)
 894            (dz-slot dz)
 895            (omega-slot omega)
 896            (phi-slot phi)
 897            (kappa-slot kappa)
 898            (boresight-description-slot boresight-description)
 899            (b-dx-slot b-dx)
 900            (b-dy-slot b-dy)
 901            (b-dz-slot b-dz)
 902            (b-ddx-slot b-ddx)
 903            (b-ddy-slot b-ddy)
 904            (b-ddz-slot b-ddz)
 905            (b-rotx-slot b-rotx)
 906            (b-roty-slot b-roty)
 907            (b-rotz-slot b-rotz)
 908            (b-drotx-slot b-drotx)
 909            (b-droty-slot b-droty)
 910            (b-drotz-slot b-drotz)
 911            (nx-slot nx)
 912            (ny-slot ny)
 913            (nz-slot nz)
 914            (d-slot d))
 915         record
 916       (setf device-stage-of-life-id-slot device-stage-of-life-id
 917             date-slot date
 918             person-slot person
 919             main-description-slot main-description
 920             debug-slot debug
 921             photogrammetry-version-slot photogrammetry-version
 922             mounting-angle-slot mounting-angle
 923             inner-orientation-description-slot inner-orientation-description
 924             c-slot c
 925             xh-slot xh
 926             yh-slot yh
 927             a1-slot a1
 928             a2-slot a2
 929             a3-slot a3
 930             b1-slot b1
 931             b2-slot b2
 932             c1-slot c1
 933             c2-slot c2
 934             r0-slot r0
 935             outer-orientation-description-slot outer-orientation-description
 936             dx-slot dx
 937             dy-slot dy
 938             dz-slot dz
 939             omega-slot omega
 940             phi-slot phi
 941             kappa-slot kappa
 942             boresight-description-slot boresight-description
 943             b-dx-slot b-dx
 944             b-dy-slot b-dy
 945             b-dz-slot b-dz
 946             b-ddx-slot b-ddx
 947             b-ddy-slot b-ddy
 948             b-ddz-slot b-ddz
 949             b-rotx-slot b-rotx
 950             b-roty-slot b-roty
 951             b-rotz-slot b-rotz
 952             b-drotx-slot b-drotx
 953             b-droty-slot b-droty
 954             b-drotz-slot b-drotz
 955             nx-slot nx
 956             ny-slot ny
 957             nz-slot nz
 958             d-slot d))
 959     (let ((new-row-p (save-dao record)))
 960       (cl-log:log-message
 961        :db-sys
 962        "sys-camera-calibration: ~:[Updated~;Stored new~] record ~
 963         for ~A, device-stage-of-life-id ~A"
 964        new-row-p (date record) (device-stage-of-life-id record)))
 965     (values (device-stage-of-life-id record)
 966             (date record))))
 967
 968 #|
 969 (with-connection '("phoros-dev" "postgres" "passwd" "host")
 970   (nuke-all-tables)
 971   (create-acquisition-project "yyyy")
 972   (store-camera-hardware :sensor-width-pix 7000 :sensor-height-pix 800 :pix-size .003 :channels 3 :pix-depth 17 :color-raiser #(1 2 3) :bayer-pattern #(4 5 6) :serial-number "18" :description "yyy" :try-overwrite t)
 973   (store-lens :c 10.5 :serial-number "17.8.8" :description "blahBlah3" :try-overwrite nil)
 974   (store-generic-device :camera-hardware-id 1 :lens-id 1)
 975   (store-device-stage-of-life :recorded-device-id "1" :event-number "777" :generic-device-id 1 :vehicle-name "Auto" :casing-name "Vorn links" :computer-name "ccdheck" :computer-interface-name "eth0" :mounting-date "2010-01-30T07:00-1")
 976   (store-images-and-points "yyyy" "/home/bertb/phoros-testdata/mitsa-small/"))
 977 |#