fasttrack.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 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-fasttrack)
  20
  21 ;;; Debug helpers.  TODO: remove them.
  22 (defparameter *t* nil)
  23 (defparameter *tt* nil)
  24
  25 (cffi:define-foreign-library phoml
  26   (:unix (:or "./libphoml.so"
  27               "./phoml/lib/libphoml.so"))
  28   (t (:default "libphoml")))
  29
  30 (setf *read-default-float-format* 'double-float)
  31
  32 (defparameter *photogrammetry-mutex* (bt:make-lock "photogrammetry"))
  33
  34 (defparameter *fasttrack-version*
  35   (asdf:component-version (asdf:find-system :fasttrack))
  36   "Fasttrack version as defined in system definition.  TODO: enforce equality with *phoros-version*")
  37
  38 (defvar *postgresql-aux-credentials* nil
  39   "A list: (database user password host &key (port 5432) use-ssl).")
  40
  41 (defparameter *aggregate-view-columns*
  42   (list 'usable
  43         'recorded-device-id                ;debug
  44         'device-stage-of-life-id           ;debug
  45         'generic-device-id                 ;debug
  46         'directory
  47         'measurement-id
  48         'filename 'byte-position 'point-id
  49         'trigger-time
  50         ;;'coordinates   ;the search target
  51         'longitude 'latitude 'ellipsoid-height
  52         'cartesian-system
  53         'east-sd 'north-sd 'height-sd
  54         'roll 'pitch 'heading
  55         'roll-sd 'pitch-sd 'heading-sd
  56         'sensor-width-pix 'sensor-height-pix
  57         'pix-size
  58         'bayer-pattern 'color-raiser
  59         'mounting-angle
  60         'dx 'dy 'dz 'omega 'phi 'kappa
  61         'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
  62         'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
  63         'b-ddx 'b-ddy 'b-ddz
  64         'b-drotx 'b-droty 'b-drotz)
  65   "Most of the column names of aggregate-view.")
  66
  67 (defvar *phoros-cookies* nil
  68   "Container for cookies sent by Phoros server")
  69
  70 (defvar *phoros-url* nil
  71   "URL of the Phoros project currently in use.")
  72
  73 (defvar *cache-dir* '(:absolute "home" "bertb" "lisphack" "phoros" "cache"))
  74 ;; TODO: invent cache validity checks
  75
  76 (defparameter *image-size* '(800 800)
  77   "Image size in pixels in a list (width height).")
  78
  79 (defun ensure-hyphen-before-digit (symbol)
  80   "Return symbol with hyphens inserted after each letter that is
  81 followed by a digit. "
  82   (intern
  83    (coerce
  84     (loop
  85        with need-hyphen-before-next-digit-p
  86        for c across (string symbol)
  87        if (and need-hyphen-before-next-digit-p (digit-char-p c))
  88        collect #\- and collect c and do (setf need-hyphen-before-next-digit-p nil)
  89        else collect c and do (setf need-hyphen-before-next-digit-p nil)
  90        end
  91        if (alpha-char-p c) do (setf need-hyphen-before-next-digit-p t) end)
  92     'string)))
  93
  94 (defmacro defun-cached (name (&rest args) &body body &aux (doc ""))
  95   "Define a function whose return value must be readibly printable, is
  96   being read from a chache if possible, and is being cached if
  97   necessary."
  98   (when (stringp (car body))
  99     (setf doc (car body))
 100     (setf body (cdr body)))
 101   (cl-utilities:with-unique-names (input-stream output-stream)
 102     `(defun ,name (,@args)
 103        ,doc
 104        (ensure-directories-exist (cache-file-name ',name ,@args))
 105        (with-open-file (,input-stream (cache-file-name ',name ,@args)
 106                                       :direction :input
 107                                       :if-does-not-exist nil)
 108          (if ,input-stream
 109              (read ,input-stream)
 110              (with-open-file (,output-stream (cache-file-name ',name ,@args)
 111                                             :direction :output)
 112                (prin1 (progn ,@body)
 113                       ,output-stream)))))))
 114
 115 (defun main ()
 116
 117   (with-tk ((make-instance 'ffi-tk))
 118     (tcl "package" "require" "Img")
 119     (tcl "option" "add" "*tearOff" 0)
 120     (tcl "wm" "title" "." "Phoros Fasttrack")
 121     (tcl "menu" ".menubar")
 122     (tcl "." "configure" :menu ".menubar")
 123     (tcl "menu" ".menubar.file")
 124     (tcl ".menubar" "add" "cascade" :label "File" :menu ".menubar.file" :underline 0)
 125     (tcl ".menubar.file" "add" "command" :label "Kaputt" :command (tcl{ "destroy" "."))
 126     (tcl ".menubar.file" "add" "command" :label "Do Stuff" :command (event-handler* (print "doing stuff") (print "doing more stuff") (tcl "set" "feet" 500)))
 127
 128     (bind-event "." "<<check.blah>>" ((ddd #\d)) (print (list "ddd" ddd)))
 129     (tcl ".menubar.file" "add" "checkbutton" :label "Check" :variable "check" :onvalue 1 :offvalue 0 :command (tcl{ "event" "generate" "." "<<check.blah>>" :data (lit "$check")))
 130
 131     (tcl "grid" (tcl[ "ttk::frame" ".f" :borderwidth 3 :relief "groove") :column 0 :row 0 :sticky "nwes")
 132
 133     (tcl "set" "chart1" (tcl[ "canvas" ".f.chart1" :bg "yellow" :scrollregion "0 0 2500 400" :xscrollcommand ".f.h set"))
 134
 135     (tcl "grid" (tcl[ "canvas" ".f.rearview" :bg "black" (mapcan #'list '(:width :height) *image-size*)) :column 0 :row 0 :sticky "nwes")
 136     (tcl "grid" (tcl[ "canvas" ".f.frontview" :bg "black" (mapcan #'list '(:width :height) *image-size*)) :column 1 :row 0 :sticky "nwes")
 137     (tcl "grid" (lit "$chart1") :column 0 :row 1 :sticky "nwes" :columnspan 2)
 138     (tcl "grid" (tcl[ "tk::scrollbar" ".f.h" :orient "horizontal" :command ".f.chart1 xview") :column 0 :row 2 :sticky "we" :columnspan 2)
 139     (tcl "grid" (tcl[ "ttk::label" ".f.l1" :background "grey") :column 0 :row 3 :sticky "nwes")
 140     (tcl "grid" (tcl[ "ttk::label" ".f.l2" :textvariable "meters" :background "red") :column 1 :row 3 :sticky "nwes")
 141
 142
 143     (tcl ".f.chart1" "create" "line" '(30 30 40 40 50 30 600 40) :fill "red" :tags "lll")
 144     ;; (tcl ".f.chart1" "scale" "lll" 0 0 .1 1)
 145
 146     (tcl "image" "create" "photo" "rearview")
 147     (tcl "image" "create" "photo" "frontview")
 148
 149     (tcl ".f.rearview" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "rearview")
 150     (tcl ".f.frontview" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "frontview")
 151
 152     (tcl "set" "chart1ttt" (tcl[ ".f.chart1" "create" "rectangle" 0 0 2500 400 :width 0 :fill "green"))
 153
 154     (tcl "set" "ppp" (tcl ".f.chart1" "create" "line"
 155                           (loop
 156                              for coordinates across (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011")
 157                              for i from 0
 158                              when coordinates collect i and collect (format nil "~F" (* (- (coordinates-longitude coordinates) 14) 500)))
 159                           :fill "green" :width 10))
 160     (loop
 161        for coordinates across (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011")
 162        for i from 0
 163        when coordinates do (tcl ".f.chart1" "create" "oval" i (format nil "~F" (coordinates-longitude coordinates)) i (format nil "~F" (coordinates-longitude coordinates))))
 164
 165     (tcl ".f.chart1" "create" "line" 100 100 100 100 :capstyle "round" :width 5) ;a point
 166
 167     (tcl "set" "cursor" (tcl[ ".f.chart1" "create" "line" 10 0 10 100))
 168
 169     (bind-event "." "<<jumptostation>>" ((xx #\d))
 170       (print (list xx))
 171       (tcl "set" "meters" xx)
 172       (tcl ".f.chart1" "delete" (lit "$cursor"))
 173       (tcl "set" "cursor" (tcl[ ".f.chart1" "create" "line" xx 0 xx 100))
 174       (put-image :table 'bew-landstr-kleinpunkte :vnk "4252017" :nnk "4252011" :station (round (parse-number:parse-number xx)) :step 10 :rear-view-p t)
 175       (put-image :table 'bew-landstr-kleinpunkte :vnk "4252017" :nnk "4252011" :station (round (parse-number:parse-number xx)) :step 10 :rear-view-p nil))
 176
 177     (tcl ".f.chart1" "bind" (lit "$chart1ttt") "<ButtonPress-1>" "event generate . <<jumptostation>> -data [.f.chart1 canvasx %x]")
 178
 179     ;; (tcl "foreach w [ winfo children .f ] {grid configure $w -padx 5 -pady 5}")
 180     ;; (tcl "focus" ".f.feet")
 181
 182     (mainloop)))
 183
 184 (defun put-image (&key table vnk nnk station step rear-view-p)
 185   "Put an image along with a labelled station marker on screen."
 186   (let* ((point-radius 5)
 187          (line-width 2)
 188          (photo (if rear-view-p "rearview" "frontview"))
 189          (canvas (concatenate 'string ".f." photo))
 190          (cursor-name (concatenate 'string photo "cursor"))
 191          (label-name (concatenate 'string photo "label"))
 192          (arrow-name (concatenate 'string photo "arrow"))
 193          (global-point-coordinates
 194           (subseq (all-stations table vnk nnk)
 195                   (min (length (all-stations table vnk nnk)) station)
 196                   (min (length (all-stations table vnk nnk)) (+ station 4))))
 197          (image-data-alist
 198           (get-image-data-alist (road-section-image-data table vnk nnk step rear-view-p)
 199                                 station
 200                                 step))
 201          (image-arrow-coordinates
 202           (loop
 203              for i across global-point-coordinates
 204              append (image-point-coordinates image-data-alist i)))
 205          (image-cursor-coordinates (ignore-errors
 206                                      (list (- (first image-arrow-coordinates) point-radius)
 207                                            (- (second image-arrow-coordinates) point-radius)
 208                                            (+ (first image-arrow-coordinates) point-radius)
 209                                            (+ (second image-arrow-coordinates) point-radius))))
 210          (image-label-coordinates  (ignore-errors
 211                                      (list (+ (first image-arrow-coordinates) point-radius line-width)
 212                                            (second image-arrow-coordinates)))))
 213     (tcl photo "configure" :file (or (get-image-namestring (road-section-image-data table vnk nnk step rear-view-p)
 214                                                            station
 215                                                            step)
 216                                      "public_html/phoros-logo-plain.png"))
 217     (tcl "if" (tcl[ "info" "exists" cursor-name) (tcl{ canvas "delete" (lit (concatenate 'string "$" cursor-name))))
 218     (tcl "if" (tcl[ "info" "exists" label-name) (tcl{ canvas "delete" (lit (concatenate 'string "$" label-name))))
 219     (tcl "if" (tcl[ "info" "exists" arrow-name) (tcl{ canvas "delete" (lit (concatenate 'string "$" arrow-name))))
 220     (when image-cursor-coordinates
 221       (tcl "set" cursor-name (tcl[ canvas "create" "oval" image-cursor-coordinates :width line-width)))
 222     (when image-label-coordinates
 223       (tcl "set" label-name (tcl[ canvas "create" "text" image-label-coordinates :text station :anchor "w")))
 224     (when (and image-arrow-coordinates
 225                (loop
 226                   for tail on image-arrow-coordinates by #'cddr
 227                   always (in-image-p (first tail) (second tail))))
 228       (tcl "set" arrow-name (tcl[ canvas "create" "line" image-arrow-coordinates :arrow "last" :width line-width)))))
 229
 230 (defun image-point-coordinates (image-data-alist global-point-coordinates)
 231   "Return a list (m n) of image coordinates representing
 232 global-point-coordinates in the image described in image-data-alist
 233 but scaled to fit into *image-size*."
 234   (ignore-errors
 235     (convert-image-coordinates
 236      (photogrammetry :reprojection
 237                      image-data-alist
 238                      (pairlis '(:x-global :y-global :z-global)
 239                               (proj:cs2cs
 240                                (list
 241                                 (proj:degrees-to-radians
 242                                  (coordinates-longitude global-point-coordinates))
 243                                 (proj:degrees-to-radians
 244                                  (coordinates-latitude global-point-coordinates))
 245                                 (coordinates-ellipsoid-height global-point-coordinates))
 246                                :destination-cs (cdr (assoc :cartesian-system image-data-alist)))))
 247      image-data-alist)))
 248
 249 (defun in-image-p (m n)
 250   "Check if m, n lay inside *image-size*."
 251   (and m n (<= 0 m (first *image-size*)) (<= 0 n (second *image-size*))))
 252
 253 (defun sections (table &key (start 0) (end most-positive-fixnum))
 254   "Return list of distinct pairs of vnk, nnk found in table in
 255 current database."
 256   (query (:limit (:order-by (:select 'vnk 'nnk
 257                                      :from table
 258                                      :group-by 'vnk 'nnk)
 259                             'vnk 'nnk)
 260                  (- end start) start)))
 261
 262 (defun stations (table vnk nnk &optional (step 1))
 263   "Return a list of plists of :longitude, :latitude,
 264 :ellipsoid-height, :station, :azimuth of stations step metres apart
 265 between vnk and nnk."
 266   (query
 267    (:order-by
 268     (:select (:as (:st_x 't1.the-geom) 'longitude)
 269              (:as (:st_y 't1.the-geom) 'latitude)
 270              (:as (:st_z 't1.the-geom) 'ellipsoid-height)
 271              (:as 't1.nk-station 'station)
 272              (:as (:st_azimuth 't1.the-geom 't2.the-geom) 'azimuth)
 273              :from (:as table 't1)
 274              :left-join (:as table 't2)
 275              :on (:and (:= 't1.nk-station (:- 't2.nk-station 1))
 276                        (:= 't2.vnk vnk)
 277                        (:= 't2.nnk nnk))
 278              :where (:and (:= 't1.vnk vnk)
 279                           (:= 't1.nnk nnk)
 280                           (:= 0 (:% 't1.nk-station step))))
 281     't1.nk-station)
 282    :plists))
 283
 284 (defun-cached all-stations (table vnk nnk)
 285   "Return a vector of coordinates of all points between vnk and nnk,
 286 station (in metres) being the vector index."
 287   (let* ((stations (stations table vnk nnk))
 288          (result (make-array (list (1+ (getf (first (last stations)) :station)))
 289                              :initial-element nil)))
 290     (loop
 291        for i in stations
 292        do (destructuring-bind (&key longitude latitude ellipsoid-height station azimuth)
 293               i
 294             (setf (svref result station)
 295                   (make-coordinates :longitude longitude
 296                                     :latitude latitude
 297                                     :ellipsoid-height ellipsoid-height
 298                                     :azimuth azimuth))))
 299     result))
 300
 301 (defun-cached road-section-image-data (table vnk nnk step rear-view-p)
 302   "Return a list of instances of image data corresponding to stations,
 303 which are step metres apart, found in table in current database."
 304   (remove nil (mapcar #'(lambda (x)
 305                           (apply #'image-data :rear-view-p rear-view-p x))
 306                       (stations table vnk nnk step))))
 307
 308 (defun cache-file-name (kind &rest args)
 309   "Return pathname for a cache file distinguishable by kind and args."
 310   (make-pathname :directory *cache-dir*
 311                  :name (format nil "~{~:[f~;~:*~(~A~)~]_~}~A"
 312                                args
 313                                *fasttrack-version*)
 314                  :type (string-downcase kind)))
 315
 316 ;; (defun road-section-image-data-pathname (vnk nnk step rear-view-p)
 317 ;;   "Return pathname of a cached set of image data between vnk and nnk,
 318 ;; step metres apart."
 319 ;;   (make-pathname :directory *cache-dir*
 320 ;;                  :name (format nil "~A_~A_~D_~:[f~;r~]_~A"
 321 ;;                                vnk nnk step rear-view-p
 322 ;;                                *fasttrack-version*)
 323 ;;                  :type "image-data"))
 324
 325 (defun cache-images (road-section-image-data)
 326   "Download images described in road-section-image-data into their
 327 canonical places."
 328   (loop
 329      for i in road-section-image-data
 330      do (download-image i)))
 331
 332 (defun get-image-data (road-section-image-data station step)
 333   "Return image data for the image near station."
 334   (find (* step (round station step)) road-section-image-data
 335         :key #'image-data-station
 336         :test #'=))
 337
 338 (defun get-image-namestring (road-section-image-data station step)
 339   "Return path to image near station.  Download it if necessary."
 340   (let ((image-data (get-image-data road-section-image-data station step)))
 341     (when image-data (namestring (download-image image-data)))))
 342
 343 (defun get-image-data-alist (road-section-image-data station step)
 344   "Return as an alist data for the image near station."
 345   (image-data-alist (get-image-data road-section-image-data station step)))
 346
 347 (defun image-data (&key longitude latitude ellipsoid-height station azimuth rear-view-p)
 348   "Get from Phoros server image data for location near longitude,
 349 latitude."
 350   (let* ((coordinates (make-coordinates :longitude longitude
 351                                         :latitude latitude
 352                                         :ellipsoid-height ellipsoid-height
 353                                         :azimuth azimuth))
 354          (image-data (phoros-nearest-image-data coordinates rear-view-p)))
 355     (when (image-data-p image-data)
 356       (setf (image-data-station image-data) station)
 357       (setf (image-data-station-coordinates image-data) coordinates)
 358       image-data)))
 359
 360 (define-condition phoros-server-error (error)
 361    ((body :reader body :initarg :body)
 362     (status-code :reader status-code :initarg :status-code)
 363     (headers :reader headers :initarg :headers)
 364     (url :reader url :initarg :url)
 365     (reason-phrase :reader reason-phrase :initarg :reason-phrase))
 366   (:report (lambda (condition stream)
 367              (format stream "Can't connect to Phoros server: ~A (~D)"
 368                      (reason-phrase condition) (status-code condition)))))
 369
 370 (defun phoros-lib-url (canonical-url suffix)
 371   "Replace last path element of canonical-url by lib/<suffix>."
 372   (let* ((old-path (puri:uri-parsed-path canonical-url))
 373          (new-path (append (butlast old-path) (list "lib" suffix)))
 374          (new-url (puri:copy-uri canonical-url)))
 375     (setf (puri:uri-parsed-path new-url) new-path)
 376     new-url))
 377
 378 (defun phoros-login (url user-name user-password)
 379   "Log into Phoros server; return T if successful.  Try logging out
 380 first."
 381   (setf *phoros-url* (puri:parse-uri url))
 382   (setf drakma:*allow-dotless-cookie-domains-p* t)
 383   (setf drakma:*text-content-types* (acons "application" "json" drakma:*text-content-types*))
 384   (phoros-logout)
 385   (setf *phoros-cookies* (make-instance 'drakma:cookie-jar))
 386   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
 387       (drakma:http-request *phoros-url* :cookie-jar *phoros-cookies*)
 388     (declare (ignore stream must-close))
 389     (assert (= status-code 200) ()
 390             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
 391     (multiple-value-bind (body status-code headers authenticate-url stream must-close reason-phrase)
 392         (drakma:http-request (phoros-lib-url *phoros-url* "authenticate")
 393                              :cookie-jar *phoros-cookies*
 394                              :form-data t
 395                              :method :post
 396                              :parameters (pairlis '("user-name" "user-password")
 397                                                   (list user-name user-password)))
 398       (declare (ignore stream must-close))
 399       (assert (< status-code 400) ()
 400               'phoros-server-error :body body :status-code status-code :headers headers :url authenticate-url :reason-phrase reason-phrase)
 401       (= status-code 302))))
 402
 403 (defun phoros-logout ()
 404   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
 405       (drakma:http-request (phoros-lib-url *phoros-url* "logout")
 406                            :cookie-jar *phoros-cookies*)
 407     (declare (ignore stream must-close))
 408     (assert (= status-code 200) ()
 409             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)))
 410
 411 (defun heading (azimuth rear-view-p)
 412   "Return as a string the one of east, west, north, south which best
 413 describes azimuth."
 414   (cond ((<= (* 1/4 pi) azimuth (* 3/4 pi)) (if rear-view-p "west" "east"))
 415         ((<= (* 3/4 pi) azimuth (* 5/4 pi)) (if rear-view-p "north" "south"))
 416         ((<= (* 5/4 pi) azimuth (* 7/4 pi)) (if rear-view-p "east" "west"))
 417         ((or (<= (* 5/4 pi) azimuth pi) (<= 0 (* 1/4 pi))) (if rear-view-p "south" "north"))))
 418
 419 (defun phoros-nearest-image-data (coordinates rear-view-p)
 420   "Return a set of image-data."
 421   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
 422       (drakma:http-request (phoros-lib-url *phoros-url* "nearest-image-data")
 423                            :cookie-jar *phoros-cookies*
 424                            :method :post
 425                            :content-type "text/plain; charset=UTF-8"
 426                            :content (json:encode-json-plist-to-string (list :longitude (coordinates-longitude coordinates)
 427                                                                             :latitude (coordinates-latitude coordinates)
 428                                                                             :zoom 20
 429                                                                             :count 1
 430                                                                             :selected-restriction-ids (vector "Device_21" (heading (coordinates-azimuth coordinates) rear-view-p))))) ;TODO: document requirement for restrictions tagged north, east, south, west, and front_cam; actually use the latter
 431     (declare (ignore stream must-close))
 432     (assert (= status-code 200) ()
 433             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
 434     (unless (string-equal body "null")
 435       (apply #'make-image-data :allow-other-keys t
 436              (plist-from-alist
 437               (car (json:decode-json-from-string body)))))))
 438
 439 (defun download-file (url path)
 440   "Unless already there, store content from url under path.  Return
 441 nil if nothing needed storing."
 442   (ensure-directories-exist path)
 443   (with-open-file (file-stream path :direction :output
 444                                :element-type 'unsigned-byte
 445                                :if-exists nil)
 446     (when file-stream
 447       (multiple-value-bind
 448             (body status-code headers url stream must-close reason-phrase)
 449           (drakma:http-request url
 450                                :cookie-jar *phoros-cookies*
 451                                :method :get)
 452         (declare (ignore stream must-close))
 453         (assert (= status-code 200) ()
 454                 'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
 455         (write-sequence body file-stream)
 456         reason-phrase))))
 457
 458 (defun download-image (image-data)
 459   "If not already there, download a png image, shrink it, convert it
 460 into jpg, and store it under the cache path.  Return that path."
 461   (multiple-value-bind (url origin-path destination-path)
 462       (image-url image-data)
 463     (unless (probe-file destination-path)
 464       (download-file url origin-path)
 465       (apply #'convert-image-file origin-path destination-path *image-size*)
 466       (delete-file origin-path))
 467     destination-path))
 468
 469 (defstruct coordinates
 470   longitude
 471   latitude
 472   ellipsoid-height
 473   azimuth)
 474
 475 (eval `(defstruct image-data
 476          ;; fasttrack auxiliary slots
 477          station
 478          station-coordinates
 479          (rear-view-p nil)
 480          ;; original Phoros image data slots
 481          ,@(mapcar #'ensure-hyphen-before-digit *aggregate-view-columns*)))
 482
 483 (defun image-data-alist (image-data)
 484   "Return an alist representation of image-data."
 485   (when image-data
 486     (loop
 487        for i in (append (mapcar #'ensure-hyphen-before-digit *aggregate-view-columns*) '(station station-coordinates))
 488        collect (intern (string i) 'keyword) into keys
 489        collect (funcall (intern (concatenate 'string (string 'image-data-)
 490                                              (string i)))
 491                         image-data)
 492        into values
 493        finally (return (pairlis keys values)))))
 494
 495 (defun plist-from-alist (alist)
 496   (loop
 497      for (key . value) in alist
 498      collect key
 499      collect value))
 500
 501 (defun image-url (image-data)
 502   "Return an image URL made from ingredients found in image-data, the
 503 corresponding cache path, and the corresponding cache path for the
 504 shrunk image."
 505   (let* ((path
 506           (format nil "~A/~A~A/~D.png"
 507                   (puri:uri-path (phoros-lib-url *phoros-url* "photo"))
 508                   (image-data-directory image-data)
 509                   (image-data-filename image-data)
 510                   (image-data-byte-position image-data)))
 511          (query
 512           (format nil "mounting-angle=~D~
 513                        &bayer-pattern=~{~D~#^,~}~
 514                        &color-raiser=~{~D~#^,~}"
 515                   (image-data-mounting-angle image-data)
 516                   (map 'list #'identity (image-data-bayer-pattern image-data))
 517                   (map 'list #'identity (image-data-color-raiser image-data))))
 518          (url (puri:copy-uri *phoros-url* :path path :query query))
 519          (host (puri:uri-host url))
 520          (port (puri:uri-port url))
 521          (cache-directory (append *cache-dir*
 522                                   (list (format nil "~A_~D" host port))
 523                                   (cdr (pathname-directory (puri:uri-path url)))))
 524          (cache-name (pathname-name (puri:uri-path url)))
 525          (cache-type (pathname-type (puri:uri-path url))))
 526     (values url
 527             (make-pathname :directory cache-directory
 528                            :name cache-name
 529                            :type cache-type)
 530             (make-pathname :directory cache-directory
 531                            :name cache-name
 532                            :type "jpg"))))
 533
 534 (defun convert-image-file (origin-file destination-file width height)
 535   "Convert origin-file into destination-file of a maximum size of
 536 width x height."
 537   (lisp-magick:with-magick-wand (wand :load (namestring origin-file))
 538     (let ((a (/ (lisp-magick:magick-get-image-width wand)
 539                 (lisp-magick:magick-get-image-height wand))))
 540       (if (> a (/ width height))
 541           (lisp-magick:magick-scale-image wand width (truncate (/ width a)))
 542           (lisp-magick:magick-scale-image wand (truncate (* a height)) height)))
 543     (lisp-magick:magick-write-image wand (namestring destination-file))))
 544
 545 (defun convert-image-coordinates (original-coordinates-alist image-data-alist)
 546   "Convert image coordinates from original-coordinates-alist for the
 547 image in image-data-alist into a list of coordinates for that image
 548 scaled and centered to *image-size*."
 549   (let* ((original-m (cdr (assoc :m original-coordinates-alist)))
 550          (original-n (cdr (assoc :n original-coordinates-alist)))
 551          (original-width (cdr (assoc :sensor-width-pix image-data-alist)))
 552          (original-height (cdr (assoc :sensor-height-pix image-data-alist)))
 553          (new-width (first *image-size*))
 554          (new-height (second *image-size*))
 555          (scaling-factor (min (/ new-width original-width) (/ new-height original-height)))
 556          (new-m-offset (/ (- new-width (* original-width scaling-factor)) 2))
 557          (new-n-offset (/ (- new-height (* original-height scaling-factor)) 2))
 558          (new-m (+ (* original-m scaling-factor) new-m-offset))
 559          (new-n (- new-height           ;flip n
 560                    (+ (* original-n scaling-factor) new-n-offset))))
 561     (list new-m new-n)))