stuff-db.lisp

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