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 ".menubar.file" "<<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" ".menubar.file" "<<check.blah>>" :data (lit "$check")))
 130
 131     (tcl "grid" (tcl[ "ttk::frame" ".f" :padding "3 3 12 12") :column 0 :row 0 :sticky "nwes")
 132
 133     ;; (tcl "event" "generate" "." "<<boom>>" :data "Blahbla")
 134
 135     (tcl "set" "chart1" (tcl[ "canvas" ".f.chart1" :bg "yellow" :scrollregion "0 0 2500 400" :xscrollcommand ".f.h set"))
 136
 137     (tcl "grid" (tcl[ "canvas" ".f.image1" :bg "black" (mapcan #'list '(:width :height) *image-size*)) :column 0 :row 0 :sticky "nwes")
 138     (tcl "grid" (tcl[ "canvas" ".f.image2" :bg "black" (mapcan #'list '(:width :height) *image-size*)) :column 1 :row 0 :sticky "nwes")
 139     (tcl "grid" (lit "$chart1") :column 0 :row 1 :sticky "nwes" :columnspan 2)
 140     (tcl "grid" (tcl[ "tk::scrollbar" ".f.h" :orient "horizontal" :command ".f.chart1 xview") :column 0 :row 3 :sticky "we" :columnspan 2)
 141     (tcl "grid" (tcl[ "ttk::label" ".f.l1" :background "grey") :column 0 :row 2 :sticky "nwes")
 142     (tcl "grid" (tcl[ "ttk::label" ".f.l2" :textvariable "meters" :background "red") :column 1 :row 2 :sticky "nwes")
 143
 144
 145     (tcl ".f.chart1" "create" "line" '(30 30 40 40 50 30 600 40) :fill "red" :tags "lll")
 146     (tcl ".f.chart1" "scale" "lll" 0 0 .1 1)
 147
 148     (tcl "image" "create" "photo" "rear-view")
 149     (tcl "image" "create" "photo" "front-view")
 150
 151     (tcl ".f.image1" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "rear-view")
 152     (tcl ".f.image2" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "front-view")
 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     (tcl ".f.chart1" "bind" (lit "$ppp") "<ButtonPress-1>"
 170          ;; Some canvasx voodoo required, possibly involving virtual events
 171          (event-handler
 172           #'(lambda (xx)
 173               (progn (tcl "set" "meters" xx)
 174                      (tcl ".f.chart1" "delete" (lit "$cursor"))
 175                      (tcl "set" "cursor" (tcl[ ".f.chart1" "create" "line" xx 0 xx 100))
 176                      (tcl "rear-view" "configure" :file (or (get-image-namestring (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100 t)
 177                                                                                   (parse-integer xx)
 178                                                                                   100)
 179                                                             "public_html/phoros-logo-plain.png"))
 180                      (print xx)
 181                      (print (svref (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011") (parse-integer xx)))
 182                      (print (ignore-errors
 183                               (photogrammetry :reprojection
 184                                               (get-image-data-alist (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100 t)
 185                                                                     (parse-integer xx)
 186                                                                     100)
 187                                               (pairlis '(:x-global :y-global :z-global)
 188                                                        (proj:cs2cs
 189                                                         (list
 190                                                          (proj:degrees-to-radians
 191                                                           (coordinates-longitude (svref (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011") (parse-integer xx))))
 192                                                          (proj:degrees-to-radians
 193                                                           (coordinates-latitude (svref (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011") (parse-integer xx))))
 194                                                          (coordinates-ellipsoid-height (svref (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011") (parse-integer xx))))
 195                                                         :destination-cs (cdr (assoc :cartesian-system (get-image-data-alist (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100 t)
 196                                                                                                                             (parse-integer xx)
 197                                                                                                                             100))))))))
 198                      (tcl "front-view" "configure" :file (or (get-image-namestring (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100 nil)
 199                                                                                    (parse-integer xx)
 200                                                                                    100)
 201                                                              "public_html/phoros-logo-background.png"))
 202                      (print (ignore-errors
 203                               (photogrammetry :reprojection
 204                                               (get-image-data-alist (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100 nil)
 205                                                                     (parse-integer xx)
 206                                                                     100)
 207                                               (pairlis '(:x-global :y-global :z-global)
 208                                                        (proj:cs2cs
 209                                                         (list
 210                                                          (proj:degrees-to-radians
 211                                                           (coordinates-longitude (svref (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011") (parse-integer xx))))
 212                                                          (proj:degrees-to-radians
 213                                                           (coordinates-latitude (svref (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011") (parse-integer xx))))
 214                                                          (coordinates-ellipsoid-height (svref (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011") (parse-integer xx))))
 215                                                         :destination-cs (cdr (assoc :cartesian-system (get-image-data-alist (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100 nil)
 216                                                                                                                             (parse-integer xx)
 217                                                                                                                             100))))))))))
 218           '(#\x)))
 219
 220     ;; (bind-event ".f.chart1" "<ButtonPress-1>" ((xx #\x))
 221     ;;   (progn (tcl "set" "meters" xx)
 222     ;;          (tcl ".f.chart1" "delete" (lit "$cursor"))
 223     ;;          (tcl "set" "cursor" (tcl[ ".f.chart1" "create" "line" xx 0 xx 100))
 224     ;;          (tcl "rear-view" "configure" :file (get-image-namestring (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100)
 225     ;;                                                                 (parse-integer xx)
 226     ;;                                                                 100))
 227     ;;          (tcl "front-view" "configure" :file (get-image-namestring (road-section-image-data 'bew-landstr-kleinpunkte "4252017" "4252011" 100)
 228     ;;                                                                 (parse-integer xx)
 229     ;;                                                                 100))))
 230
 231
 232     ;; (tcl "grid" (tcl[ "ttk::entry" ".f.feet" :width 7 :textvariable "feet") :column 2 :row 1 :sticky "we")
 233     ;; (tcl "grid" (tcl[ "ttk::label" ".f.meters" :textvariable "meters") :column 2 :row 2 :sticky "we")
 234     ;; (tcl "grid" (tcl[ "ttk::button" ".f.calc" :text "Calculate" :command "calculate") :column 3 :row 3 :sticky "w")
 235     ;; (tcl "grid" (tcl[ "ttk::label" ".f.flbl" :text "feet") :column 3 :row 1 :sticky "w")
 236     ;; (tcl "grid" (tcl[ "ttk::label" ".f.islbl" :text "is equivalent to") :column 1 :row 2 :sticky "e")
 237     ;; (tcl "grid" (tcl[ "ttk::label" ".f.mlbl" :text "meters") :column 3 :row 2 :sticky "w")
 238     ;; (tcl "foreach w [ winfo children .f ] {grid configure $w -padx 5 -pady 5}")
 239     ;; (tcl "focus" ".f.feet")
 240
 241     (mainloop)))
 242
 243
 244
 245 (defun sections (table &key (start 0) (end most-positive-fixnum))
 246   "Return list of distinct pairs of vnk, nnk found in table in
 247 current database."
 248   (query (:limit (:order-by (:select 'vnk 'nnk
 249                                      :from table
 250                                      :group-by 'vnk 'nnk)
 251                             'vnk 'nnk)
 252                  (- end start) start)))
 253
 254 (defun stations (table vnk nnk &optional (step 1))
 255   "Return a list of plists of :longitude, :latitude,
 256 :ellipsoid-height, :station, :azimuth of stations step metres apart
 257 between vnk and nnk."
 258   (query
 259    (:order-by
 260     (:select (:as (:st_x 't1.the-geom) 'longitude)
 261              (:as (:st_y 't1.the-geom) 'latitude)
 262              (:as (:st_z 't1.the-geom) 'ellipsoid-height)
 263              (:as 't1.nk-station 'station)
 264              (:as (:st_azimuth 't1.the-geom 't2.the-geom) 'azimuth)
 265              :from (:as table 't1)
 266              :left-join (:as table 't2)
 267              :on (:and (:= 't1.nk-station (:- 't2.nk-station 1))
 268                        (:= 't2.vnk vnk)
 269                        (:= 't2.nnk nnk))
 270              :where (:and (:= 't1.vnk vnk)
 271                           (:= 't1.nnk nnk)
 272                           (:= 0 (:% 't1.nk-station step))))
 273     't1.nk-station)
 274    :plists))
 275
 276 (defun-cached all-stations (table vnk nnk)
 277   "Return a vector of coordinates of all points between vnk and nnk,
 278 station (in metres) being the vector index."
 279   (let* ((stations (stations table vnk nnk))
 280          (result (make-array (list (1+ (getf (first (last stations)) :station)))
 281                              :initial-element nil)))
 282     (loop
 283        for i in stations
 284        do (destructuring-bind (&key longitude latitude ellipsoid-height station azimuth)
 285               i
 286             (setf (svref result station)
 287                   (make-coordinates :longitude longitude
 288                                     :latitude latitude
 289                                     :ellipsoid-height ellipsoid-height
 290                                     :azimuth azimuth))))
 291     result))
 292
 293 (defun-cached road-section-image-data (table vnk nnk step rear-view-p)
 294   "Return a list of instances of image data corresponding to stations,
 295 which are step metres apart, found in table in current database."
 296   (remove nil (mapcar #'(lambda (x)
 297                           (apply #'image-data :rear-view-p rear-view-p x))
 298                       (stations table vnk nnk step))))
 299
 300 (defun cache-file-name (kind &rest args)
 301   "Return pathname for a cache file distinguishable by kind and args."
 302   (make-pathname :directory *cache-dir*
 303                  :name (format nil "~{~:[f~;~:*~(~A~)~]_~}~A"
 304                                args
 305                                *fasttrack-version*)
 306                  :type (string-downcase kind)))
 307
 308 ;; (defun road-section-image-data-pathname (vnk nnk step rear-view-p)
 309 ;;   "Return pathname of a cached set of image data between vnk and nnk,
 310 ;; step metres apart."
 311 ;;   (make-pathname :directory *cache-dir*
 312 ;;                  :name (format nil "~A_~A_~D_~:[f~;r~]_~A"
 313 ;;                                vnk nnk step rear-view-p
 314 ;;                                *fasttrack-version*)
 315 ;;                  :type "image-data"))
 316
 317 (defun cache-images (road-section-image-data)
 318   "Download images described in image data into their canonical places."
 319   (loop
 320      for i in road-section-image-data
 321      do (download-image i)))
 322
 323 (defun get-image-data (road-section-image-data station step)
 324   "Return image data for the image near station."
 325   (find (* step (round station step)) road-section-image-data
 326         :key #'image-data-station
 327         :test #'=))
 328
 329 (defun get-image-namestring (road-section-image-data station step)
 330   "Return path to image near station.  Download it if necessary."
 331   (let ((image-data (get-image-data road-section-image-data station step)))
 332     (when image-data (namestring (download-image image-data)))))
 333
 334 (defun get-image-data-alist (road-section-image-data station step)
 335   "Return as an alist data for the image near station."
 336   (image-data-alist (get-image-data road-section-image-data station step)))
 337
 338 (defun image-data (&key longitude latitude ellipsoid-height station azimuth rear-view-p)
 339   "Get from Phoros server image data for location near longitude,
 340 latitude."
 341   (let* ((coordinates (make-coordinates :longitude longitude
 342                                         :latitude latitude
 343                                         :ellipsoid-height ellipsoid-height
 344                                         :azimuth azimuth))
 345          (image-data (phoros-nearest-image-data coordinates rear-view-p)))
 346     (when (image-data-p image-data)
 347       (setf (image-data-station image-data) station)
 348       (setf (image-data-station-coordinates image-data) coordinates)
 349       image-data)))
 350
 351 (define-condition phoros-server-error (error)
 352    ((body :reader body :initarg :body)
 353     (status-code :reader status-code :initarg :status-code)
 354     (headers :reader headers :initarg :headers)
 355     (url :reader url :initarg :url)
 356     (reason-phrase :reader reason-phrase :initarg :reason-phrase))
 357   (:report (lambda (condition stream)
 358              (format stream "Can't connect to Phoros server: ~A (~D)"
 359                      (reason-phrase condition) (status-code condition)))))
 360
 361 (defun phoros-lib-url (canonical-url suffix)
 362   "Replace last path element of canonical-url by lib/<suffix>."
 363   (let* ((old-path (puri:uri-parsed-path canonical-url))
 364          (new-path (append (butlast old-path) (list "lib" suffix)))
 365          (new-url (puri:copy-uri canonical-url)))
 366     (setf (puri:uri-parsed-path new-url) new-path)
 367     new-url))
 368
 369 (defun phoros-login (url user-name user-password)
 370   "Log into Phoros server; return T if successful.  Try logging out
 371 first."
 372   (setf *phoros-url* (puri:parse-uri url))
 373   (setf drakma:*allow-dotless-cookie-domains-p* t)
 374   (setf drakma:*text-content-types* (acons "application" "json" drakma:*text-content-types*))
 375   (phoros-logout)
 376   (setf *phoros-cookies* (make-instance 'drakma:cookie-jar))
 377   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
 378       (drakma:http-request *phoros-url* :cookie-jar *phoros-cookies*)
 379     (declare (ignore stream must-close))
 380     (assert (= status-code 200) ()
 381             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
 382     (multiple-value-bind (body status-code headers authenticate-url stream must-close reason-phrase)
 383         (drakma:http-request (phoros-lib-url *phoros-url* "authenticate")
 384                              :cookie-jar *phoros-cookies*
 385                              :form-data t
 386                              :method :post
 387                              :parameters (pairlis '("user-name" "user-password")
 388                                                   (list user-name user-password)))
 389       (declare (ignore stream must-close))
 390       (assert (< status-code 400) ()
 391               'phoros-server-error :body body :status-code status-code :headers headers :url authenticate-url :reason-phrase reason-phrase)
 392       (= status-code 302))))
 393
 394 (defun phoros-logout ()
 395   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
 396       (drakma:http-request (phoros-lib-url *phoros-url* "logout")
 397                            :cookie-jar *phoros-cookies*)
 398     (declare (ignore stream must-close))
 399     (assert (= status-code 200) ()
 400             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)))
 401
 402 (defun heading (azimuth rear-view-p)
 403   "Return as a string the one of east, west, north, south which best
 404 describes azimuth."
 405   (cond ((<= (* 1/4 pi) azimuth (* 3/4 pi)) (if rear-view-p "west" "east"))
 406         ((<= (* 3/4 pi) azimuth (* 5/4 pi)) (if rear-view-p "north" "south"))
 407         ((<= (* 5/4 pi) azimuth (* 7/4 pi)) (if rear-view-p "east" "west"))
 408         ((or (<= (* 5/4 pi) azimuth pi) (<= 0 (* 1/4 pi))) (if rear-view-p "north" "south"))))
 409
 410 (defun phoros-nearest-image-data (coordinates rear-view-p)
 411   "Return a set of image-data."
 412   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
 413       (drakma:http-request (phoros-lib-url *phoros-url* "nearest-image-data")
 414                            :cookie-jar *phoros-cookies*
 415                            :method :post
 416                            :content-type "text/plain; charset=UTF-8"
 417                            :content (json:encode-json-plist-to-string (list :longitude (coordinates-longitude coordinates)
 418                                                                             :latitude (coordinates-latitude coordinates)
 419                                                                             :zoom 20
 420                                                                             :count 1
 421                                                                             :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
 422     (declare (ignore stream must-close))
 423     (assert (= status-code 200) ()
 424             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
 425     (unless (string-equal body "null")
 426       (apply #'make-image-data :allow-other-keys t
 427              (plist-from-alist
 428               (print (car (json:decode-json-from-string body))))))))
 429
 430 (defun download-file (url path)
 431   "Unless already there, store content from url under path.  Return
 432 nil if nothing needed storing."
 433   (ensure-directories-exist path)
 434   (with-open-file (file-stream path :direction :output
 435                                :element-type 'unsigned-byte
 436                                :if-exists nil)
 437     (when file-stream
 438       (multiple-value-bind
 439             (body status-code headers url stream must-close reason-phrase)
 440           (drakma:http-request url
 441                                :cookie-jar *phoros-cookies*
 442                                :method :get)
 443         (declare (ignore stream must-close))
 444         (assert (= status-code 200) ()
 445                 'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
 446         (write-sequence body file-stream)
 447         reason-phrase))))
 448
 449 (defun download-image (image-data)
 450   "If not already there, download a png image, shrink it, convert it
 451 into jpg, and store it under the cache path.  Return that path."
 452   (multiple-value-bind (url origin-path destination-path)
 453       (image-url image-data)
 454     (unless (probe-file destination-path)
 455       (download-file url origin-path)
 456       (apply #'convert-image-file origin-path destination-path *image-size*)
 457       (delete-file origin-path))
 458     destination-path))
 459
 460 (defstruct coordinates
 461   longitude
 462   latitude
 463   ellipsoid-height
 464   azimuth)
 465
 466 (eval `(defstruct image-data
 467          ;; fasttrack auxiliary slots
 468          station
 469          station-coordinates
 470          (rear-view-p nil)
 471          ;; original Phoros image data slots
 472          ,@(mapcar #'ensure-hyphen-before-digit *aggregate-view-columns*)))
 473
 474 (defun image-data-alist (image-data)
 475   "Return an alist representation of image-data."
 476   (when image-data
 477     (loop
 478        for i in (append (mapcar #'ensure-hyphen-before-digit *aggregate-view-columns*) '(station station-coordinates))
 479        collect (intern (string i) 'keyword) into keys
 480        collect (funcall (intern (concatenate 'string (string 'image-data-)
 481                                              (string i)))
 482                         image-data)
 483        into values
 484        finally (return (pairlis keys values)))))
 485
 486 (defun plist-from-alist (alist)
 487   (loop
 488      for (key . value) in alist
 489      collect key
 490      collect value))
 491
 492 (defun image-url (image-data)
 493   "Return an image URL made from ingredients found in image-data, the
 494 corresponding cache path, and the corresponding cache path for the
 495 shrunk image."
 496   (let* ((path
 497           (format nil "~A/~A~A/~D.png"
 498                   (puri:uri-path (phoros-lib-url *phoros-url* "photo"))
 499                   (image-data-directory image-data)
 500                   (image-data-filename image-data)
 501                   (image-data-byte-position image-data)))
 502          (query
 503           (format nil "mounting-angle=~D~
 504                      &bayer-pattern=~{~D~#^,~}~
 505                      &color-raiser=~{~D~#^,~}"
 506                   (image-data-mounting-angle image-data)
 507                   (map 'list #'identity (image-data-bayer-pattern image-data))
 508                   (map 'list #'identity (image-data-color-raiser image-data))))
 509          (url (puri:copy-uri *phoros-url* :path path :query query))
 510          (host (puri:uri-host url))
 511          (port (puri:uri-port url))
 512          (cache-directory (append *cache-dir*
 513                                   (list (format nil "~A_~D" host port))
 514                                   (cdr (pathname-directory (puri:uri-path url)))))
 515          (cache-name (pathname-name (puri:uri-path url)))
 516          (cache-type (pathname-type (puri:uri-path url))))
 517     (values url
 518             (make-pathname :directory cache-directory
 519                            :name cache-name
 520                            :type cache-type)
 521             (make-pathname :directory cache-directory
 522                            :name cache-name
 523                            :type "jpg"))))
 524
 525 (defun convert-image-file (origin-file destination-file width height)
 526   "Convert origin-file into destination-file of a maximum size of
 527 width x height."
 528   (lisp-magick:with-magick-wand (wand :load (namestring origin-file))
 529     (let ((a (/ (lisp-magick:magick-get-image-width wand)
 530                 (lisp-magick:magick-get-image-height wand))))
 531       (if (> a (/ width height))
 532           (lisp-magick:magick-scale-image wand width (truncate (/ width a)))
 533           (lisp-magick:magick-scale-image wand (truncate (* a height)) height)))
 534     (lisp-magick:magick-write-image wand (namestring destination-file))))