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 (sans any `.') as used in
 258   ;; http://hpiers.obspm.fr/eoppc/bul/bulc/TimeSteps.history."
 259   (defun initialize-leap-seconds ()
 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)  ~
 277           Falling back to cached data in ~A."
 278          *time-steps-history-url* e *time-steps-history-file*)))
 279     (with-open-file (stream *time-steps-history-file*
 280                             :direction :input :if-does-not-exist :error)
 281       (let ((leap-second-records
 282              (sort                      ;just in case
 283               (loop
 284                  for raw-time-record = (read-line stream nil nil)
 285                  while raw-time-record
 286                  for (raw-year raw-month raw-date raw-sign raw-seconds)
 287                    = (cl-utilities:split-sequence
 288                       #\Space
 289                       (nsubstitute #\Space #\Tab raw-time-record)
 290                       :remove-empty-subseqs t)
 291                  for year = (when raw-year
 292                               (parse-integer raw-year :junk-allowed t))
 293                  for month = (when raw-month
 294                                (cdr (assoc (string-trim "." raw-month)
 295                                            leap-second-months
 296                                            :test #'string-equal)))
 297                  for date = (when raw-date
 298                               (parse-integer raw-date :junk-allowed t))
 299                  for sign = (when raw-sign
 300                               (if (string-equal raw-sign "-") -1 1))
 301                  for seconds = (when raw-seconds
 302                                  (parse-integer raw-seconds :junk-allowed t))
 303                  when (and year (< 1980 year))
 304                  collect (list (encode-universal-time 0 0 0 date month year 0)
 305                                (* sign seconds)))
 306               #'<
 307               :key #'car)))
 308         (setf *leap-seconds*
 309               (loop
 310                  for (leap-date leap) in leap-second-records
 311                  sum leap into leap-sum
 312                  collect leap-date into leap-dates
 313                  collect leap-sum into leap-sums
 314                  finally
 315                    (return (reverse (pairlis leap-dates leap-sums)))))))))
 316
 317 (defparameter *gps-epoch* (encode-universal-time 0 0 0 6 1 1980 0))
 318 (defparameter *unix-epoch* (encode-universal-time 0 0 0 1 1 1970 0))
 319
 320 (defun gps-start-of-week (time)
 321   "Begin of a GPS week (approximately Sunday 00:00)"
 322   (let ((week-length (* 7 24 3600))
 323         (leap-seconds (cdr (find time *leap-seconds*
 324                                  :key #'car :test #'> :from-end t))))
 325     (assert leap-seconds ()
 326             "Couldn't determine leap seconds for ~A" (timestring (round time)))
 327     (+ (* (floor (- time *gps-epoch*) week-length)
 328           week-length)
 329        *gps-epoch*
 330        leap-seconds)))
 331
 332 (defun utc-from-gps (utc-approximately gps-week-time)
 333   "Convert GPS week time into UTC.  gps-week-time may be of type
 334 float; in this case a non-integer is returned which can't be fed into
 335 decode-universal-time."
 336   (+ (gps-start-of-week utc-approximately) gps-week-time))
 337
 338 (defun utc-from-unix (unix-time)
 339   "Convert UNIX UTC to Lisp time."
 340   (when unix-time (+ unix-time *unix-epoch*)))
 341
 342 ;;(defun event-number (recorded-device-id)
 343 ;;  "Return the GPS event number corresponding to recorded-device-id of camera (etc.)"
 344 ;;  (let ((event-table (pairlis '(21 22 11 12 1 2)
 345 ;;                              '("1" "1" "2" "2" "1" "1"))))
 346 ;;    (cdr (assoc recorded-device-id event-table)))) ; TODO: make a saner version
 347
 348
 349 (let (event-number-storage)
 350   (defun device-event-number (recorded-device-id utc)
 351     "Return the GPS event number (a string) corresponding to
 352 recorded-device-id (a string) of camera (etc.)"
 353     (let ((device-event-number
 354            (cdr (assoc recorded-device-id event-number-storage
 355                        :test #'string-equal))))
 356       (if device-event-number
 357           device-event-number
 358           (let* ((date (simple-date:universal-time-to-timestamp (round utc)))
 359                  (device-stage-of-life
 360                   (car
 361                    (select-dao
 362                     'sys-device-stage-of-life
 363                     (:and (:overlaps
 364                            (:set 'mounting-date
 365                                  (:least :current-date 'unmounting-date))
 366                            (:set (:date date) (:date date)))
 367                           (:= 'recorded-device-id recorded-device-id))))))
 368             (assert device-stage-of-life
 369                     ()
 370                     "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."
 371                     recorded-device-id (timestring (round utc)))
 372             (push (cons recorded-device-id (event-number device-stage-of-life))
 373                   event-number-storage)
 374             (event-number device-stage-of-life))))))
 375
 376 (defun almost= (x y epsilon)
 377   (< (abs (- x y)) epsilon))
 378
 379 (defun geographic-to-utm (utm-zone longitude latitude &optional (height 0d0))
 380   "Return UTM utm-zone representation of geographic coordinates."
 381   (let ((utm-coordinate-system
 382          (format nil "+proj=utm +ellps=WGS84 +zone=~D" utm-zone)))
 383     (proj:cs2cs (list (proj:degrees-to-radians longitude) (proj:degrees-to-radians latitude) height)
 384                 :destination-cs utm-coordinate-system)))
 385
 386 (defun utm-zone (longitude)
 387   "Return UTM zone number belonging to longitude."
 388   (1+ (floor (+ longitude 180) 6)))
 389
 390 (defun assert-utm-zone (longitude-median longitude-leeway longitude latitude
 391                         geographic-height easting northing cartesian-height)
 392   "Check if, given longitude and latitude, easting and northing are
 393 calculated in the UTM zone belonging to longitude-median."
 394   (let ((epsilon 1d-1))
 395     (unless
 396         (or (every #'(lambda (x y) (almost= x y epsilon))
 397                    (geographic-to-utm (utm-zone (- longitude-median
 398                                                    longitude-leeway))
 399                                       longitude latitude geographic-height)
 400                    (list easting northing cartesian-height))
 401             (every #'(lambda (x y) (almost= x y epsilon))
 402                    (geographic-to-utm (utm-zone (+ longitude-median
 403                                                    longitude-leeway))
 404                                       longitude latitude geographic-height)
 405                    (list easting northing cartesian-height)))
 406       (error "The longitude median ~A should be in or near UTM zone ~D.  ~
 407               This is inconsistent with the easting values I was given.  ~
 408               Offending coordinates: (~A ~A ~A) (~A ~A ~A)."
 409              longitude-median (utm-zone longitude-median) longitude latitude
 410              geographic-height easting northing cartesian-height))))
 411
 412 (defun assert-gps-points-sanity (gps-points)
 413   "Check if gps-points (as returned by collect-gps-data) are ok.
 414 Return the Proj.4 string describing the cartesian coordinate system
 415 used."
 416   (loop
 417      for gps-event in gps-points
 418      for gps-event-vector = (cdr gps-event)
 419      for first-longitude = (longitude (aref gps-event-vector 0))
 420      for first-latitude = (latitude (aref gps-event-vector 0))
 421      for first-geographic-height = (ellipsoid-height (aref gps-event-vector 0))
 422      for first-easting = (easting (aref gps-event-vector 0))
 423      for first-northing = (northing (aref gps-event-vector 0))
 424      for first-cartesian-height = (cartesian-height (aref gps-event-vector 0))
 425      for longitude-median =
 426        (loop
 427           for point across gps-event-vector
 428           for i from 1
 429           sum (longitude point) into longitude-sum
 430           finally (return (/ longitude-sum i)))
 431      do (assert-utm-zone longitude-median 1
 432                          first-longitude first-latitude
 433                          first-geographic-height
 434                          first-easting first-northing
 435                          first-cartesian-height)
 436      finally (return (format nil "+proj=utm +ellps=WGS84 +zone=~D"
 437                              (utm-zone longitude-median)))))
 438
 439 (defun get-measurement-id (common-table-name dir-path cartesian-system)
 440   "Get measurement-id associated with dir-path and
 441 acquisition-project-id.  Create a fresh matching record if necessary."
 442   (let ((acquisition-project
 443          (car (select-dao 'sys-acquisition-project
 444                           (:= 'common-table-name common-table-name)))))
 445     (assert acquisition-project)
 446     (let* ((acquisition-project-id (acquisition-project-id acquisition-project))
 447            (measurement
 448             (or (car (select-dao
 449                       'sys-measurement
 450                       (:and (:= 'acquisition-project-id acquisition-project-id)
 451                             (:= 'directory dir-path))))
 452                 (insert-dao
 453                  (make-instance 'sys-measurement
 454                                 :acquisition-project-id acquisition-project-id
 455                                 :directory dir-path
 456                                 :cartesian-system cartesian-system
 457                                 :fetch-defaults t)))))
 458       (measurement-id measurement))))
 459
 460 (defun store-images-and-points (common-table-name dir-path
 461                                 &key (epsilon 1d-3)
 462                                 (root-dir (user-homedir-pathname))
 463                                 aggregate-events)
 464   "Link images to GPS points; store both into their respective DB
 465 tables.  Images become linked to GPS points when their respective
 466 times differ by less than epsilon seconds, and when the respective
 467 events match.  dir-path is a (probably absolute) path to a directory
 468 that contains one set of measuring data.  root-dir must be equal for
 469 all pojects."
 470   ;; TODO: epsilon could be a range.  We would do a raw mapping by (a bigger) time epsilon and then take speed into account.
 471   (assert
 472    (every #'string= root-dir dir-path)
 473    () "~A is not a leading part of ~A." root-dir dir-path)
 474   (assert-phoros-db-major-version)
 475   (assert     ;not strictly necessary, but may save the user some time
 476    (select-dao 'sys-acquisition-project
 477                (:= 'common-table-name common-table-name))
 478    () "There is no acquisition project named ~A." common-table-name)
 479   (setf *random-state* (make-random-state t))
 480   (create-data-table-definitions common-table-name)
 481   (initialize-leap-seconds)
 482   (let* ((images
 483           (collect-pictures-directory-data dir-path))
 484          (estimated-time
 485           (loop
 486              for i across images
 487              unless (or (fake-trigger-time-p i)
 488                         (< (trigger-time i) *gps-epoch*))
 489              do (return (trigger-time i))))
 490          (gps-points
 491           (if aggregate-events
 492               (aggregate-gps-events (collect-gps-data dir-path estimated-time))
 493               (collect-gps-data dir-path estimated-time)))
 494          (gps-start-pointers (loop
 495                                 for i in gps-points
 496                                 collect (cons (car i) 0)))
 497          (mapped-image-counter (length images))
 498          (cartesian-system (assert-gps-points-sanity gps-points))
 499          (dir-below-root-dir
 500           (enough-namestring (string-right-trim "/\\ " dir-path) root-dir)))
 501     (cl-log:log-message
 502      :db-dat "I assume this measure was taken approximately ~A."
 503      (timestring (round estimated-time)))
 504     (loop
 505        for i across images
 506        for image-event-number = (or aggregate-events
 507                                     (device-event-number (recorded-device-id i)
 508                                                          estimated-time))
 509        for image-time = (trigger-time i)
 510        for matching-point =
 511          (when image-time               ; otherwise this image is junk
 512            (let ((gps-start-pointer
 513                   (cdr (assoc image-event-number gps-start-pointers
 514                               :test #'equal))))
 515              (assert gps-start-pointer ()
 516                      "Can't find an event number of ~S ~
 517                       (as suggested by the sys tables relevant to the ~
 518                       current image) among ~{~S~#^, ~} ~
 519                       (as derived from the names of the GPS event files).  ~
 520                       Consider using --aggregate-events if you can't ~
 521                       recitfy your data."
 522                      image-event-number (mapcar #'car gps-start-pointers))
 523              (loop
 524                 for gps-pointer from gps-start-pointer
 525                 for gps-point across (subseq (cdr (assoc image-event-number
 526                                                          gps-points
 527                                                          :test #'equal))
 528                                              gps-start-pointer)
 529                 when (almost= (gps-time gps-point) image-time epsilon)
 530                 do (setf (cdr (assoc image-event-number
 531                                      gps-start-pointers :test #'equal))
 532                          gps-pointer) ; remember index of last matching point
 533                 and return gps-point)))
 534        if matching-point
 535        do (let ((point-id               ; TODO: consider using transaction
 536                  (or (point-id matching-point) ; We've hit a point twice.
 537                      (sequence-next (point-id-sequence-name matching-point))))
 538                 (measurement-id (get-measurement-id common-table-name
 539                                                     dir-below-root-dir
 540                                                     cartesian-system)))
 541             (setf (point-id i) point-id
 542                   (point-id matching-point) point-id
 543                   (measurement-id matching-point) measurement-id
 544                   (measurement-id i) measurement-id
 545                   (trigger-time matching-point) image-time)
 546             (save-dao matching-point)
 547             (execute (:update (dao-table-name (class-of matching-point))
 548                               :set 'coordinates
 549                               (:st_geomfromewkt
 550                                (format nil "SRID=4326; POINT(~S ~S ~S)"
 551                                        (longitude matching-point)
 552                                        (latitude matching-point)
 553                                        (ellipsoid-height matching-point)))
 554                               :where (:= 'point-id (point-id matching-point))))
 555             (save-dao i))
 556        else do
 557          (decf mapped-image-counter)
 558          (cl-log:log-message
 559           :orphan
 560           "Couldn't map to any point: ~A~A, byte ~S. ~
 561            ~:[~; It didn't have a decent trigger time anyway.~]"
 562           dir-path (filename i) (image-byte-position i)
 563           (fake-trigger-time-p i)))
 564     (cl-log:log-message
 565      :db-dat
 566      "Tried to map ~D images to GPS points.  ~
 567       The attempt has been successful in ~:[~D~;all~] cases.~
 568       ~1@*~:[  See file ~3@*~A for details on the failures.~;~]"
 569      (length images)
 570      (= (length images) mapped-image-counter)
 571      mapped-image-counter
 572      (truename
 573       (cl-log:text-file-messenger-file (cl-log:find-messenger :orphan))))))
 574
 575 (defun assert-user-points-version (user-points-version)
 576   "Check if user-points-version is compatible with the current
 577 user-point table definition."
 578   (multiple-value-bind (major minor revision) (version-number-parts user-points-version)
 579     (declare (ignore minor revision))
 580     (cond              ;insert more interesting clauses when necessary
 581       ((null user-points-version)
 582        (warn "Storing user-points which don't have a version number."))
 583       ((> major (phoros-version :major t))
 584        (warn  "User-point file was created by Phoros ~A ~
 585               which is newer than the current version ~A."
 586               user-points-version (phoros-version)))
 587       ((< major 13)
 588        (error "User-point file was created by Phoros ~A ~
 589               which is incompatible with the current version ~A.  ~
 590               Please edit the file like so: ~
 591               (1) Change any occurence of the name \"attribute\" to \"kind\". ~
 592               (2) Change the value of name \"phorosVersion\" ~
 593               from ~0@*~S to \"13.0.0\".  Then retry."
 594               user-points-version (phoros-version)))
 595        (t))))
 596
 597 (defun* store-user-points (presentation-project-name &mandatory-key json-file)
 598   "Store in DB user points given in file at json-file, which
 599 supposedly was created by Phoros.  Return number of points stored,
 600 number of points that were already in DB, number of points found in
 601 JSON file, and a list containing user-names from the json file that
 602 don't exist in DB."
 603   (assert-phoros-db-major-version)
 604   (let* ((user-point-table-name
 605           (user-point-table-name presentation-project-name))
 606          (raw-input (with-open-file (stream json-file)
 607                       (json:decode-json stream)))
 608          (raw-input-version (cdr (assoc :phoros-version raw-input)))
 609          (raw-features (cdr (assoc :features raw-input))))
 610     (assert-user-points-version raw-input-version)
 611     (loop
 612        for i in raw-features
 613        for coordinates = (cdr (assoc :coordinates (cdr (assoc :geometry i))))
 614        for point-form = (format nil "SRID=4326; POINT(~{~S ~})" coordinates)
 615        for properties = (cdr (assoc :properties i))
 616        for user-name = (cdr (assoc :user-name properties))
 617        for kind = (cdr (assoc :kind properties))
 618        for description = (cdr (assoc :description properties))
 619        for numeric-description = (cdr (assoc :numeric-description properties))
 620        for creation-date = (cdr (assoc :creation-date properties))
 621        ;; for stdx-global = (cdr (assoc :stdx-global properties))
 622        ;; for stdy-global = (cdr (assoc :stdy-global properties))
 623        ;; for stdz-global = (cdr (assoc :stdz-global properties))
 624        for input-size = (cdr (assoc :input-size properties))
 625        for aux-numeric = (cdr (assoc :aux-numeric properties))
 626        for aux-text = (cdr (assoc :aux-text properties))
 627        for aux-numeric-comparison =
 628          (if aux-numeric
 629              (format nil "(~A = (CAST (ARRAY[~{~S~#^,~}] AS NUMERIC[])))"
 630                      (s-sql:to-sql-name 'aux-numeric) aux-numeric)
 631              (sql (:is-null 'aux-numeric)))
 632        for aux-text-comparison =
 633          (if aux-text
 634              (sql (:= 'aux-text (apply #'vector aux-text)))
 635              (sql (:is-null 'aux-text)))
 636        with points-stored = 0
 637        with points-already-in-db = 0
 638        with unknown-users = nil
 639        sum 1 into points-tried
 640        do
 641          (if
 642           (query
 643            (:select
 644             t
 645             :from user-point-table-name
 646             :where (:and (:st_equals 'coordinates
 647                                      (:st_geomfromewkt point-form))
 648                          (:= 'kind kind)
 649                          (:= 'description description)
 650                          (:= 'numeric-description numeric-description)
 651                          (:= (:to-char 'creation-date
 652                                        *user-point-creation-date-format*)
 653                              creation-date)
 654                          ;; (:= 'stdx-global stdx-global)
 655                          ;; (:= 'stdy-global stdy-global)
 656                          ;; (:= 'stdz-global stdz-global)
 657                          (:= 'input-size input-size)
 658                          (:raw aux-numeric-comparison)
 659                          (:raw aux-text-comparison))))
 660           (incf points-already-in-db)
 661           (progn
 662             (unless (and user-name
 663                          (query
 664                           (:select t
 665                                    :from 'sys-user
 666                                    :where (:= 'user-name user-name))))
 667               (pushnew user-name unknown-users :test #'equal))
 668             (assert
 669              (= 1
 670                 (execute
 671                  (sql-compile
 672                   `(:insert-into
 673                     ,user-point-table-name :set
 674                     'coordinates (:st_geomfromewkt ,point-form)
 675                     'user-id ,(if user-name
 676                                   `(:select 'user-id
 677                                             :from 'sys-user
 678                                             :where (:= 'user-name
 679                                                        ,user-name))
 680                                   :null)
 681                     'kind ,kind
 682                     'description ,description
 683                     'numeric-description ,numeric-description
 684                     'creation-date ,creation-date
 685                     ;; 'stdx-global ,stdx-global
 686                     ;; 'stdy-global ,stdy-global
 687                     ;; 'stdz-global ,stdz-global
 688                     'input-size ,input-size
 689                     'aux-numeric ,(if aux-numeric
 690                                       (apply #'vector aux-numeric)
 691                                       :null)
 692                     'aux-text ,(if aux-text
 693                                    (apply #'vector aux-text)
 694                                    :null)))))
 695              () "Point not stored.  This should not happen.")
 696             (incf points-stored)))
 697        finally (return (values points-stored
 698                                points-already-in-db
 699                                points-tried
 700                                unknown-users)))))
 701
 702 (defun update-footprint (common-table-name
 703                          measurement-id filename byte-position)
 704   "Update footprint of an image."
 705   (let* ((aggregate-view-name
 706           (aggregate-view-name common-table-name))
 707          (raw-footprint
 708           (photogrammetry
 709            :footprint
 710            ;; KLUDGE: translate keys, e.g. a1 -> a_1
 711            (json:decode-json-from-string
 712             (json:encode-json-to-string
 713              (query (:select '*
 714                              :from aggregate-view-name
 715                              :where (:and (:= 'measurement-id measurement-id)
 716                                           (:= 'filename filename)
 717                                           (:= 'byte-position byte-position)))
 718                     :alist)))))
 719          (ewkt-footprint
 720           (format nil "SRID=4326; POLYGON((~{~{~A~#^ ~}~#^, ~}))"
 721                   (cdr (assoc :footprint raw-footprint)))))
 722     (execute
 723      (:update aggregate-view-name :set
 724               'footprint (:st_geomfromewkt ewkt-footprint)
 725               :where (:and (:= 'measurement-id measurement-id)
 726                            (:= 'filename filename)
 727                            (:= 'byte-position byte-position))))))
 728
 729
 730 (defun insert-footprints (common-table-name)
 731   "Give images of acquisition project common-table-name that don't
 732 have up-to-date footprints fresh footprints."
 733   (let* ((log-frequency 200)
 734          (aggregate-view-name
 735           (aggregate-view-name common-table-name))
 736          (number-of-image-records
 737           (query (:select (:count '*)
 738                           :from aggregate-view-name
 739                           :where (:and
 740                                   (:or
 741                                    (:is-null 'footprint)
 742                                    (:!= 'footprint-device-stage-of-life-id
 743                                         'device-stage-of-life-id))
 744                                   'usable))
 745                  :single!)))
 746     (loop
 747        for image-records
 748        = (query (:limit
 749                  (:order-by
 750                   (:select 'measurement-id 'filename 'byte-position
 751                            :from aggregate-view-name
 752                            :where (:and
 753                                    (:or
 754                                     (:is-null 'footprint)
 755                                     (:!= 'footprint-device-stage-of-life-id
 756                                          'device-stage-of-life-id))
 757                                    'usable))
 758                   'measurement-id 'filename 'byte-position)
 759                  log-frequency))
 760        while image-records
 761        sum (loop
 762               for (measurement-id filename byte-position) in image-records
 763               sum (update-footprint
 764                    common-table-name measurement-id filename byte-position))
 765        into number-of-updated-footprints
 766        do (cl-log:log-message
 767            :db-dat
 768            "Updating image footprints of acquisition project ~A: ~
 769            ~D out of ~D done."
 770            common-table-name
 771            number-of-updated-footprints number-of-image-records)
 772        finally (return number-of-updated-footprints))))
 773
 774 (defun insert-all-footprints (postgresql-credentials)
 775   "Asynchronously update image footprints of all acquisition projects
 776 where necessarcy."
 777   (let ((common-table-names
 778          (with-connection postgresql-credentials
 779            (query (:select 'common-table-name
 780                            :from 'sys-acquisition-project)
 781                   :list))))
 782     (setf bt:*default-special-bindings*
 783           (acons '*insert-footprints-postgresql-credentials*
 784                  `(list ,@postgresql-credentials)
 785                  nil))
 786     (dolist (common-table-name common-table-names)
 787       (bt:make-thread
 788        #'(lambda ()
 789            (declare (special *insert-footprints-postgresql-credentials*))
 790            (with-connection *insert-footprints-postgresql-credentials*
 791              (insert-footprints common-table-name)))
 792        :name "insert-all-footprints"))))
 793
 794 (defun delete-imageless-points (common-table-name)
 795   "Delete from acquisition project common-table-name points that have
 796 no images."
 797   (let* ((point-data-table-name (point-data-table-name common-table-name))
 798          (image-data-table-name (image-data-table-name common-table-name)))
 799     (execute
 800      (:delete-from point-data-table-name
 801                    :where (:not
 802                            (:exists
 803                             (:select (:dot image-data-table-name 'point-id)
 804                                      :from image-data-table-name
 805                                      :where (:= (:dot image-data-table-name
 806                                                       'point-id)
 807                                                 (:dot point-data-table-name
 808                                                       'point-id)))))))))
 809
 810 (defun delete-all-imageless-points (postgresql-credentials)
 811   "Asynchronously delete imageless footprints of all acquisition
 812 projects."
 813   (let ((common-table-names
 814          (with-connection postgresql-credentials
 815            (query (:select 'common-table-name
 816                            :from 'sys-acquisition-project)
 817                   :list))))
 818     (setf bt:*default-special-bindings*
 819           (acons '*delete-imageless-points-postgresql-credentials*
 820                  `(list ,@postgresql-credentials)
 821                  nil))
 822     (dolist (common-table-name common-table-names)
 823       (bt:make-thread
 824        #'(lambda ()
 825            (declare (special *delete-imageless-points-postgresql-credentials*))
 826            (with-connection *delete-imageless-points-postgresql-credentials*
 827              (delete-imageless-points common-table-name)))
 828        :name "delete-all-imageless-points"))))
 829
 830 (defun* store-camera-hardware (&key
 831                                (try-overwrite t)
 832                                &mandatory-key
 833                                sensor-width-pix
 834                                sensor-height-pix
 835                                pix-size
 836                                channels
 837                                pix-depth
 838                                color-raiser
 839                                bayer-pattern
 840                                serial-number
 841                                description)
 842   "Store a new record in table sys-camera-hardware, or try updating an
 843 existing one.  Return camera-hardware-id of the altered record."
 844   (assert-phoros-db-major-version)
 845   (let ((record
 846          (or (when try-overwrite
 847                (car (select-dao 'sys-camera-hardware
 848                                 (:and (:= 'sensor-width-pix sensor-width-pix)
 849                                       (:= 'sensor-height-pix sensor-height-pix)
 850                                       (:= 'pix-size pix-size)
 851                                       (:= 'channels channels)
 852                                       (:= 'serial-number serial-number)
 853                                       (:= 'pix-depth pix-depth)))))
 854              (make-instance 'sys-camera-hardware :fetch-defaults t))))
 855     (with-slots ((sensor-width-pix-slot sensor-width-pix)
 856                  (sensor-height-pix-slot sensor-height-pix)
 857                  (pix-size-slot pix-size)
 858                  (channels-slot channels)
 859                  (pix-depth-slot pix-depth)
 860                  (color-raiser-slot color-raiser)
 861                  (bayer-pattern-slot bayer-pattern)
 862                  (serial-number-slot serial-number)
 863                  (description-slot description))
 864         record
 865       (setf sensor-width-pix-slot sensor-width-pix
 866             sensor-height-pix-slot sensor-height-pix
 867             pix-size-slot pix-size
 868             channels-slot channels
 869             pix-depth-slot pix-depth
 870             color-raiser-slot color-raiser
 871             bayer-pattern-slot bayer-pattern
 872             serial-number-slot serial-number
 873             description-slot description))
 874     (let ((new-row-p (save-dao record)))
 875       (cl-log:log-message
 876        :db-sys
 877        "sys-camera-hardware: ~:[Updated~;Stored new~] camera-hardware-id ~A"
 878        new-row-p (camera-hardware-id record)))
 879     (camera-hardware-id record)))
 880
 881 (defun* store-lens (&key (try-overwrite t)
 882                          &mandatory-key
 883                          c
 884                          serial-number
 885                          description)
 886   "Store a new record in table sys-lens, or try updating an existing
 887 one.  Return lens-id of the altered record."
 888   (assert-phoros-db-major-version)
 889   (let ((record
 890          (or (when try-overwrite
 891                (car (select-dao 'sys-lens
 892                                 (:and (:= 'c c)
 893                                       (:= 'serial-number serial-number)))))
 894              (make-instance 'sys-lens :fetch-defaults t))))
 895     (with-slots ((c-slot c)
 896                  (serial-number-slot serial-number)
 897                  (description-slot description))
 898         record
 899       (setf c-slot c
 900             serial-number-slot serial-number
 901             description-slot description))
 902     (let ((new-row-p (save-dao record)))
 903       (cl-log:log-message
 904        :db-sys "sys-lens: ~:[Updated~;Stored new~] lens-id ~A"
 905        new-row-p (lens-id record)))
 906     (lens-id record)))
 907
 908 (defun store-generic-device
 909     (&key (camera-hardware-id :null) (lens-id :null) (scanner-id :null))
 910   "Store a new record in table sys-generic-device.  Return
 911 generic-device-id of the new record."
 912   (assert-phoros-db-major-version)
 913   (assert (notevery
 914            #'(lambda (x) (eq :null x))
 915            (list camera-hardware-id lens-id scanner-id))
 916           () "Generic device: not enough components.")
 917   (let ((record (make-instance 'sys-generic-device
 918                                :camera-hardware-id camera-hardware-id
 919                                :lens-id lens-id
 920                                :scanner-id scanner-id
 921                                :fetch-defaults t)))
 922     (let ((new-row-p (save-dao record)))
 923       (cl-log:log-message
 924        :db-sys
 925        "sys-generic-device: ~:[Updated~;Stored new~] generic-device-id ~A"
 926        new-row-p (generic-device-id record)))
 927     (generic-device-id record)))
 928
 929 (defun* store-device-stage-of-life (&key (unmounting-date :null)
 930                                    (try-overwrite t)
 931                                    &mandatory-key
 932                                    recorded-device-id
 933                                    event-number
 934                                    generic-device-id
 935                                    vehicle-name
 936                                    casing-name
 937                                    computer-name
 938                                    computer-interface-name
 939                                    mounting-date)
 940   "Store a new record in table sys-device-stage-of-life, or try
 941 updating an existing one.  Return device-stage-of-life-id of the
 942 altered record."
 943   (assert-phoros-db-major-version)
 944   (let ((record
 945          (or (when try-overwrite
 946                (car (select-dao
 947                      'sys-device-stage-of-life
 948                      (:and (:= 'recorded-device-id recorded-device-id)
 949                            (:= 'event-number event-number)
 950                            (:= 'generic-device-id generic-device-id)
 951                            (:= 'vehicle-name vehicle-name)
 952                            (:= 'mounting-date mounting-date)))))
 953              (make-instance 'sys-device-stage-of-life :fetch-defaults t))))
 954     (with-slots ((recorded-device-id-slot recorded-device-id)
 955                  (event-number-slot event-number)
 956                  (generic-device-id-slot generic-device-id)
 957                  (vehicle-name-slot vehicle-name)
 958                  (casing-name-slot casing-name)
 959                  (computer-name-slot computer-name)
 960                  (computer-interface-name-slot computer-interface-name)
 961                  (mounting-date-slot mounting-date)
 962                  (unmounting-date-slot unmounting-date))
 963         record
 964       (setf recorded-device-id-slot recorded-device-id
 965             event-number-slot event-number
 966             generic-device-id-slot generic-device-id
 967             vehicle-name-slot vehicle-name
 968             casing-name-slot casing-name
 969             computer-name-slot computer-name
 970             computer-interface-name-slot computer-interface-name
 971             mounting-date-slot mounting-date
 972             unmounting-date-slot unmounting-date))
 973     (let ((new-row-p (save-dao record)))
 974       (cl-log:log-message
 975        :db-sys
 976        "sys-device-stage-of-life: ~:[Updated~;Stored new~] device-stage-of-life-id ~A"
 977        new-row-p (device-stage-of-life-id record)))
 978     (device-stage-of-life-id record)))
 979
 980 (defun* store-device-stage-of-life-end (&mandatory-key device-stage-of-life-id
 981                                                        unmounting-date)
 982   "Update record in table sys-device-stage-of-life with an unmounting
 983 date.  Return device-stage-of-life-id of the altered record."
 984   (assert-phoros-db-major-version)
 985   (let ((record
 986          (get-dao 'sys-device-stage-of-life device-stage-of-life-id)))
 987     (with-slots ((unmounting-date-slot unmounting-date))
 988         record
 989       (setf unmounting-date-slot unmounting-date))
 990     (update-dao record)
 991     (device-stage-of-life-id record)))
 992
 993 (defun* store-camera-calibration (&key
 994                                   (usable "yes")
 995                                   &mandatory-key
 996                                   device-stage-of-life-id
 997                                   date
 998                                   person
 999                                   main-description
1000                                   debug
1001                                   photogrammetry-version
1002                                   mounting-angle
1003                                   inner-orientation-description
1004                                   c
1005                                   xh
1006                                   yh
1007                                   a1
1008                                   a2
1009                                   a3
1010                                   b1
1011                                   b2
1012                                   c1
1013                                   c2
1014                                   r0
1015                                   outer-orientation-description
1016                                   dx
1017                                   dy
1018                                   dz
1019                                   omega
1020                                   phi
1021                                   kappa
1022                                   boresight-description
1023                                   b-dx
1024                                   b-dy
1025                                   b-dz
1026                                   b-ddx
1027                                   b-ddy
1028                                   b-ddz
1029                                   b-rotx
1030                                   b-roty
1031                                   b-rotz
1032                                   b-drotx
1033                                   b-droty
1034                                   b-drotz
1035                                   nx
1036                                   ny
1037                                   nz
1038                                   d)
1039   "Store a new record of camera-calibration in table
1040 sys-device-stage-of-life, or update an existing one.  Return
1041 device-stage-of-life-id and date of the altered record."
1042   (assert-phoros-db-major-version)
1043   (let ((record
1044          (or (car (select-dao
1045                    'sys-camera-calibration
1046                    (:and (:= 'device-stage-of-life-id device-stage-of-life-id)
1047                          (:= 'date date))))
1048              (make-instance 'sys-camera-calibration :fetch-defaults t))))
1049     (with-slots
1050           ((device-stage-of-life-id-slot device-stage-of-life-id)
1051            (date-slot date)
1052            (person-slot person)
1053            (main-description-slot main-description)
1054            (usable-slot usable)
1055            (debug-slot debug)
1056            (photogrammetry-version-slot photogrammetry-version)
1057            (mounting-angle-slot mounting-angle)
1058            (inner-orientation-description-slot inner-orientation-description)
1059            (c-slot c)
1060            (xh-slot xh)
1061            (yh-slot yh)
1062            (a1-slot a1)
1063            (a2-slot a2)
1064            (a3-slot a3)
1065            (b1-slot b1)
1066            (b2-slot b2)
1067            (c1-slot c1)
1068            (c2-slot c2)
1069            (r0-slot r0)
1070            (outer-orientation-description-slot outer-orientation-description)
1071            (dx-slot dx)
1072            (dy-slot dy)
1073            (dz-slot dz)
1074            (omega-slot omega)
1075            (phi-slot phi)
1076            (kappa-slot kappa)
1077            (boresight-description-slot boresight-description)
1078            (b-dx-slot b-dx)
1079            (b-dy-slot b-dy)
1080            (b-dz-slot b-dz)
1081            (b-ddx-slot b-ddx)
1082            (b-ddy-slot b-ddy)
1083            (b-ddz-slot b-ddz)
1084            (b-rotx-slot b-rotx)
1085            (b-roty-slot b-roty)
1086            (b-rotz-slot b-rotz)
1087            (b-drotx-slot b-drotx)
1088            (b-droty-slot b-droty)
1089            (b-drotz-slot b-drotz)
1090            (nx-slot nx)
1091            (ny-slot ny)
1092            (nz-slot nz)
1093            (d-slot d))
1094         record
1095       (setf device-stage-of-life-id-slot device-stage-of-life-id
1096             date-slot date
1097             person-slot person
1098             main-description-slot main-description
1099             usable-slot usable
1100             debug-slot debug
1101             photogrammetry-version-slot photogrammetry-version
1102             mounting-angle-slot mounting-angle
1103             inner-orientation-description-slot inner-orientation-description
1104             c-slot c
1105             xh-slot xh
1106             yh-slot yh
1107             a1-slot a1
1108             a2-slot a2
1109             a3-slot a3
1110             b1-slot b1
1111             b2-slot b2
1112             c1-slot c1
1113             c2-slot c2
1114             r0-slot r0
1115             outer-orientation-description-slot outer-orientation-description
1116             dx-slot dx
1117             dy-slot dy
1118             dz-slot dz
1119             omega-slot omega
1120             phi-slot phi
1121             kappa-slot kappa
1122             boresight-description-slot boresight-description
1123             b-dx-slot b-dx
1124             b-dy-slot b-dy
1125             b-dz-slot b-dz
1126             b-ddx-slot b-ddx
1127             b-ddy-slot b-ddy
1128             b-ddz-slot b-ddz
1129             b-rotx-slot b-rotx
1130             b-roty-slot b-roty
1131             b-rotz-slot b-rotz
1132             b-drotx-slot b-drotx
1133             b-droty-slot b-droty
1134             b-drotz-slot b-drotz
1135             nx-slot nx
1136             ny-slot ny
1137             nz-slot nz
1138             d-slot d))
1139     (let ((new-row-p (save-dao record)))
1140       (cl-log:log-message
1141        :db-sys
1142        "sys-camera-calibration: ~:[Updated~;Stored new~] record ~
1143         for ~A, device-stage-of-life-id ~A"
1144        new-row-p (date record) (device-stage-of-life-id record)))
1145     (values (device-stage-of-life-id record)
1146             (date record))))
1147
1148 #|
1149 (with-connection '("phoros-dev" "postgres" "passwd" "host")
1150   (nuke-all-tables)
1151   (create-acquisition-project "yyyy")
1152   (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)
1153   (store-lens :c 10.5 :serial-number "17.8.8" :description "blahBlah3" :try-overwrite nil)
1154   (store-generic-device :camera-hardware-id 1 :lens-id 1)
1155   (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")
1156   (store-images-and-points "yyyy" "/home/bertb/phoros-testdata/mitsa-small/"))
1157 |#