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   (create-data-table-definitions common-table-name)
 459   (initialize-leap-seconds)
 460   (let* ((images
 461           (collect-pictures-directory-data dir-path))
 462          (estimated-time
 463           (loop
 464              for i across images
 465              unless (or (fake-trigger-time-p i)
 466                         (< (trigger-time i) *gps-epoch*))
 467              do (return (trigger-time i))))
 468          (gps-points
 469           (if aggregate-events
 470               (aggregate-gps-events (collect-gps-data dir-path estimated-time))
 471               (collect-gps-data dir-path estimated-time)))
 472          (gps-start-pointers (loop
 473                                 for i in gps-points
 474                                 collect (cons (car i) 0)))
 475          (dir-below-root-dir
 476           (enough-namestring (string-right-trim "/\\ " dir-path) root-dir))
 477          (mapped-image-counter (length images))
 478          (cartesian-system (assert-gps-points-sanity gps-points)))
 479     (cl-log:log-message
 480      :db-dat "I assume this measure was taken approximately ~A."
 481      (timestring (round estimated-time)))
 482     (loop
 483        for i across images
 484        for image-event-number = (or aggregate-events
 485                                     (device-event-number (recorded-device-id i)
 486                                                          estimated-time))
 487        for image-time = (trigger-time i)
 488        for matching-point =
 489          (when image-time               ; otherwise this image is junk
 490            (let ((gps-start-pointer
 491                   (cdr (assoc image-event-number gps-start-pointers
 492                               :test #'equal))))
 493              (assert gps-start-pointer ()
 494                      "Can't find an event number of ~S (as suggested by the sys tables relevant to the current image) among ~{~S~#^, ~} (as derived from the names of the GPS event files).  Consider using --aggregate-events if you can't recitfy your data."
 495                      image-event-number (mapcar #'car gps-start-pointers))
 496              (loop
 497                 for gps-pointer from gps-start-pointer
 498                 for gps-point across (subseq (cdr (assoc image-event-number
 499                                                          gps-points
 500                                                          :test #'equal))
 501                                              gps-start-pointer)
 502                 when (almost= (gps-time gps-point) image-time epsilon)
 503                 do (setf (cdr (assoc image-event-number
 504                                      gps-start-pointers :test #'equal))
 505                          gps-pointer) ; remember index of last matching point
 506                 and return gps-point)))
 507        if matching-point
 508        do (let ((point-id               ; TODO: consider using transaction
 509                  (or (point-id matching-point) ; We've hit a point twice.
 510                      (sequence-next (point-id-sequence-name matching-point))))
 511                 (measurement-id (get-measurement-id common-table-name
 512                                                     dir-below-root-dir cartesian-system)))
 513             (setf (point-id i) point-id
 514                   (point-id matching-point) point-id
 515                   (measurement-id matching-point) measurement-id
 516                   (measurement-id i) measurement-id
 517                   (trigger-time matching-point) image-time)
 518             (save-dao matching-point)
 519             (execute (:update (dao-table-name (class-of matching-point))
 520                               :set 'coordinates
 521                               (:st_geomfromewkt
 522                                (format nil "SRID=4326; POINT(~S ~S ~S)"
 523                                        (longitude matching-point)
 524                                        (latitude matching-point)
 525                                        (ellipsoid-height matching-point)))
 526                               :where (:= 'point-id (point-id matching-point))))
 527             (save-dao i))
 528        else do
 529          (decf mapped-image-counter)
 530          (cl-log:log-message
 531           :orphan
 532           "Couldn't map to any point: ~A~A, byte ~S. ~:[~; It didn't have a decent trigger time anyway.~]"
 533           dir-path (filename i) (image-byte-position i) (fake-trigger-time-p i)))
 534     (cl-log:log-message
 535      :db-dat
 536      "Tried to map ~D images to GPS points.  The attempt has been successful in ~:[~D~;all~] cases.~1@*~:[  See file orphans.log for details on the failures.~;~]"
 537      (length images) (= (length images) mapped-image-counter)
 538      mapped-image-counter)))
 539
 540 (defun store-camera-hardware
 541     (&key (sensor-width-pix (error "sensor-width-pix needed."))
 542      (sensor-height-pix (error "sensor-height-pix needed."))
 543      (pix-size (error "pix-size needed."))
 544      (channels (error "channels needed."))
 545      (pix-depth (error "pix-depth needed."))
 546      (color-raiser (error "color-raiser needed."))
 547      (bayer-pattern (error "bayer-pattern needed."))
 548      (serial-number (error "serial-number needed."))
 549      (description (error "description needed."))
 550      (try-overwrite t))
 551   "Store a new record in table sys-camera-hardware, or try updating an
 552 existing one.  Return camera-hardware-id of the altered record."
 553   (assert-phoros-db-major-version)
 554   (let ((record
 555          (or (when try-overwrite
 556                (car (select-dao 'sys-camera-hardware
 557                                 (:and (:= 'sensor-width-pix sensor-width-pix)
 558                                       (:= 'sensor-height-pix sensor-height-pix)
 559                                       (:= 'pix-size pix-size)
 560                                       (:= 'channels channels)
 561                                       (:= 'serial-number serial-number)
 562                                       (:= 'pix-depth pix-depth)))))
 563              (make-instance 'sys-camera-hardware :fetch-defaults t))))
 564     (with-slots ((sensor-width-pix-slot sensor-width-pix)
 565                  (sensor-height-pix-slot sensor-height-pix)
 566                  (pix-size-slot pix-size)
 567                  (channels-slot channels)
 568                  (pix-depth-slot pix-depth)
 569                  (color-raiser-slot color-raiser)
 570                  (bayer-pattern-slot bayer-pattern)
 571                  (serial-number-slot serial-number)
 572                  (description-slot description))
 573         record
 574       (setf sensor-width-pix-slot sensor-width-pix
 575             sensor-height-pix-slot sensor-height-pix
 576             pix-size-slot pix-size
 577             channels-slot channels
 578             pix-depth-slot pix-depth
 579             color-raiser-slot color-raiser
 580             bayer-pattern-slot bayer-pattern
 581             serial-number-slot serial-number
 582             description-slot description))
 583     (let ((new-row-p (save-dao record)))
 584       (cl-log:log-message
 585        :db-sys
 586        "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
 587        new-row-p (camera-hardware-id record)))
 588     (camera-hardware-id record)))
 589
 590 (defun store-lens
 591     (&key (c (error "c needed."))
 592      (serial-number (error "serial-number needed."))
 593      (description (error "description needed."))
 594      (try-overwrite t))
 595   "Store a new record in table sys-lens, or try updating an existing
 596 one.  Return lens-id of the altered record."
 597   (assert-phoros-db-major-version)
 598   (let ((record
 599          (or (when try-overwrite
 600                (car (select-dao 'sys-lens
 601                                 (:and (:= 'c c)
 602                                       (:= 'serial-number serial-number)))))
 603              (make-instance 'sys-lens :fetch-defaults t))))
 604     (with-slots ((c-slot c)
 605                  (serial-number-slot serial-number)
 606                  (description-slot description))
 607         record
 608       (setf c-slot c
 609             serial-number-slot serial-number
 610             description-slot description))
 611     (let ((new-row-p (save-dao record)))
 612       (cl-log:log-message
 613        :db-sys "sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
 614        new-row-p (lens-id record)))
 615     (lens-id record)))
 616
 617 (defun store-generic-device
 618     (&key (camera-hardware-id :null) (lens-id :null) (scanner-id :null))
 619   "Store a new record in table sys-generic-device.  Return
 620 generic-device-id of the new record."
 621   (assert-phoros-db-major-version)
 622   (assert (notevery
 623            #'(lambda (x) (eq :null x))
 624            (list camera-hardware-id lens-id scanner-id))
 625           () "Generic device: not enough components.")
 626   (let ((record (make-instance 'sys-generic-device
 627                                :camera-hardware-id camera-hardware-id
 628                                :lens-id lens-id
 629                                :scanner-id scanner-id
 630                                :fetch-defaults t)))
 631     (let ((new-row-p (save-dao record)))
 632       (cl-log:log-message
 633        :db-sys
 634        "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
 635        new-row-p (generic-device-id record)))
 636     (generic-device-id record)))
 637
 638 (defun store-device-stage-of-life
 639     (&key (recorded-device-id (error "recorded-device-id needed."))
 640      (event-number (error "event-number needed."))
 641      (generic-device-id (error "generic-device-id needed."))
 642      (vehicle-name (error "vehicle-name needed."))
 643      (casing-name (error "casing-name needed."))
 644      (computer-name (error "computer-name needed."))
 645      (computer-interface-name (error "computer-interface-name needed."))
 646      (mounting-date (error "mounting-date needed."))
 647      (unmounting-date :null)
 648      (try-overwrite t))
 649   "Store a new record in table sys-device-stage-of-life, or try
 650 updating an existing one.  Return device-stage-of-life-id of the
 651 altered record."
 652   (assert-phoros-db-major-version)
 653   (let ((record
 654          (or (when try-overwrite
 655                (car (select-dao
 656                      'sys-device-stage-of-life
 657                      (:and (:= 'recorded-device-id recorded-device-id)
 658                            (:= 'event-number event-number)
 659                            (:= 'generic-device-id generic-device-id)
 660                            (:= 'vehicle-name vehicle-name)
 661                            (:= 'mounting-date mounting-date)))))
 662              (make-instance 'sys-device-stage-of-life :fetch-defaults t))))
 663     (with-slots ((recorded-device-id-slot recorded-device-id)
 664                  (event-number-slot event-number)
 665                  (generic-device-id-slot generic-device-id)
 666                  (vehicle-name-slot vehicle-name)
 667                  (casing-name-slot casing-name)
 668                  (computer-name-slot computer-name)
 669                  (computer-interface-name-slot computer-interface-name)
 670                  (mounting-date-slot mounting-date)
 671                  (unmounting-date-slot unmounting-date))
 672         record
 673       (setf recorded-device-id-slot recorded-device-id
 674             event-number-slot event-number
 675             generic-device-id-slot generic-device-id
 676             vehicle-name-slot vehicle-name
 677             casing-name-slot casing-name
 678             computer-name-slot computer-name
 679             computer-interface-name-slot computer-interface-name
 680             mounting-date-slot mounting-date
 681             unmounting-date-slot unmounting-date))
 682     (let ((new-row-p (save-dao record)))
 683       (cl-log:log-message
 684        :db-sys
 685        "sys-device-stage-of-life: ~:[Updated~;Stored new~] device-stage-of-life-id ~A"
 686        new-row-p (device-stage-of-life-id record)))
 687     (device-stage-of-life-id record)))
 688
 689 (defun store-device-stage-of-life-end
 690     (&key (device-stage-of-life-id (error "device-stage-of-life-id needed."))
 691      (unmounting-date (error "unmounting-date needed.")))
 692   "Update record in table sys-device-stage-of-life with an unmounting
 693 date.  Return device-stage-of-life-id of the altered record."
 694   (assert-phoros-db-major-version)
 695   (let ((record
 696          (get-dao 'sys-device-stage-of-life device-stage-of-life-id)))
 697     (with-slots ((unmounting-date-slot unmounting-date))
 698         record
 699       (setf unmounting-date-slot unmounting-date))
 700     (update-dao record)
 701     (device-stage-of-life-id record)))
 702
 703 (defun store-camera-calibration
 704     (&key
 705      (device-stage-of-life-id (error "device-stage-of-life-id needed."))
 706      (date (error "date needed."))
 707      (person (error "person needed."))
 708      (main-description (error "main-description needed."))
 709      (debug (error "debug needed."))
 710      (photogrammetry-version (error "photogrammetry-version needed."))
 711      (mounting-angle (error "mounting-angle needed."))
 712      (inner-orientation-description (error "inner-orientation-description needed."))
 713      (c (error "c needed."))
 714      (xh (error "xh needed."))
 715      (yh (error "yh needed."))
 716      (a1 (error "a1 needed."))
 717      (a2 (error "a2 needed."))
 718      (a3 (error "a3 needed."))
 719      (b1 (error "b1 needed."))
 720      (b2 (error "b2 needed."))
 721      (c1 (error "c1 needed."))
 722      (c2 (error "c2 needed."))
 723      (r0 (error "r0 needed."))
 724      (outer-orientation-description (error "outer-orientation-description needed."))
 725      (dx (error "dx needed."))
 726      (dy (error "dy needed."))
 727      (dz (error "dz needed."))
 728      (omega (error "omega needed."))
 729      (phi (error "phi needed."))
 730      (kappa (error "kappa needed."))
 731      (boresight-description (error "boresight-description needed."))
 732      (b-dx (error "b-dx needed."))
 733      (b-dy (error "b-dy needed."))
 734      (b-dz (error "b-dz needed."))
 735      (b-ddx (error "b-ddx needed."))
 736      (b-ddy (error "b-ddy needed."))
 737      (b-ddz (error "b-ddz needed."))
 738      (b-rotx (error "b-rotx needed."))
 739      (b-roty (error "b-roty needed."))
 740      (b-rotz (error "b-rotz needed."))
 741      (b-drotx (error "b-drotx needed."))
 742      (b-droty (error "b-droty needed."))
 743      (b-drotz (error "b-drotz needed."))
 744      (nx (error "nx needed."))
 745      (ny (error "ny needed."))
 746      (nz (error "nz needed."))
 747      (d (error "d needed.")))
 748   "Store a new record of camera-calibration in table
 749 sys-device-stage-of-life, or update an existing one.  Return
 750 device-stage-of-life-id and date of the altered record."
 751   (assert-phoros-db-major-version)
 752   (let ((record
 753          (or (car (select-dao
 754                    'sys-camera-calibration
 755                    (:and (:= 'device-stage-of-life-id device-stage-of-life-id)
 756                          (:= 'date date))))
 757              (make-instance 'sys-camera-calibration :fetch-defaults t))))
 758     (with-slots
 759           ((device-stage-of-life-id-slot device-stage-of-life-id)
 760            (date-slot date)
 761            (person-slot person)
 762            (main-description-slot main-description)
 763            (debug-slot debug)
 764            (photogrammetry-version-slot photogrammetry-version)
 765            (mounting-angle-slot mounting-angle)
 766            (inner-orientation-description-slot inner-orientation-description)
 767            (c-slot c)
 768            (xh-slot xh)
 769            (yh-slot yh)
 770            (a1-slot a1)
 771            (a2-slot a2)
 772            (a3-slot a3)
 773            (b1-slot b1)
 774            (b2-slot b2)
 775            (c1-slot c1)
 776            (c2-slot c2)
 777            (r0-slot r0)
 778            (outer-orientation-description-slot outer-orientation-description)
 779            (dx-slot dx)
 780            (dy-slot dy)
 781            (dz-slot dz)
 782            (omega-slot omega)
 783            (phi-slot phi)
 784            (kappa-slot kappa)
 785            (boresight-description-slot boresight-description)
 786            (b-dx-slot b-dx)
 787            (b-dy-slot b-dy)
 788            (b-dz-slot b-dz)
 789            (b-ddx-slot b-ddx)
 790            (b-ddy-slot b-ddy)
 791            (b-ddz-slot b-ddz)
 792            (b-rotx-slot b-rotx)
 793            (b-roty-slot b-roty)
 794            (b-rotz-slot b-rotz)
 795            (b-drotx-slot b-drotx)
 796            (b-droty-slot b-droty)
 797            (b-drotz-slot b-drotz)
 798            (nx-slot nx)
 799            (ny-slot ny)
 800            (nz-slot nz)
 801            (d-slot d))
 802         record
 803       (setf device-stage-of-life-id-slot device-stage-of-life-id
 804             date-slot date
 805             person-slot person
 806             main-description-slot main-description
 807             debug-slot debug
 808             photogrammetry-version-slot photogrammetry-version
 809             mounting-angle-slot mounting-angle
 810             inner-orientation-description-slot inner-orientation-description
 811             c-slot c
 812             xh-slot xh
 813             yh-slot yh
 814             a1-slot a1
 815             a2-slot a2
 816             a3-slot a3
 817             b1-slot b1
 818             b2-slot b2
 819             c1-slot c1
 820             c2-slot c2
 821             r0-slot r0
 822             outer-orientation-description-slot outer-orientation-description
 823             dx-slot dx
 824             dy-slot dy
 825             dz-slot dz
 826             omega-slot omega
 827             phi-slot phi
 828             kappa-slot kappa
 829             boresight-description-slot boresight-description
 830             b-dx-slot b-dx
 831             b-dy-slot b-dy
 832             b-dz-slot b-dz
 833             b-ddx-slot b-ddx
 834             b-ddy-slot b-ddy
 835             b-ddz-slot b-ddz
 836             b-rotx-slot b-rotx
 837             b-roty-slot b-roty
 838             b-rotz-slot b-rotz
 839             b-drotx-slot b-drotx
 840             b-droty-slot b-droty
 841             b-drotz-slot b-drotz
 842             nx-slot nx
 843             ny-slot ny
 844             nz-slot nz
 845             d-slot d))
 846     (let ((new-row-p (save-dao record)))
 847       (cl-log:log-message
 848        :db-sys
 849        "sys-camera-calibration: ~:[Updated~;Stored new~] record for ~A, device-stage-of-life-id ~A"
 850        new-row-p (date record) (device-stage-of-life-id record)))
 851     (values (device-stage-of-life-id record)
 852             (date record))))
 853
 854 #|
 855 (with-connection '("phoros-dev" "postgres" "passwd" "host")
 856   (nuke-all-tables)
 857   (create-acquisition-project "yyyy")
 858   (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)
 859   (store-lens :c 10.5 :serial-number "17.8.8" :description "blahBlah3" :try-overwrite nil)
 860   (store-generic-device :camera-hardware-id 1 :lens-id 1)
 861   (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")
 862   (store-images-and-points "yyyy" "/home/bertb/phoros-testdata/mitsa-small/"))
 863 |#