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   (setf *random-state* (make-random-state t))
 463   (create-data-table-definitions common-table-name)
 464   (initialize-leap-seconds)
 465   (let* ((images
 466           (collect-pictures-directory-data dir-path))
 467          (estimated-time
 468           (loop
 469              for i across images
 470              unless (or (fake-trigger-time-p i)
 471                         (< (trigger-time i) *gps-epoch*))
 472              do (return (trigger-time i))))
 473          (gps-points
 474           (if aggregate-events
 475               (aggregate-gps-events (collect-gps-data dir-path estimated-time))
 476               (collect-gps-data dir-path estimated-time)))
 477          (gps-start-pointers (loop
 478                                 for i in gps-points
 479                                 collect (cons (car i) 0)))
 480          (mapped-image-counter (length images))
 481          (cartesian-system (assert-gps-points-sanity gps-points))
 482          (dir-below-root-dir
 483           (enough-namestring (string-right-trim "/\\ " dir-path) root-dir)))
 484     (cl-log:log-message
 485      :db-dat "I assume this measure was taken approximately ~A."
 486      (timestring (round estimated-time)))
 487     (loop
 488        for i across images
 489        for image-event-number = (or aggregate-events
 490                                     (device-event-number (recorded-device-id i)
 491                                                          estimated-time))
 492        for image-time = (trigger-time i)
 493        for matching-point =
 494          (when image-time               ; otherwise this image is junk
 495            (let ((gps-start-pointer
 496                   (cdr (assoc image-event-number gps-start-pointers
 497                               :test #'equal))))
 498              (assert gps-start-pointer ()
 499                      "Can't find an event number of ~S ~
 500                       (as suggested by the sys tables relevant to the ~
 501                       current image) among ~{~S~#^, ~} ~
 502                       (as derived from the names of the GPS event files).  ~
 503                       Consider using --aggregate-events if you can't ~
 504                       recitfy your data."
 505                      image-event-number (mapcar #'car gps-start-pointers))
 506              (loop
 507                 for gps-pointer from gps-start-pointer
 508                 for gps-point across (subseq (cdr (assoc image-event-number
 509                                                          gps-points
 510                                                          :test #'equal))
 511                                              gps-start-pointer)
 512                 when (almost= (gps-time gps-point) image-time epsilon)
 513                 do (setf (cdr (assoc image-event-number
 514                                      gps-start-pointers :test #'equal))
 515                          gps-pointer) ; remember index of last matching point
 516                 and return gps-point)))
 517        if matching-point
 518        do (let ((point-id               ; TODO: consider using transaction
 519                  (or (point-id matching-point) ; We've hit a point twice.
 520                      (sequence-next (point-id-sequence-name matching-point))))
 521                 (measurement-id (get-measurement-id common-table-name
 522                                                     dir-below-root-dir
 523                                                     cartesian-system)))
 524             (setf (point-id i) point-id
 525                   (point-id matching-point) point-id
 526                   (measurement-id matching-point) measurement-id
 527                   (measurement-id i) measurement-id
 528                   (trigger-time matching-point) image-time)
 529             (save-dao matching-point)
 530             (execute (:update (dao-table-name (class-of matching-point))
 531                               :set 'coordinates
 532                               (:st_geomfromewkt
 533                                (format nil "SRID=4326; POINT(~S ~S ~S)"
 534                                        (longitude matching-point)
 535                                        (latitude matching-point)
 536                                        (ellipsoid-height matching-point)))
 537                               :where (:= 'point-id (point-id matching-point))))
 538             (save-dao i))
 539        else do
 540          (decf mapped-image-counter)
 541          (cl-log:log-message
 542           :orphan
 543           "Couldn't map to any point: ~A~A, byte ~S. ~
 544            ~:[~; It didn't have a decent trigger time anyway.~]"
 545           dir-path (filename i) (image-byte-position i)
 546           (fake-trigger-time-p i)))
 547     (cl-log:log-message
 548      :db-dat
 549      "Tried to map ~D images to GPS points.  ~
 550       The attempt has been successful in ~:[~D~;all~] cases.~
 551       ~1@*~:[  See file ~3@*~A for details on the failures.~;~]"
 552      (length images)
 553      (= (length images) mapped-image-counter)
 554      mapped-image-counter
 555      (truename
 556       (cl-log:text-file-messenger-file (cl-log:find-messenger :orphan))))))
 557
 558 (defun assert-user-points-version (user-points-version)
 559   "Check if user-points-version is compatible with the current
 560 user-point table definition."
 561   (cond                ;insert more interesting clauses when necessary
 562     ((null user-points-version)
 563      (warn "Storing user-points which don't have a version number."))
 564     (t)))
 565
 566 (defun* store-user-points (common-table-name &mandatory-key json-file)
 567   "Store in DB user points given in file at json-file, which
 568 supposedly was created by Phoros.  Return number of points stored,
 569 number of points that were already in DB, and number of points found
 570 in JSON file."
 571   (assert-phoros-db-major-version)
 572   (let* ((user-point-table-name (user-point-table-name common-table-name))
 573          (raw-input (with-open-file (stream json-file)
 574                       (json:decode-json stream)))
 575          (raw-input-version (cdr (assoc :phoros-version raw-input)))
 576          (raw-features (cdr (assoc :features raw-input))))
 577     (assert-user-points-version raw-input-version)
 578     (loop
 579        for i in raw-features
 580        for coordinates = (cdr (assoc :coordinates (cdr (assoc :geometry i))))
 581        for point-form = (format nil "SRID=4326; POINT(~{~S ~})" coordinates)
 582        for properties = (cdr (assoc :properties i))
 583        for user-name = (cdr (assoc :user-name properties))
 584        for attribute = (cdr (assoc :attribute properties))
 585        for description = (cdr (assoc :description properties))
 586        for numeric-description = (cdr (assoc :numeric-description properties))
 587        for creation-date = (cdr (assoc :creation-date properties))
 588        for stdx-global = (cdr (assoc :stdx-global properties))
 589        for stdy-global = (cdr (assoc :stdy-global properties))
 590        for stdz-global = (cdr (assoc :stdz-global properties))
 591        for input-size = (cdr (assoc :input-size properties))
 592        for aux-numeric = (cdr (assoc :aux-numeric properties))
 593        for aux-text = (cdr (assoc :aux-text properties))
 594        for aux-numeric-comparison =
 595          (if aux-numeric
 596              (format nil "(~A = (CAST (ARRAY[~{~S~#^,~}] AS NUMERIC[])))"
 597                      (s-sql:to-sql-name 'aux-numeric) aux-numeric)
 598              (sql (:is-null 'aux-numeric)))
 599        for aux-text-comparison =
 600          (if aux-text
 601              (sql (:= 'aux-text (apply #'vector aux-text)))
 602              (sql (:is-null 'aux-text)))
 603        with points-stored = 0
 604        with points-already-in-db = 0
 605        sum 1 into points-tried
 606        do
 607          (if
 608           (query
 609            (:select
 610             t
 611             :from user-point-table-name :natural :left-join 'sys-user
 612             :where (:and (:st_equals 'coordinates
 613                                      (:st_geomfromewkt point-form))
 614                          (:= 'user-name user-name)
 615                          (:= 'attribute attribute)
 616                          (:= 'description description)
 617                          (:= 'numeric-description numeric-description)
 618                          (:= (:to-char 'creation-date
 619                                        *user-point-creation-date-format*)
 620                              creation-date)
 621                          (:= 'stdx-global stdx-global)
 622                          (:= 'stdy-global stdy-global)
 623                          (:= 'stdz-global stdz-global)
 624                          (:= 'input-size input-size)
 625                          (:raw aux-numeric-comparison)
 626                          (:raw aux-text-comparison))))
 627           (incf points-already-in-db)
 628           (progn
 629             (assert
 630              (= 1
 631                 (execute
 632                  (:insert-into user-point-table-name :set
 633                                'coordinates (:st_geomfromewkt point-form)
 634                                'user-id (:select 'user-id
 635                                                  :from 'sys-user
 636                                                  :where (:= 'user-name
 637                                                             user-name))
 638                                'attribute attribute
 639                                'description description
 640                                'numeric-description numeric-description
 641                                'creation-date creation-date
 642                                'stdx-global stdx-global
 643                                'stdy-global stdy-global
 644                                'stdz-global stdz-global
 645                                'input-size input-size
 646                                'aux-numeric (if aux-numeric
 647                                                 (apply #'vector aux-numeric)
 648                                                 :null)
 649                                'aux-text (if aux-text
 650                                              (apply #'vector aux-text)
 651                                              :null))))
 652              () "Point not stored.  This should not happen.")
 653             (incf points-stored)))
 654        finally (return (values points-stored
 655                                points-already-in-db
 656                                points-tried)))))
 657
 658 (defun update-footprint (common-table-name
 659                          measurement-id filename byte-position)
 660   "Update footprint of an image."
 661   (let* ((aggregate-view-name
 662           (aggregate-view-name common-table-name))
 663          (raw-footprint
 664           (photogrammetry
 665            :footprint
 666            ;; KLUDGE: translate keys, e.g. a1 -> a_1
 667            (json:decode-json-from-string
 668             (json:encode-json-to-string
 669              (query (:select '*
 670                              :from aggregate-view-name
 671                              :where (:and (:= 'measurement-id measurement-id)
 672                                           (:= 'filename filename)
 673                                           (:= 'byte-position byte-position)))
 674                     :alist)))))
 675          (ewkt-footprint
 676           (format nil "SRID=4326; POLYGON((~{~{~A~#^ ~}~#^, ~}))"
 677                   (cdr (assoc :footprint raw-footprint)))))
 678     (execute
 679      (:update aggregate-view-name :set
 680               'footprint (:st_geomfromewkt ewkt-footprint)
 681               :where (:and (:= 'measurement-id measurement-id)
 682                            (:= 'filename filename)
 683                            (:= 'byte-position byte-position))))))
 684
 685 (defun insert-footprints (common-table-name)
 686   "Give images of acquisition project common-table-name that don't
 687 have up-to-date footprints fresh footprints."
 688   (let* ((aggregate-view-name
 689           (aggregate-view-name common-table-name))
 690          (image-records
 691           (query (:select 'measurement-id 'filename 'byte-position
 692                           :from aggregate-view-name
 693                           :where (:and
 694                                   (:or
 695                                    (:is-null 'footprint)
 696                                        (:!= 'footprint-device-stage-of-life-id
 697                                             'device-stage-of-life-id))
 698                                        'usable)))))
 699     (loop
 700        for (measurement-id filename byte-position) in image-records
 701        sum (update-footprint
 702             common-table-name measurement-id filename byte-position))))
 703
 704 (defun insert-all-footprints (postgresql-credentials)
 705   "Asynchronously update image footprints of all acquisition projects
 706 where necessarcy."
 707   (let ((common-table-names
 708          (with-connection postgresql-credentials
 709            (query (:select 'common-table-name
 710                            :from 'sys-acquisition-project)
 711                   :list))))
 712     (setf bt:*default-special-bindings*
 713           (acons '*insert-footprints-postgresql-credentials*
 714                  `(list ,@postgresql-credentials)
 715                  nil))
 716     (dolist (common-table-name common-table-names)
 717       (bt:make-thread
 718        #'(lambda ()
 719            (declare (special *insert-footprints-postgresql-credentials*))
 720            (with-connection *insert-footprints-postgresql-credentials*
 721              (insert-footprints common-table-name)))
 722        :name "insert-all-footprints"))))
 723
 724 (defun delete-imageless-points (common-table-name)
 725   "Delete from acquisition project common-table-name points that have
 726 no images."
 727   (let* ((point-data-table-name (point-data-table-name common-table-name))
 728          (image-data-table-name (image-data-table-name common-table-name)))
 729     (execute
 730      (:delete-from point-data-table-name
 731                    :where (:not
 732                            (:exists
 733                             (:select (:dot image-data-table-name 'point-id)
 734                                      :from image-data-table-name
 735                                      :where (:= (:dot image-data-table-name
 736                                                       'point-id)
 737                                                 (:dot point-data-table-name
 738                                                       'point-id)))))))))
 739
 740 (defun delete-all-imageless-points (postgresql-credentials)
 741   "Asynchronously delete imageless footprints of all acquisition
 742 projects."
 743   (let ((common-table-names
 744          (with-connection postgresql-credentials
 745            (query (:select 'common-table-name
 746                            :from 'sys-acquisition-project)
 747                   :list))))
 748     (setf bt:*default-special-bindings*
 749           (acons '*delete-imageless-points-postgresql-credentials*
 750                  `(list ,@postgresql-credentials)
 751                  nil))
 752     (dolist (common-table-name common-table-names)
 753       (bt:make-thread
 754        #'(lambda ()
 755            (declare (special *delete-imageless-points-postgresql-credentials*))
 756            (with-connection *delete-imageless-points-postgresql-credentials*
 757              (delete-imageless-points common-table-name)))
 758        :name "delete-all-imageless-points"))))
 759
 760 (defun* store-camera-hardware (&key
 761                                (try-overwrite t)
 762                                &mandatory-key
 763                                sensor-width-pix
 764                                sensor-height-pix
 765                                pix-size
 766                                channels
 767                                pix-depth
 768                                color-raiser
 769                                bayer-pattern
 770                                serial-number
 771                                description)
 772   "Store a new record in table sys-camera-hardware, or try updating an
 773 existing one.  Return camera-hardware-id of the altered record."
 774   (assert-phoros-db-major-version)
 775   (let ((record
 776          (or (when try-overwrite
 777                (car (select-dao 'sys-camera-hardware
 778                                 (:and (:= 'sensor-width-pix sensor-width-pix)
 779                                       (:= 'sensor-height-pix sensor-height-pix)
 780                                       (:= 'pix-size pix-size)
 781                                       (:= 'channels channels)
 782                                       (:= 'serial-number serial-number)
 783                                       (:= 'pix-depth pix-depth)))))
 784              (make-instance 'sys-camera-hardware :fetch-defaults t))))
 785     (with-slots ((sensor-width-pix-slot sensor-width-pix)
 786                  (sensor-height-pix-slot sensor-height-pix)
 787                  (pix-size-slot pix-size)
 788                  (channels-slot channels)
 789                  (pix-depth-slot pix-depth)
 790                  (color-raiser-slot color-raiser)
 791                  (bayer-pattern-slot bayer-pattern)
 792                  (serial-number-slot serial-number)
 793                  (description-slot description))
 794         record
 795       (setf sensor-width-pix-slot sensor-width-pix
 796             sensor-height-pix-slot sensor-height-pix
 797             pix-size-slot pix-size
 798             channels-slot channels
 799             pix-depth-slot pix-depth
 800             color-raiser-slot color-raiser
 801             bayer-pattern-slot bayer-pattern
 802             serial-number-slot serial-number
 803             description-slot description))
 804     (let ((new-row-p (save-dao record)))
 805       (cl-log:log-message
 806        :db-sys
 807        "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
 808        new-row-p (camera-hardware-id record)))
 809     (camera-hardware-id record)))
 810
 811 (defun* store-lens (&key (try-overwrite t)
 812                          &mandatory-key
 813                          c
 814                          serial-number
 815                          description)
 816   "Store a new record in table sys-lens, or try updating an existing
 817 one.  Return lens-id of the altered record."
 818   (assert-phoros-db-major-version)
 819   (let ((record
 820          (or (when try-overwrite
 821                (car (select-dao 'sys-lens
 822                                 (:and (:= 'c c)
 823                                       (:= 'serial-number serial-number)))))
 824              (make-instance 'sys-lens :fetch-defaults t))))
 825     (with-slots ((c-slot c)
 826                  (serial-number-slot serial-number)
 827                  (description-slot description))
 828         record
 829       (setf c-slot c
 830             serial-number-slot serial-number
 831             description-slot description))
 832     (let ((new-row-p (save-dao record)))
 833       (cl-log:log-message
 834        :db-sys "sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
 835        new-row-p (lens-id record)))
 836     (lens-id record)))
 837
 838 (defun store-generic-device
 839     (&key (camera-hardware-id :null) (lens-id :null) (scanner-id :null))
 840   "Store a new record in table sys-generic-device.  Return
 841 generic-device-id of the new record."
 842   (assert-phoros-db-major-version)
 843   (assert (notevery
 844            #'(lambda (x) (eq :null x))
 845            (list camera-hardware-id lens-id scanner-id))
 846           () "Generic device: not enough components.")
 847   (let ((record (make-instance 'sys-generic-device
 848                                :camera-hardware-id camera-hardware-id
 849                                :lens-id lens-id
 850                                :scanner-id scanner-id
 851                                :fetch-defaults t)))
 852     (let ((new-row-p (save-dao record)))
 853       (cl-log:log-message
 854        :db-sys
 855        "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
 856        new-row-p (generic-device-id record)))
 857     (generic-device-id record)))
 858
 859 (defun* store-device-stage-of-life (&key (unmounting-date :null)
 860                                    (try-overwrite t)
 861                                    &mandatory-key
 862                                    recorded-device-id
 863                                    event-number
 864                                    generic-device-id
 865                                    vehicle-name
 866                                    casing-name
 867                                    computer-name
 868                                    computer-interface-name
 869                                    mounting-date)
 870   "Store a new record in table sys-device-stage-of-life, or try
 871 updating an existing one.  Return device-stage-of-life-id of the
 872 altered record."
 873   (assert-phoros-db-major-version)
 874   (let ((record
 875          (or (when try-overwrite
 876                (car (select-dao
 877                      'sys-device-stage-of-life
 878                      (:and (:= 'recorded-device-id recorded-device-id)
 879                            (:= 'event-number event-number)
 880                            (:= 'generic-device-id generic-device-id)
 881                            (:= 'vehicle-name vehicle-name)
 882                            (:= 'mounting-date mounting-date)))))
 883              (make-instance 'sys-device-stage-of-life :fetch-defaults t))))
 884     (with-slots ((recorded-device-id-slot recorded-device-id)
 885                  (event-number-slot event-number)
 886                  (generic-device-id-slot generic-device-id)
 887                  (vehicle-name-slot vehicle-name)
 888                  (casing-name-slot casing-name)
 889                  (computer-name-slot computer-name)
 890                  (computer-interface-name-slot computer-interface-name)
 891                  (mounting-date-slot mounting-date)
 892                  (unmounting-date-slot unmounting-date))
 893         record
 894       (setf recorded-device-id-slot recorded-device-id
 895             event-number-slot event-number
 896             generic-device-id-slot generic-device-id
 897             vehicle-name-slot vehicle-name
 898             casing-name-slot casing-name
 899             computer-name-slot computer-name
 900             computer-interface-name-slot computer-interface-name
 901             mounting-date-slot mounting-date
 902             unmounting-date-slot unmounting-date))
 903     (let ((new-row-p (save-dao record)))
 904       (cl-log:log-message
 905        :db-sys
 906        "sys-device-stage-of-life: ~:[Updated~;Stored new~] device-stage-of-life-id ~A"
 907        new-row-p (device-stage-of-life-id record)))
 908     (device-stage-of-life-id record)))
 909
 910 (defun* store-device-stage-of-life-end (&mandatory-key device-stage-of-life-id
 911                                                        unmounting-date)
 912   "Update record in table sys-device-stage-of-life with an unmounting
 913 date.  Return device-stage-of-life-id of the altered record."
 914   (assert-phoros-db-major-version)
 915   (let ((record
 916          (get-dao 'sys-device-stage-of-life device-stage-of-life-id)))
 917     (with-slots ((unmounting-date-slot unmounting-date))
 918         record
 919       (setf unmounting-date-slot unmounting-date))
 920     (update-dao record)
 921     (device-stage-of-life-id record)))
 922
 923 (defun* store-camera-calibration (&key
 924                                   (usable "yes")
 925                                   &mandatory-key
 926                                   device-stage-of-life-id
 927                                   date
 928                                   person
 929                                   main-description
 930                                   debug
 931                                   photogrammetry-version
 932                                   mounting-angle
 933                                   inner-orientation-description
 934                                   c
 935                                   xh
 936                                   yh
 937                                   a1
 938                                   a2
 939                                   a3
 940                                   b1
 941                                   b2
 942                                   c1
 943                                   c2
 944                                   r0
 945                                   outer-orientation-description
 946                                   dx
 947                                   dy
 948                                   dz
 949                                   omega
 950                                   phi
 951                                   kappa
 952                                   boresight-description
 953                                   b-dx
 954                                   b-dy
 955                                   b-dz
 956                                   b-ddx
 957                                   b-ddy
 958                                   b-ddz
 959                                   b-rotx
 960                                   b-roty
 961                                   b-rotz
 962                                   b-drotx
 963                                   b-droty
 964                                   b-drotz
 965                                   nx
 966                                   ny
 967                                   nz
 968                                   d)
 969   "Store a new record of camera-calibration in table
 970 sys-device-stage-of-life, or update an existing one.  Return
 971 device-stage-of-life-id and date of the altered record."
 972   (assert-phoros-db-major-version)
 973   (let ((record
 974          (or (car (select-dao
 975                    'sys-camera-calibration
 976                    (:and (:= 'device-stage-of-life-id device-stage-of-life-id)
 977                          (:= 'date date))))
 978              (make-instance 'sys-camera-calibration :fetch-defaults t))))
 979     (with-slots
 980           ((device-stage-of-life-id-slot device-stage-of-life-id)
 981            (date-slot date)
 982            (person-slot person)
 983            (main-description-slot main-description)
 984            (usable-slot usable)
 985            (debug-slot debug)
 986            (photogrammetry-version-slot photogrammetry-version)
 987            (mounting-angle-slot mounting-angle)
 988            (inner-orientation-description-slot inner-orientation-description)
 989            (c-slot c)
 990            (xh-slot xh)
 991            (yh-slot yh)
 992            (a1-slot a1)
 993            (a2-slot a2)
 994            (a3-slot a3)
 995            (b1-slot b1)
 996            (b2-slot b2)
 997            (c1-slot c1)
 998            (c2-slot c2)
 999            (r0-slot r0)
1000            (outer-orientation-description-slot outer-orientation-description)
1001            (dx-slot dx)
1002            (dy-slot dy)
1003            (dz-slot dz)
1004            (omega-slot omega)
1005            (phi-slot phi)
1006            (kappa-slot kappa)
1007            (boresight-description-slot boresight-description)
1008            (b-dx-slot b-dx)
1009            (b-dy-slot b-dy)
1010            (b-dz-slot b-dz)
1011            (b-ddx-slot b-ddx)
1012            (b-ddy-slot b-ddy)
1013            (b-ddz-slot b-ddz)
1014            (b-rotx-slot b-rotx)
1015            (b-roty-slot b-roty)
1016            (b-rotz-slot b-rotz)
1017            (b-drotx-slot b-drotx)
1018            (b-droty-slot b-droty)
1019            (b-drotz-slot b-drotz)
1020            (nx-slot nx)
1021            (ny-slot ny)
1022            (nz-slot nz)
1023            (d-slot d))
1024         record
1025       (setf device-stage-of-life-id-slot device-stage-of-life-id
1026             date-slot date
1027             person-slot person
1028             main-description-slot main-description
1029             usable-slot usable
1030             debug-slot debug
1031             photogrammetry-version-slot photogrammetry-version
1032             mounting-angle-slot mounting-angle
1033             inner-orientation-description-slot inner-orientation-description
1034             c-slot c
1035             xh-slot xh
1036             yh-slot yh
1037             a1-slot a1
1038             a2-slot a2
1039             a3-slot a3
1040             b1-slot b1
1041             b2-slot b2
1042             c1-slot c1
1043             c2-slot c2
1044             r0-slot r0
1045             outer-orientation-description-slot outer-orientation-description
1046             dx-slot dx
1047             dy-slot dy
1048             dz-slot dz
1049             omega-slot omega
1050             phi-slot phi
1051             kappa-slot kappa
1052             boresight-description-slot boresight-description
1053             b-dx-slot b-dx
1054             b-dy-slot b-dy
1055             b-dz-slot b-dz
1056             b-ddx-slot b-ddx
1057             b-ddy-slot b-ddy
1058             b-ddz-slot b-ddz
1059             b-rotx-slot b-rotx
1060             b-roty-slot b-roty
1061             b-rotz-slot b-rotz
1062             b-drotx-slot b-drotx
1063             b-droty-slot b-droty
1064             b-drotz-slot b-drotz
1065             nx-slot nx
1066             ny-slot ny
1067             nz-slot nz
1068             d-slot d))
1069     (let ((new-row-p (save-dao record)))
1070       (cl-log:log-message
1071        :db-sys
1072        "sys-camera-calibration: ~:[Updated~;Stored new~] record ~
1073         for ~A, device-stage-of-life-id ~A"
1074        new-row-p (date record) (device-stage-of-life-id record)))
1075     (values (device-stage-of-life-id record)
1076             (date record))))
1077
1078 #|
1079 (with-connection '("phoros-dev" "postgres" "passwd" "host")
1080   (nuke-all-tables)
1081   (create-acquisition-project "yyyy")
1082   (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)
1083   (store-lens :c 10.5 :serial-number "17.8.8" :description "blahBlah3" :try-overwrite nil)
1084   (store-generic-device :camera-hardware-id 1 :lens-id 1)
1085   (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")
1086   (store-images-and-points "yyyy" "/home/bertb/phoros-testdata/mitsa-small/"))
1087 |#