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 :phoros))
  36   "Fasttrack version as defined in system definition.  TODO: enforce equality with *phoros-version*")
  37
  38 (defvar *postgresql-road-network-credentials* nil
  39   "A list: (database user password host &key (port 5432) use-ssl).")
  40
  41 (defvar *postgresql-road-network-table* "phoros_project_aux_point"
  42   "Name of table or view in database described by
  43   *postgresql-road-network-credentials*")
  44
  45 (defvar *postgresql-zeb-credentials* nil
  46   "A list: (database user password host &key (port 5432) use-ssl).")
  47
  48 (defvar *postgresql-zeb-table* "zeb"
  49   "Name of table or view in database described by
  50   *postgresql-zeb-credentials*")
  51
  52 (defvar *road-network-chart-configuration* nil
  53   "Database columns selected for rendering.")
  54
  55 (defvar *zeb-chart-configuration* nil
  56   "Database columns selected for rendering.")
  57
  58 (defvar *accidents-chart-configuration* nil
  59   "Accidents rendering parameters.")
  60
  61 (defvar *postgresql-accidents-credentials* nil
  62   "A list: (database user password host &key (port 5432) use-ssl).")
  63
  64 (defvar *postgresql-accidents-table* "unfaelle"
  65   "Name of table or view in database described by
  66   *postgresql-accidents-credentials*")
  67
  68 (defvar *road-section* nil
  69   "If there is a chart, we store a list of its parameters (table vnk
  70   nnk road-section-length) here.")
  71
  72 (defparameter *aggregate-view-columns*
  73   (list 'usable
  74         'recorded-device-id                ;debug
  75         'device-stage-of-life-id           ;debug
  76         'generic-device-id                 ;debug
  77         'directory
  78         'measurement-id
  79         'filename 'byte-position 'point-id
  80         'trigger-time
  81         ;;'coordinates   ;the search target
  82         'longitude 'latitude 'ellipsoid-height
  83         'cartesian-system
  84         'east-sd 'north-sd 'height-sd
  85         'roll 'pitch 'heading
  86         'roll-sd 'pitch-sd 'heading-sd
  87         'sensor-width-pix 'sensor-height-pix
  88         'pix-size
  89         'bayer-pattern 'color-raiser
  90         'mounting-angle
  91         'dx 'dy 'dz 'omega 'phi 'kappa
  92         'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
  93         'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
  94         'b-ddx 'b-ddy 'b-ddz
  95         'b-drotx 'b-droty 'b-drotz)
  96   "Most of the column names of aggregate-view.")
  97
  98 (defvar *phoros-cookies* nil
  99   "Container for cookies sent by Phoros server")
 100
 101 (defvar *phoros-url* nil
 102   "URL of the Phoros project currently in use.")
 103
 104 (defvar *phoros-credentials* '("user" "password")
 105   "List of (user password) used for login at *phoros-url*.")
 106
 107 (defvar *cache-dir* '(:absolute "home" "bertb" "lisphack" "phoros" "cache"))
 108 ;; TODO: invent cache validity checks
 109
 110 (defparameter *image-size* '(800 800)
 111   "Image size in pixels in a list (width height).")
 112
 113 (defparameter *chart-height* 200
 114   "Height of chart in pixels.")
 115
 116 (defvar *jump-to-station-event* nil
 117   "Remembering event id of chart click event jumptostation.")
 118
 119 (defvar *choose-road-section-event* nil)
 120
 121 (defun ensure-hyphen-before-digit (symbol)
 122   "Return symbol with hyphens inserted after each letter that is
 123 followed by a digit. "
 124   (intern
 125    (coerce
 126     (loop
 127        with need-hyphen-before-next-digit-p
 128        for c across (string symbol)
 129        if (and need-hyphen-before-next-digit-p (digit-char-p c))
 130        collect #\- and collect c and do (setf need-hyphen-before-next-digit-p nil)
 131        else collect c and do (setf need-hyphen-before-next-digit-p nil)
 132        end
 133        if (alpha-char-p c) do (setf need-hyphen-before-next-digit-p t) end)
 134     'string)))
 135
 136 (defmacro defun-cached (name (&rest args) &body body &aux (doc ""))
 137   "Define a function whose return value must be readibly printable, is
 138   being read from a chache if possible, and is being cached if
 139   necessary.  The function defined has a secondary return value
 140   cached-p.  If function is called with :from-cache-only t, let it
 141   return nil and nil if there is nothing cached."
 142   (when (stringp (car body))
 143     (setf doc (car body))
 144     (setf body (cdr body)))
 145   (cl-utilities:with-unique-names (input-stream output-stream)
 146     `(defun ,name (,@args &key from-cache-only)
 147        ,doc
 148        (ensure-directories-exist (cache-file-name ',name ,@args))
 149        (with-open-file (,input-stream (cache-file-name ',name ,@args)
 150                                       :direction :input
 151                                       :if-does-not-exist nil)
 152          (if ,input-stream
 153              (values (read ,input-stream) t)
 154              (values (unless from-cache-only
 155                        (with-open-file (,output-stream (cache-file-name ',name ,@args)
 156                                                        :direction :output)
 157                          (prin1 (progn ,@body)
 158                                 ,output-stream)))
 159                      nil))))))
 160
 161 (eval '(defstruct coordinates
 162         longitude
 163         latitude
 164         ellipsoid-height
 165         azimuth))
 166
 167 (eval `(defstruct image-data
 168          ;; fasttrack auxiliary slots
 169          station
 170          station-coordinates
 171          (rear-view-p nil)
 172          ;; original Phoros image data slots
 173          ,@(mapcar #'ensure-hyphen-before-digit *aggregate-view-columns*)))
 174
 175 (defun main ()
 176   (in-package #:phoros-fasttrack) ;for reading of cached #S(...) forms
 177   (cffi:use-foreign-library phoml)
 178   (restore-credentials)
 179   (restore-chart-configuration)
 180   (restore-road-section)
 181   (apply #'phoros-login *phoros-url* *phoros-credentials*)
 182   (with-tk ((make-instance 'ffi-tk))
 183     (tcl "package" "require" "Img")
 184     (tcl "option" "add" "*tearOff" 0)
 185     (tcl "wm" "title" "." "Phoros Fasttrack")
 186     (tcl "menu" ".menubar")
 187     (tcl "." "configure" :menu ".menubar")
 188     (tcl "menu" ".menubar.file")
 189     (tcl ".menubar" "add" "cascade" :label "File" :menu ".menubar.file" :underline 0)
 190     (tcl ".menubar.file" "add" "command" :label "credentials..." :command (event-handler* (credentials-dialog)))
 191     (tcl ".menubar.file" "add" "command" :label "road section..." :command (event-handler* (road-section-dialog)))
 192     (tcl ".menubar.file" "add" "command" :label "chart configuration..." :command (event-handler* (chart-dialog)))
 193     (tcl ".menubar.file" "add" "command" :label "Kaputt" :command (tcl{ "destroy" "."))
 194
 195     (tcl "grid" (tcl[ "ttk::frame" ".f" :borderwidth 3 :relief "groove") :column 0 :row 0 :sticky "nwes")
 196
 197     (tcl "set" "chart1" (tcl[ "canvas" ".f.chart1" :xscrollcommand ".f.h set" :height *chart-height*))
 198
 199     (tcl "grid" (tcl[ "canvas" ".f.rearview" :background "black" (mapcan #'list '(:width :height) *image-size*)) :column 0 :row 0 :sticky "nwes")
 200     (tcl "grid" (tcl[ "canvas" ".f.frontview" :background "black" (mapcan #'list '(:width :height) *image-size*)) :column 1 :row 0 :sticky "nwes")
 201     (tcl "grid" (lit "$chart1") :column 0 :row 1 :sticky "nwes" :columnspan 2)
 202     (tcl "grid" (tcl[ "tk::scrollbar" ".f.h" :orient "horizontal" :command ".f.chart1 xview") :column 0 :row 2 :sticky "we" :columnspan 2)
 203     (tcl "grid" (tcl[ "ttk::label" ".f.l1" :background "grey") :column 0 :row 3 :sticky "nwes")
 204     (tcl "grid" (tcl[ "ttk::label" ".f.l2" :textvariable "meters" :background "red") :column 1 :row 3 :sticky "nwes")
 205
 206
 207     (tcl "image" "create" "photo" "rearview")
 208     (tcl "image" "create" "photo" "frontview")
 209
 210     (tcl ".f.rearview" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "rearview")
 211     (tcl ".f.frontview" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "frontview")
 212
 213     (tcl "set" "chartbackground" (tcl[ ".f.chart1" "create" "rectangle" 0 0 0 *chart-height* :width 0 :fill "white" :tags "clickablechart"))
 214
 215     ;; (tcl "set" "ppp" (tcl ".f.chart1" "create" "line"
 216     ;;                       (loop
 217     ;;                          for coordinates across (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011")
 218     ;;                          for i from 0
 219     ;;                          when coordinates collect i and collect (format nil "~F" (* (- (coordinates-longitude coordinates) 14) 500)))
 220     ;;                       :fill "green" :width 10))
 221     ;; (loop
 222     ;;    for coordinates across (all-stations 'bew-landstr-kleinpunkte "4252017" "4252011")
 223     ;;    for i from 0
 224     ;;    when coordinates do (tcl ".f.chart1" "create" "oval" i (format nil "~F" (coordinates-longitude coordinates)) i (format nil "~F" (coordinates-longitude coordinates))))
 225
 226     ;; (tcl ".f.chart1" "create" "line" 100 100 100 100 :capstyle "round" :width 5) ;a point
 227
 228     ;; (tcl ".f.chart1" "bind" (lit "$chartbackground") "<ButtonPress-1>" "event generate . <<jumptostation>> -data [.f.chart1 canvasx %x]")
 229     (tcl ".f.chart1" "bind" "clickablechart" "<ButtonPress-1>" "event generate . <<jumptostation>> -data [.f.chart1 canvasx %x]")
 230
 231     ;; (tcl "foreach w [ winfo children .f ] {grid configure $w -padx 5 -pady 5}")
 232     ;; (tcl "focus" ".f.feet")
 233     (refresh-chart)
 234     (mainloop)))
 235
 236 (defun road-network-data (column vnk nnk chart-height)
 237   "Return a list of lists of station and column values between vnk
 238 and nnk scaled into chart-height; the minimum column value; and the
 239 maximum column value.  Both minimum and maximum are nil if data is
 240 constant."
 241   (with-connection *postgresql-road-network-credentials*
 242     (setf column (intern (string-upcase column)))
 243     (destructuring-bind (minimum maximum)
 244         (mapcar #'(lambda (x) (if (numberp x)
 245                                   (coerce x 'double-float)
 246                                   x))
 247                 (query (:select (:min column)
 248                                 (:max column)
 249                                 :from (intern *postgresql-road-network-table*)
 250                                 :where (:and (:= 'vnk vnk)
 251                                              (:= 'nnk nnk)))
 252                        :list))
 253       (if (and (numberp minimum) (numberp maximum))
 254           (let* ((span (- maximum minimum))
 255                  (m (if (zerop span)
 256                         0
 257                         (/ chart-height span)))
 258                  (b (if (zerop span)
 259                         (* chart-height 1/2)
 260                         (+ chart-height (* m minimum)))))
 261             (values
 262              (mapcar #'(lambda (x) (if (numberp x)
 263                                        (coerce x 'double-float)
 264                                        x))
 265                      (query (:order-by
 266                              (:select 'nk-station
 267                                       (:- b (:* m column))
 268                                       :from (intern *postgresql-road-network-table*)
 269                                       :where (:and (:= 'vnk vnk)
 270                                                    (:= 'nnk nnk)))
 271                              'nk-station)))
 272              (unless (zerop span) minimum)
 273              (unless (zerop span) maximum)))
 274           (values nil nil nil)))))
 275
 276 (defun zeb-data (column vnk nnk chart-height)
 277   "Return a list of lists of station and column values between vnk
 278 and nnk scaled into chart-height; the minimum column value; and the
 279 maximum column value.  Both minimum and maximum are nil if data is
 280 constant."
 281   (with-connection *postgresql-zeb-credentials*
 282     (setf column (intern (string-upcase column)))
 283     (destructuring-bind (minimum maximum)
 284         (mapcar #'(lambda (x) (if (numberp x)
 285                                   (coerce x 'double-float)
 286                                   x))
 287                 (query (:select (:min column)
 288                                 (:max column)
 289                                 :from (intern *postgresql-zeb-table*)
 290                                 :where (:and (:= 'vnk vnk)
 291                                              (:= 'nnk nnk)))
 292                        :list))
 293       (if (and (numberp minimum) (numberp maximum))
 294           (let* ((span (- maximum minimum))
 295                  (m (if (zerop span)
 296                         0
 297                         (/ chart-height span)))
 298                  (b (if (zerop span)
 299                         (* chart-height 1/2)
 300                         (+ chart-height (* m minimum)))))
 301             (values
 302              (mapcar #'(lambda (x) (if (numberp x)
 303                                        (coerce x 'double-float)
 304                                        x))
 305                      (query (:order-by
 306                              (:select 'vst
 307                                       (:- b (:* m column))
 308                                       'bst
 309                                       (:- b (:* m column))
 310                                       :from (intern *postgresql-zeb-table*)
 311                                       :where (:and (:= 'vnk vnk)
 312                                                    (:= 'nnk nnk)))
 313                              'vst)))
 314              (unless (zerop span) minimum)
 315              (unless (zerop span) maximum)))
 316           (values nil nil nil)))))
 317
 318 (defun accidents-data (vnk nnk &key
 319                        (year-min most-negative-fixnum)
 320                        (year-max most-positive-fixnum))
 321   "Return a list of plists containing accident data for the road
 322 section between vnk and nnk."
 323   (with-connection *postgresql-accidents-credentials*
 324     (query (:order-by
 325             (:select 'nk-station 'unfalltyp 'unfallkategorie 'alkohol
 326                      :from (intern *postgresql-accidents-table*)
 327                      :where (:and (:= 'vnk vnk)
 328                                   (:= 'nnk nnk)
 329                                   (:between 'jahr year-min year-max)))
 330             'nk-station 'jahr 'monat 'tag 'stunde 'minuten)
 331            :plists)))
 332
 333 (defun road-section-dialog ()
 334   (tcl "tk::toplevel" ".choose-road-section")
 335   (tcl "set" "chooseroadsectiontree" (tcl[ "ttk::treeview" ".choose-road-section.tree" :columns "length number-of-images" :yscrollcommand ".choose-road-section.v set" :height 40))
 336   (tcl "grid" (lit "$chooseroadsectiontree") :column 0 :row 0 :sticky "nwes")
 337   (tcl "grid" (tcl[ "tk::scrollbar" ".choose-road-section.v" :orient "vertical" :command ".choose-road-section.tree yview") :column 1 :row 0 :sticky "ns")
 338   (tcl "grid" (tcl[ "ttk::button" ".choose-road-section.close-button" :text "close" :command (event-handler* (print *choose-road-section-event*)
 339                                                                                                              (unregister-event *choose-road-section-event*)
 340                                                                                                              (tcl "destroy" ".choose-road-section")))
 341        :column 0 :row 1)
 342   (tcl ".choose-road-section.tree" "heading" "length" :text "m")
 343   (tcl ".choose-road-section.tree" "column" "length" :width 50 :anchor "e")
 344
 345   (with-connection *postgresql-road-network-credentials*
 346     (let ((sections (sections (make-symbol *postgresql-road-network-table*))))
 347       (loop
 348          for (vnk nnk length) in sections
 349          do (multiple-value-bind (rearview-image-data rearview-cached-p)
 350                 (road-section-image-data (provenience-string *phoros-url*) *postgresql-road-network-table* vnk nnk 10 t :from-cache-only t)
 351               (multiple-value-bind (frontview-image-data frontview-cached-p)
 352                   (road-section-image-data (provenience-string *phoros-url*) *postgresql-road-network-table* vnk nnk 10 nil :from-cache-only t)
 353                 (add-vnk-nnk-leaf vnk nnk length (and rearview-cached-p frontview-cached-p (+ (length rearview-image-data) (length frontview-image-data))))))))
 354     (setf *choose-road-section-event*
 355           (bind-event ".choose-road-section.tree" "<ButtonPress-1>" ()
 356             (let ((vnk-nnk-length (read-from-string (tcl ".choose-road-section.tree" "focus"))))
 357               (save-station nil)
 358               (apply #'prepare-chart (make-symbol *postgresql-road-network-table*) vnk-nnk-length))))
 359     (focus-vnk-nnk-leaf))
 360   (mainloop))
 361
 362 (defun credentials-dialog ()
 363   (flet ((send-credentials (purpose)
 364            (tcl{ "event" "generate" ".credentials-dialog" "<<credentials>>"
 365                  :data (tcl[ "list"
 366                              (string purpose)
 367                              (lit "$roadnetworkdatabase") (lit "$roadnetworkhost") (lit "$roadnetworkport") (lit "$roadnetworkusessl") (lit "$roadnetworktable") (lit "$roadnetworkuser") (lit "$roadnetworkpassword")
 368                              (lit "$zebdatabase") (lit "$zebhost") (lit "$zebport") (lit "$zebusessl") (lit "$zebtable") (lit "$zebuser") (lit "$zebpassword")
 369                              (lit "$accidentsdatabase") (lit "$accidentshost") (lit "$accidentsport") (lit "$accidentsusessl") (lit "$accidentstable") (lit "$accidentsuser") (lit "$accidentspassword")
 370                              (lit "$phorosurl") (lit "$phorosuser") (lit "$phorospassword")))))
 371
 372     (tcl "tk::toplevel" ".credentials-dialog")
 373
 374     (tcl "grid" (tcl[ "ttk::labelframe" ".credentials-dialog.db" :text "database credentials") :column 0 :row 0 :columnspan 5 :sticky "w")
 375     (tcl "grid" (tcl[ "ttk::labelframe" ".credentials-dialog.phoros" :text "phoros credentials") :column 0 :row 1 :sticky "w")
 376
 377     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.hosts" :text "host" :font "TkHeadingFont") :column 0 :row 1 :sticky "w")
 378     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.ports" :text "port" :font "TkHeadingFont") :column 0 :row 2 :sticky "w")
 379     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.use-ssls" :text "ssl" :font "TkHeadingFont") :column 0 :row 3 :sticky "w")
 380     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.databases" :text "database" :font "TkHeadingFont") :column 0 :row 4 :sticky "w")
 381     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.tables" :text "table" :font "TkHeadingFont") :column 0 :row 5 :sticky "w")
 382     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.users" :text "user" :font "TkHeadingFont") :column 0 :row 6 :sticky "w")
 383     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.passwords" :text "password" :font "TkHeadingFont") :column 0 :row 7 :sticky "w")
 384     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.status" :text "status" :font "TkHeadingFont") :column 0 :row 8 :sticky "w")
 385
 386     (destructuring-bind (database user password host &key (port 5432) (use-ssl :no))
 387         *postgresql-road-network-credentials*
 388       (tcl "set" "roadnetworkhost" host)
 389       (tcl "set" "roadnetworkport" port)
 390       (tcl "set" "roadnetworkusessl" (string use-ssl))
 391       (tcl "set" "roadnetworkdatabase" database)
 392       (tcl "set" "roadnetworktable" *postgresql-road-network-table*)
 393       (tcl "set" "roadnetworkuser" user)
 394       (tcl "set" "roadnetworkpassword" password))
 395     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.road-network-header" :text "road network" :width 30 :font "TkHeadingFont") :column 1 :row 0 :sticky "w")
 396     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-host" :textvariable "roadnetworkhost") :column 1 :row 1 :sticky "we")
 397     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-port" :textvariable "roadnetworkport") :column 1 :row 2 :sticky "we")
 398     (tcl "grid" (tcl[ "ttk::checkbutton" ".credentials-dialog.db.roadnetwork-use-ssl" :variable "roadnetworkusessl" :onvalue "yes" :offvalue "no") :column 1 :row 3 :sticky "w")
 399     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-database" :textvariable "roadnetworkdatabase") :column 1 :row 4 :sticky "we")
 400     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-table" :textvariable "roadnetworktable") :column 1 :row 5 :sticky "we")
 401     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-user" :textvariable "roadnetworkuser") :column 1 :row 6 :sticky "we")
 402     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-password" :textvariable "roadnetworkpassword") :column 1 :row 7 :sticky "we")
 403     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.road-network-status" :text "?") :column 1 :row 8 :sticky "w")
 404
 405     (destructuring-bind (database user password host &key (port 5432) (use-ssl :no))
 406         *postgresql-zeb-credentials*
 407       (tcl "set" "zebhost" host)
 408       (tcl "set" "zebport" port)
 409       (tcl "set" "zebusessl" (string use-ssl))
 410       (tcl "set" "zebdatabase" database)
 411       (tcl "set" "zebtable" *postgresql-zeb-table*)
 412       (tcl "set" "zebuser" user)
 413       (tcl "set" "zebpassword" password))
 414     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.zeb-header" :text "ZEB" :width 30 :font "TkHeadingFont") :column 2 :row 0 :sticky "w")
 415     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-host" :textvariable "zebhost") :column 2 :row 1 :sticky "we")
 416     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-port" :textvariable "zebport") :column 2 :row 2 :sticky "we")
 417     (tcl "grid" (tcl[ "ttk::checkbutton" ".credentials-dialog.db.zeb-use-ssl" :variable "zebusessl" :onvalue "yes" :offvalue "no") :column 2 :row 3 :sticky "w")
 418     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-database" :textvariable "zebdatabase") :column 2 :row 4 :sticky "we")
 419     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-table" :textvariable "zebtable") :column 2 :row 5 :sticky "we")
 420     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-user" :textvariable "zebuser") :column 2 :row 6 :sticky "we")
 421     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-password" :textvariable "zebpassword") :column 2 :row 7 :sticky "we")
 422     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.zeb-status" :text "?") :column 2 :row 8 :sticky "w")
 423
 424     (destructuring-bind (database user password host &key (port 5432) (use-ssl :no))
 425         *postgresql-accidents-credentials*
 426       (tcl "set" "accidentshost" host)
 427       (tcl "set" "accidentsport" port)
 428       (tcl "set" "accidentsusessl" (string use-ssl))
 429       (tcl "set" "accidentsdatabase" database)
 430       (tcl "set" "accidentstable" *postgresql-accidents-table*)
 431       (tcl "set" "accidentsuser" user)
 432       (tcl "set" "accidentspassword" password))
 433     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.accidents-header" :text "accidents" :width 30 :font "TkHeadingFont") :column 3 :row 0 :sticky "w")
 434     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-host" :textvariable "accidentshost") :column 3 :row 1 :sticky "we")
 435     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-port" :textvariable "accidentsport") :column 3 :row 2 :sticky "we")
 436     (tcl "grid" (tcl[ "ttk::checkbutton" ".credentials-dialog.db.accidents-use-ssl" :variable "accidentsusessl" :onvalue "yes" :offvalue "no") :column 3 :row 3 :sticky "w")
 437     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-database" :textvariable "accidentsdatabase") :column 3 :row 4 :sticky "we")
 438     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-table" :textvariable "accidentstable") :column 3 :row 5 :sticky "we")
 439     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-user" :textvariable "accidentsuser") :column 3 :row 6 :sticky "we")
 440     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-password" :textvariable "accidentspassword") :column 3 :row 7 :sticky "we")
 441     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.accidents-status" :text "?") :column 3 :row 8 :sticky "w")
 442
 443     (destructuring-bind (user password) *phoros-credentials*
 444       (tcl "set" "phorosurl" (with-output-to-string (s) (puri:render-uri *phoros-url* s)))
 445       (tcl "set" "phorosuser" user)
 446       (tcl "set" "phorospassword" password))
 447     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.url" :text "URL" :font "TkHeadingFont") :column 0 :row 0 :sticky "w")
 448     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.user" :text "user" :font "TkHeadingFont") :column 0 :row 1 :sticky "w")
 449     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.password" :text "password" :font "TkHeadingFont") :column 0 :row 2 :sticky "w")
 450     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.status" :text "status" :font "TkHeadingFont") :column 0 :row 3 :sticky "w")
 451     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.phoros.phoros-url" :textvariable "phorosurl" :width 45) :column 1 :row 0)
 452     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.phoros.phoros-user" :textvariable "phorosuser") :column 1 :row 1 :sticky "we")
 453     (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.phoros.phoros-password" :textvariable "phorospassword") :column 1 :row 2 :sticky "we")
 454     (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.phoros-status" :text "?") :column 1 :row 3 :sticky "w")
 455
 456     (bind-event ".credentials-dialog" "<<credentials>>" ((payload #\d))
 457       (let ((purpose (first (cl-utilities:split-sequence #\Space payload))))
 458         (cond ((string-equal purpose "ok")
 459                (apply #'phoros-login *phoros-url* *phoros-credentials*)
 460                (restore-credentials payload)
 461                (tcl "destroy" ".credentials-dialog"))
 462               ((string-equal purpose "save")
 463                (save-credentials payload))
 464               ((string-equal purpose "check")
 465                (let (*postgresql-road-network-credentials*
 466                      *postgresql-zeb-credentials*
 467                      *postgresql-accidents-credentials*)
 468                  (restore-credentials payload)
 469                  (tcl ".credentials-dialog.db.road-network-status" "configure" :text (check-db *postgresql-road-network-credentials* *postgresql-road-network-table*))
 470                  (tcl ".credentials-dialog.db.zeb-status" "configure" :text (check-db *postgresql-zeb-credentials* *postgresql-zeb-table*))
 471                  (tcl ".credentials-dialog.db.accidents-status" "configure" :text (check-db *postgresql-accidents-credentials* *postgresql-accidents-table*))
 472                  (tcl ".credentials-dialog.phoros.phoros-status" "configure" :text (apply #'check-phoros (with-output-to-string (s) (puri:render-uri *phoros-url* s)) *phoros-credentials*)))))))
 473
 474     (tcl "grid" (tcl[ "ttk::button" ".credentials-dialog.cancel-button" :text "cancel" :command (tcl{ "destroy" ".credentials-dialog"))
 475          :column 1 :row 1 :sticky "s")
 476     (tcl "grid" (tcl[ "ttk::button" ".credentials-dialog.save-button" :text "save" :command (send-credentials :save))
 477          :column 2 :row 1 :sticky "s")
 478     (tcl "grid" (tcl[ "ttk::button" ".credentials-dialog.check-button" :text "check" :command (send-credentials :check))
 479          :column 3 :row 1 :sticky "s")
 480     (tcl "grid" (tcl[ "ttk::button" ".credentials-dialog.ok-button" :text "ok" :command (send-credentials :ok))
 481          :column 4 :row 1 :sticky "s")
 482
 483     (tcl ".credentials-dialog.check-button" "invoke")
 484
 485     (mainloop)))
 486
 487 (defun save-credentials (credentials-string)
 488   "Save input from credentials-dialog into cache directory."
 489   (let ((cache-file-name (cache-file-name 'credentials)))
 490     (ensure-directories-exist cache-file-name)
 491     (with-open-file (stream cache-file-name
 492                             :direction :output
 493                             :if-exists :supersede)
 494       (prin1 credentials-string stream))))
 495
 496 (defun restore-credentials (&optional credentials-string)
 497   "Put credentials (from credentials-string if any, or previously
 498 saved by save-credentials if not) into their respective variables."
 499   (let ((cache-file-name (cache-file-name 'credentials)))
 500     (with-open-file (stream cache-file-name
 501                             :direction :input
 502                             :if-does-not-exist nil)
 503       (when (and stream (not credentials-string))
 504         (setf credentials-string (read stream)))
 505       (when credentials-string
 506         (destructuring-bind (purpose road-network-database road-network-host road-network-port road-network-use-ssl road-network-table road-network-user road-network-password
 507                                      zeb-database zeb-host zeb-port zeb-use-ssl zeb-table zeb-user zeb-password
 508                                      accidents-database accidents-host accidents-port accidents-use-ssl accidents-table accidents-user accidents-password
 509                                      phoros-url phoros-user phoros-password)
 510             (cl-utilities:split-sequence #\Space credentials-string)
 511           (declare (ignore purpose))
 512           (setf *postgresql-road-network-credentials*
 513                 (list road-network-database road-network-user road-network-password road-network-host :port (parse-integer road-network-port :junk-allowed t) :use-ssl (intern (string-upcase road-network-use-ssl) 'keyword)))
 514           (setf *postgresql-road-network-table* road-network-table)
 515           (setf *postgresql-zeb-credentials*
 516                 (list zeb-database zeb-user zeb-password zeb-host :port (parse-integer zeb-port :junk-allowed t) :use-ssl (intern (string-upcase zeb-use-ssl) 'keyword)))
 517           (setf *postgresql-zeb-table* zeb-table)
 518           (setf *postgresql-accidents-credentials*
 519                 (list accidents-database accidents-user accidents-password accidents-host :port (parse-integer accidents-port :junk-allowed t) :use-ssl (intern (string-upcase accidents-use-ssl) 'keyword)))
 520           (setf *postgresql-accidents-table* accidents-table)
 521           (setf *phoros-url* (puri:parse-uri phoros-url))
 522           (setf *phoros-credentials* (list phoros-user phoros-password)))))))
 523
 524 (defun save-chart-configuration (chart-configuration-string)
 525   "Save input from chart-dialog into cache directory."
 526   (let ((cache-file-name (cache-file-name 'chart-configuration)))
 527     (ensure-directories-exist cache-file-name)
 528     (with-open-file (stream cache-file-name
 529                             :direction :output
 530                             :if-exists :supersede)
 531       (prin1 chart-configuration-string stream))))
 532
 533 (defun save-road-section (road-section-string)
 534   "Save input from road-section-dialog into cache directory."
 535   (let ((cache-file-name (cache-file-name 'road-section)))
 536     (ensure-directories-exist cache-file-name)
 537     (with-open-file (stream cache-file-name
 538                             :direction :output
 539                             :if-exists :supersede)
 540       (prin1 road-section-string stream))))
 541
 542 (defun save-station (station)
 543   "Save position of chart cursor into cache directory."
 544   (let ((cache-file-name (cache-file-name 'station)))
 545     (ensure-directories-exist cache-file-name)
 546     (with-open-file (stream cache-file-name
 547                             :direction :output
 548                             :if-exists :supersede)
 549       (prin1 station stream))))
 550
 551 (defun saved-station ()
 552   (let ((cache-file-name (cache-file-name 'station))
 553         station)
 554     (ensure-directories-exist cache-file-name)
 555     (with-open-file (stream cache-file-name
 556                             :direction :input
 557                             :if-does-not-exist nil)
 558       (when stream (setf station (read stream)))
 559       (or station 0))))
 560
 561 (defun restore-chart-configuration (&optional chart-configuration-string)
 562   "Put database columns selected for rendering (from
 563 chart-configuration-string if any, or previously saved by
 564 save-chart-configuration if not) into their respective variables."
 565   (let ((cache-file-name (cache-file-name 'chart-configuration)))
 566     (with-open-file (stream cache-file-name
 567                             :direction :input
 568                             :if-does-not-exist nil)
 569       (when (and stream (not chart-configuration-string))
 570         (setf chart-configuration-string (read stream)))
 571       (when chart-configuration-string
 572         (loop
 573            for column-definition on (cdr (cl-utilities:split-sequence #\Space chart-configuration-string)) ;ignore purpose string
 574            by #'(lambda (x) (nthcdr 6 x)) ;by number of values per column definition
 575            for (table-kind column-name selectedp color width dash) = column-definition
 576            when (and (string-equal selectedp "1")
 577                      (string-equal table-kind "roadnetwork"))
 578            collect (list column-name color width dash) into road-network-chart-configuration
 579            when (and (string-equal selectedp "1")
 580                      (string-equal table-kind "zeb"))
 581            collect (list column-name color width dash) into zeb-chart-configuration
 582            when (string-equal table-kind "accidents")
 583            collect (list column-name selectedp) into accidents-chart-configuration ;should be called value rather than selectedp
 584            finally
 585              (setf *road-network-chart-configuration* road-network-chart-configuration)
 586              (setf *zeb-chart-configuration* zeb-chart-configuration)
 587              (setf *accidents-chart-configuration* accidents-chart-configuration))))))
 588
 589 (defun restore-road-section ()
 590   (let ((cache-file-name (cache-file-name 'road-section))
 591         road-section)
 592     (with-open-file (stream cache-file-name
 593                             :direction :input
 594                             :if-does-not-exist nil)
 595       (when stream
 596         (setf road-section (read stream)))
 597       (when road-section
 598         (setf *road-section* road-section)))))
 599
 600 (defun check-db (db-credentials table-name &aux result)
 601   "Check database connection and presence of table or view table-name.
 602 Return a string describing the outcome."
 603   (unless
 604       (ignore-errors
 605         (with-connection db-credentials
 606           (if (or (table-exists-p table-name)
 607                   (view-exists-p table-name))
 608               (setf result "ok")
 609               (setf result "table or view missing"))))
 610     (setf result "connection failure"))
 611   result)
 612
 613 (defun check-phoros (url user-name password)
 614   "Check connection to phoros server.  Return a string describing the
 615 outcome."
 616   (let ((*phoros-url* nil)
 617         (*phoros-cookies* nil))
 618     (unwind-protect
 619          (handler-case (phoros-login url user-name password)
 620            (usocket:ns-host-not-found-error () "host not found")
 621            (usocket:connection-refused-error () "connection refused")
 622            (error (c) (format nil "~A" c))
 623            (:no-error (result) (if result "ok" "wrong user or password")))
 624       (ignore-errors (phoros-logout)))))
 625
 626 (defun chart-dialog ()
 627   (flet ((send-chart-configuration (purpose)
 628            (tcl{ "event" "generate" ".chart-dialog" "<<columnselection>>"
 629                  :data (tcl[ "list"
 630                              (string purpose)
 631                              (with-connection *postgresql-road-network-credentials*
 632                                (loop
 633                                   for (column-name) in (table-description *postgresql-road-network-table*)
 634                                   collect (lit (concatenate 'string "roadnetwork " column-name " $roadnetwork_" column-name " $roadnetwork_" column-name "_color" " $roadnetwork_" column-name "_width" " $roadnetwork_" column-name "_dash"))))
 635                              (with-connection *postgresql-zeb-credentials*
 636                                (loop
 637                                   for (column-name) in (table-description *postgresql-zeb-table*)
 638                                   collect (lit (concatenate 'string "zeb " column-name " $zeb_" column-name " $zeb_" column-name "_color" " $zeb_" column-name "_width" " $zeb_" column-name "_dash"))))
 639                              (lit (concatenate 'string "accidents renderp $accidentsrender nil nil nil"))
 640                              (lit (concatenate 'string "accidents year_min $accidentsyearmin nil nil nil"))
 641                              (lit (concatenate 'string "accidents year_max $accidentsyearmax nil nil nil"))))))
 642     (tcl "tk::toplevel" ".chart-dialog")
 643     (tcl "grid" (tcl[ "tk::text" ".chart-dialog.t" :width 140 :height 50 :xscrollcommand ".chart-dialog.h set" :yscrollcommand ".chart-dialog.v set") :column 0 :row 0)
 644     (tcl "grid" (tcl[ "tk::scrollbar" ".chart-dialog.h" :orient "horizontal" :command ".chart-dialog.t xview") :column 0 :row 1 :sticky "we")
 645     (tcl "grid" (tcl[ "tk::scrollbar" ".chart-dialog.v" :orient "vertical" :command ".chart-dialog.t yview") :column 1 :row 0 :sticky "sn")
 646     (tcl ".chart-dialog.t" "window" "create" "end" :window (tcl[ "ttk::frame" ".chart-dialog.t.f"))
 647     (tcl "grid" (tcl[ "ttk::labelframe" ".chart-dialog.t.f.roadnetwork" :text "road network" :borderwidth 3 :relief "groove") :column 0 :row 0 :sticky "n")
 648     (tcl "grid" (tcl[ "ttk::labelframe" ".chart-dialog.t.f.zeb" :text "ZEB" :borderwidth 3 :relief "groove") :column 1 :row 0 :sticky "n")
 649     (tcl "grid" (tcl[ "ttk::labelframe" ".chart-dialog.t.f.accidents" :text "accidents" :borderwidth 3 :relief "groove") :column 2 :row 0 :sticky "ns")
 650     (tcl "grid" (tcl[ "ttk::frame" ".chart-dialog.buttons") :column 3 :row 0 :sticky "n")
 651     (tcl "grid" (tcl[ "ttk::button" ".chart-dialog.buttons.cancel" :text "cancel" :command (tcl{ "destroy" ".chart-dialog")) :column 0 :row 0)
 652     (tcl "grid" (tcl[ "ttk::button" ".chart-dialog.buttons.save" :text "save" :command (send-chart-configuration :save)) :column 0 :row 1)
 653     (tcl "grid" (tcl[ "ttk::button" ".chart-dialog.buttons.ok" :text "ok" :command (send-chart-configuration :ok)) :column 0 :row 2)
 654
 655     (with-connection *postgresql-road-network-credentials*
 656       (present-db-columns (table-description *postgresql-road-network-table*) ".chart-dialog.t.f.roadnetwork" "roadnetwork_" *road-network-chart-configuration*))
 657     (with-connection *postgresql-zeb-credentials*
 658       (present-db-columns (table-description *postgresql-zeb-table*) ".chart-dialog.t.f.zeb" "zeb_" *zeb-chart-configuration*))
 659
 660     (tcl "set" "accidentsrender" (or (second (find "renderp" *accidents-chart-configuration* :key #'first :test #'string-equal))
 661                                             0))
 662     (tcl "set" "accidentsyearmin" (or (second (find "year_min" *accidents-chart-configuration* :key #'first :test #'string-equal))
 663                                               1999))
 664     (tcl "set" "accidentsyearmax" (or (second (find "year_max" *accidents-chart-configuration* :key #'first :test #'string-equal))
 665                                               2030))
 666     (tcl "grid" (tcl[ "ttk::checkbutton" ".chart-dialog.t.f.accidents.render" :text "render accidents" :variable "accidentsrender") :column 0 :row 0 :columnspan 2 :sticky "w")
 667     (tcl "grid" (tcl[ "ttk::label" ".chart-dialog.t.f.accidents.yearmin_label" :text "from year") :column 0 :row 1 :sticky "w")
 668     (tcl "grid" (tcl[ "tk::spinbox" ".chart-dialog.t.f.accidents.yearmin" :width 4 :from 1000 :to 3000 :textvariable "accidentsyearmin") :column 1 :row 1 :sticky "w")
 669     (tcl "grid" (tcl[ "ttk::label" ".chart-dialog.t.f.accidents.yearmax_label" :text "to year") :column 0 :row 2 :sticky "w")
 670     (tcl "grid" (tcl[ "tk::spinbox" ".chart-dialog.t.f.accidents.yearmax" :width 4 :from 1000 :to 3000 :textvariable "accidentsyearmax") :column 1 :row 2 :sticky "w")
 671
 672
 673     (bind-event ".chart-dialog" "<<columnselection>>" ((payload #\d))
 674       (let ((purpose (first (cl-utilities:split-sequence #\Space payload))))
 675         (cond ((string-equal purpose "ok")
 676                (restore-chart-configuration payload)
 677                (refresh-chart)
 678                (tcl "destroy" ".chart-dialog"))
 679               ((string-equal purpose "save")
 680                (save-chart-configuration payload)))))
 681     (mainloop)))
 682
 683 (defun lit$ (tcl-variable)
 684   (lit (concatenate 'string "$" tcl-variable)))
 685
 686 (defun present-db-columns (columns tcl-path variable-prefix chart-configuration)
 687   (loop
 688      for (column-name type) in columns
 689      ;; name of checkbutton and trunk of the other element's names
 690      for variable-name = (concatenate 'string variable-prefix column-name)
 691      for path-name = (concatenate 'string tcl-path "." column-name)
 692      ;; rest of the input elements
 693      for label-path-name = (concatenate 'string tcl-path "." column-name "_label")
 694      for width-variable-name = (concatenate 'string variable-name "_width")
 695      for width-path-name = (concatenate 'string tcl-path "." column-name "_width")
 696      for color-variable-name = (concatenate 'string variable-name "_color")
 697      for color-path-name = (concatenate 'string tcl-path "." column-name "_color")
 698      for dash-variable-name = (concatenate 'string variable-name "_dash")
 699      for dash-path-name = (concatenate 'string tcl-path "." column-name "_dash")
 700      for sample-path-name = (concatenate 'string tcl-path "." column-name "_sample")
 701      for sample-line-path-name = (concatenate 'string tcl-path "." column-name "_sample_line")
 702      for i from 0
 703      do
 704        (when (zerop (mod i 25))
 705          (let* ((name-header-path-name (concatenate 'string tcl-path "." column-name "_name_header"))
 706                 (type-header-path-name (concatenate 'string tcl-path "." column-name "_type_header"))
 707                 (width-header-path-name (concatenate 'string tcl-path "." column-name "_width_header"))
 708                 (color-header-path-name (concatenate 'string tcl-path "." column-name "_color_header"))
 709                 (dash-header-path-name (concatenate 'string tcl-path "." column-name "_dash_header"))
 710                 (sample-header-path-name (concatenate 'string tcl-path "." column-name "_sample_header")))
 711            (tcl "grid" (tcl[ "ttk::label" name-header-path-name :text "column" :font "TkHeadingFont") :column 0 :row i :sticky "w")
 712            (tcl "grid" (tcl[ "ttk::label" type-header-path-name :text "type" :font "TkHeadingFont") :column 1 :row i :sticky "w")
 713            (tcl "grid" (tcl[ "ttk::label" width-header-path-name :text "width" :font "TkHeadingFont") :column 2 :row i :sticky "w")
 714            (tcl "grid" (tcl[ "ttk::label" color-header-path-name :text "color" :font "TkHeadingFont") :column 3 :row i :sticky "w")
 715            (tcl "grid" (tcl[ "ttk::label" dash-header-path-name :text "dash" :font "TkHeadingFont") :column 4 :row i :sticky "w")
 716            (tcl "grid" (tcl[ "ttk::label" sample-header-path-name :text "sample" :font "TkHeadingFont") :column 5 :row i))
 717          (incf i))
 718        (let ((selected-column (find column-name chart-configuration :key #'first :test #'string-equal)))
 719          (tcl "grid" (tcl[ "ttk::checkbutton" path-name :text column-name :variable variable-name) :column 0 :row i :sticky "w")
 720          (tcl "grid" (tcl[ "ttk::label" label-path-name :text type) :column 1 :row i :sticky "w")
 721          (tcl "grid" (tcl[ "tk::spinbox" width-path-name :width 2 :textvariable width-variable-name :values "1 2 3 4 5 6"
 722                            :state "readonly"
 723                            :command (tcl{ "set" variable-name 1 (lit ";")
 724                                           sample-path-name "itemconfigure" sample-line-path-name :width (lit$ width-variable-name)))
 725               :column 2 :row i)
 726          (tcl "grid" (tcl[ "ttk::button" color-path-name
 727                            :width 1
 728                            :command  (tcl{ "set" "tmp" (tcl[ "tk_chooseColor" :initialcolor (lit$ color-variable-name))
 729                                            (lit ";")
 730                                            (lit "if { $tmp != {}} { set") color-variable-name (lit$ "tmp; set") variable-name 1 (lit "}")
 731                                            (lit ";")
 732                                            sample-path-name "itemconfigure" sample-line-path-name :fill (lit$ color-variable-name)))
 733               :column 3 :row i)
 734          (tcl "grid" (tcl[ "tk::spinbox" dash-path-name :width 2 :textvariable dash-variable-name :values "1 -.-. --- ... "
 735                            :state "readonly"
 736                            :command (tcl{ "set" variable-name 1 (lit ";")
 737                                           sample-path-name "itemconfigure" sample-line-path-name :dash (lit$ dash-variable-name))) :column 4 :row i)
 738
 739          (tcl "grid" (tcl[ "canvas" sample-path-name :background "white" :width 100 :height 20) :column 5 :row i)
 740          (if selected-column
 741              (progn
 742                (tcl "set" variable-name 1)
 743                (tcl "set" color-variable-name (color selected-column))
 744                (tcl "set" width-variable-name (line-width selected-column))
 745                (tcl "set" dash-variable-name (dash selected-column)))
 746              (progn
 747                (tcl "set" variable-name 0)
 748                (tcl "set" color-variable-name "black")
 749                (tcl "set" width-variable-name 2)
 750                (tcl "set" dash-variable-name "1")))
 751          (tcl sample-path-name "create" "line" 0 18 20 2 60 10 100 10 :tags sample-line-path-name :joinstyle "round" :capstyle "round" :fill (lit$ color-variable-name) :width (lit$ width-variable-name) :dash (lit$ dash-variable-name)))))
 752
 753 (defun color (column-definition)
 754   (second column-definition))
 755
 756 (defun line-width (column-definition)
 757   (third column-definition))
 758
 759 (defun dash (column-definition)
 760   (fourth column-definition))
 761
 762 (defun add-vnk-nnk-leaf (vnk nnk length number-of-images)
 763   "Put a leaf labelled vnk-nnk into road-sections tree."
 764   (tcl ".choose-road-section.tree" "insert" "" "end" :id (format nil "(~S ~S ~D)" vnk nnk length) :text (format nil "~A - ~A" vnk nnk) :values (tcl[ "list" length (or number-of-images "?"))))
 765
 766 (defun focus-vnk-nnk-leaf ()
 767   "Focus the leaf corresponding to *road-section*, of road-sections tree."
 768   (let ((vnk (second *road-section*))
 769         (nnk (third *road-section*))
 770         (length (fourth *road-section*)))
 771     (when (and vnk nnk length)
 772       (tcl "update")
 773       (tcl ".choose-road-section.tree" "selection" "set" (format nil "{(~S ~S ~D)}" vnk nnk length))
 774       (tcl ".choose-road-section.tree" "see" (format nil "(~S ~S ~D)" vnk nnk length)))))
 775
 776 (defun prepare-chart (table vnk nnk road-section-length)
 777   "Prepare chart for the road section between vnk and nnk in table in
 778 current database."
 779   (save-road-section
 780    (setf *road-section* (list table vnk nnk road-section-length)))
 781   (when *jump-to-station-event* (unregister-event *jump-to-station-event*))
 782   (tcl ".f.chart1" "configure" :scrollregion (format nil "~D ~D ~D ~D" 0 0 road-section-length *chart-height*))
 783   (tcl ".f.chart1" "coords" (lit "$chartbackground") 0 0 road-section-length *chart-height*)
 784   (draw-graphs vnk nnk)
 785   (tcl "if" (tcl[ "info" "exists" "cursor") (tcl{ ".f.chart1" "delete" (lit "$cursor")))
 786   (tcl "set" "cursor" (tcl[ ".f.chart1" "create" "line" 0 0 0 *chart-height* :width 3 :fill "orange" :dash "3"))
 787   (setf *jump-to-station-event*
 788         (bind-event "." "<<jumptostation>>" ((station #\d))
 789           (save-station
 790            (setf station (max 0   ;appearently necessary; not sure why.
 791                               (round (parse-number:parse-number station)))))
 792           (tcl "set" "meters" station)
 793           (tcl ".f.chart1" "coords" (lit "$cursor") station 0 station *chart-height*)
 794           (put-image :table table :vnk vnk :nnk nnk :station station :step 10 :rear-view-p t)
 795           (put-image :table table :vnk vnk :nnk nnk :station station :step 10 :rear-view-p nil)))
 796   (tcl "event" "generate" "." "<<jumptostation>>" :data (tcl[ ".f.chart1" "canvasx" (saved-station)))
 797   ;; TODO: also scroll to station
 798   )
 799
 800 (defun refresh-chart ()
 801   "Redraw chart."
 802   (when *road-section* (apply #'prepare-chart *road-section*)))
 803
 804 (defun draw-graphs (vnk nnk)
 805   "Draw graphs for the columns in *zeb-chart-configuration*.  Delete
 806 existing graphs first."
 807   (tcl ".f.chart1" "delete" (lit "graph"))
 808   (loop
 809      for (column-name color width dash) in *road-network-chart-configuration*
 810      do (draw-road-network-graph column-name vnk nnk color width dash))
 811   (loop
 812      for (column-name color width dash) in *zeb-chart-configuration*
 813      do (draw-zeb-graph column-name vnk nnk color width dash))
 814   (draw-accidents vnk nnk))
 815
 816 (defun draw-road-network-graph (column vnk nnk color width dash)
 817   (multiple-value-bind (line minimum maximum)
 818       (road-network-data column vnk nnk *chart-height*)
 819     (let ((line-fragments
 820            (cl-utilities:split-sequence-if #'(lambda (x)
 821                                                (eq (second x) :null))
 822                                            line
 823                                            :remove-empty-subseqs t)))
 824       (print (list :column column :min minimum :max maximum :color color :width width :dash dash))
 825       (dolist (line-fragment line-fragments)
 826         (tcl ".f.chart1" "create" "line"  (format nil "~:{~F ~F ~}" line-fragment) :tags "graph clickablechart" :joinstyle "round" :capstyle "round" :fill color :width width :dash dash)))))
 827
 828 (defun draw-zeb-graph (column vnk nnk color width dash)
 829   (multiple-value-bind (line minimum maximum)
 830       (zeb-data column vnk nnk *chart-height*)
 831     (let ((line-fragments
 832            (cl-utilities:split-sequence-if #'(lambda (x)
 833                                                (eq (second x) :null))
 834                                            line
 835                                            :remove-empty-subseqs t)))
 836       (print (list :column column :min minimum :max maximum :color color :width width :dash dash))
 837       (dolist (line-fragment line-fragments)
 838         (tcl ".f.chart1" "create" "line" (format nil "~:{~F ~F ~}" line-fragment) :tags "graph clickablechart" :joinstyle "round" :capstyle "round" :fill color :width width :dash dash)))))
 839
 840 (defun draw-accidents (vnk nnk)
 841   (when (string-equal (second (find "renderp" *accidents-chart-configuration* :key #'first :test #'string-equal))
 842                       "1")
 843     (let* ((year-min (second (find "year_min" *accidents-chart-configuration* :key #'first :test #'string-equal)))
 844            (year-max (second (find "year_max" *accidents-chart-configuration* :key #'first :test #'string-equal)))
 845            (accidents (accidents-data vnk nnk :year-min year-min :year-max year-max))
 846            (current-station -1)
 847            (y-position 5))
 848       (dolist (accident accidents)
 849         (if (= current-station (getf accident :nk-station))
 850             (incf y-position 10)
 851             (progn (setf y-position 10)
 852                    (setf current-station (getf accident :nk-station))))
 853         (draw-accident accident y-position)))))
 854
 855 (defun draw-accident (accident y-position)
 856   "Put graphical representation of accident on chart."
 857   (destructuring-bind (&key nk-station unfalltyp unfallkategorie alkohol)
 858       accident
 859     (when (plusp alkohol) (draw-triangle nk-station y-position "lightblue"))
 860     (case unfallkategorie
 861       (1 (draw-rectangle nk-station y-position 10 "black")
 862          (draw-circle nk-station y-position 8 (accident-type-color unfalltyp)))
 863       (2 (draw-circle nk-station y-position 8 (accident-type-color unfalltyp)))
 864       (3 (draw-circle nk-station y-position 6 (accident-type-color unfalltyp)))
 865       (4 (draw-circle nk-station y-position 6 "white")
 866          (draw-circle nk-station y-position 4 (accident-type-color unfalltyp)))
 867       (5 (draw-circle nk-station y-position 4 (accident-type-color unfalltyp)))
 868       (6 (draw-triangle nk-station y-position "lightblue")
 869          (draw-circle nk-station y-position 4 (accident-type-color unfalltyp)))
 870       (t (draw-circle nk-station y-position 4 (accident-type-color unfalltyp))))))
 871
 872 (defun draw-circle (x y diameter color)
 873   (tcl ".f.chart1" "create" "oval" (rectangle-coordinates x y diameter) :tags "graph clickablechart" :fill color))
 874
 875 (defun draw-rectangle (x y diameter color)
 876   (tcl ".f.chart1" "create" "rectangle" (rectangle-coordinates x y diameter) :tags "graph clickablechart" :fill color))
 877
 878 (defun draw-triangle (x y color)
 879   (let ((triangle-coordinates
 880          (list (- x 3) (- y 6) (+ x 3) (- y 6) x (+ y 9))))
 881     (tcl ".f.chart1" "create" "polygon" triangle-coordinates :tags "graph clickablechart" :fill color :outline "black")))
 882
 883 (defun accident-type-color (accident-type)
 884   (case accident-type
 885     (1 "green")
 886     (2 "yellow")
 887     (3 "red")
 888     (4 "white")
 889     (5 "lightblue")
 890     (6 "orange")
 891     (7 "black")
 892     (t "darkblue")))
 893
 894 (defun rectangle-coordinates (x y diameter)
 895   (let ((radius (/ diameter 2)))
 896     (list (- x radius) (- y radius) (+ x radius) (+ y radius))))
 897
 898 (defun put-image (&key table vnk nnk station step rear-view-p)
 899   "Put an image along with a labelled station marker on screen."
 900   (with-connection *postgresql-road-network-credentials*
 901     (let* ((point-radius 5)
 902            (line-width 2)
 903            (photo (if rear-view-p "rearview" "frontview"))
 904            (canvas (concatenate 'string ".f." photo))
 905            (cursor-name (concatenate 'string photo "cursor"))
 906            (label-name (concatenate 'string photo "label"))
 907            (arrow-name (concatenate 'string photo "arrow"))
 908            (global-point-coordinates
 909             (subseq (all-stations table vnk nnk)
 910                     (min (length (all-stations table vnk nnk)) station)
 911                     (min (length (all-stations table vnk nnk)) (+ station 4))))
 912            (image-data-alist
 913             (get-image-data-alist (road-section-image-data (provenience-string *phoros-url*) table vnk nnk step rear-view-p)
 914                                   station
 915                                   step))
 916            (image-arrow-coordinates
 917             (loop
 918                for i across global-point-coordinates
 919                append (image-point-coordinates image-data-alist i)))
 920            (image-cursor-coordinates (ignore-errors
 921                                        (list (- (first image-arrow-coordinates) point-radius)
 922                                              (- (second image-arrow-coordinates) point-radius)
 923                                              (+ (first image-arrow-coordinates) point-radius)
 924                                              (+ (second image-arrow-coordinates) point-radius))))
 925            (image-label-coordinates  (ignore-errors
 926                                        (list (+ (first image-arrow-coordinates) point-radius line-width)
 927                                              (second image-arrow-coordinates)))))
 928       (tcl photo "configure" :file (or (get-image-namestring (road-section-image-data (provenience-string *phoros-url*) table vnk nnk step rear-view-p)
 929                                                              station
 930                                                              step)
 931                                        "public_html/phoros-logo-plain.png"))
 932       (tcl "if" (tcl[ "info" "exists" cursor-name) (tcl{ canvas "delete" (lit (concatenate 'string "$" cursor-name))))
 933       (tcl "if" (tcl[ "info" "exists" label-name) (tcl{ canvas "delete" (lit (concatenate 'string "$" label-name))))
 934       (tcl "if" (tcl[ "info" "exists" arrow-name) (tcl{ canvas "delete" (lit (concatenate 'string "$" arrow-name))))
 935       (when image-cursor-coordinates
 936         (tcl "set" cursor-name (tcl[ canvas "create" "oval" image-cursor-coordinates :width line-width)))
 937       (when image-label-coordinates
 938         (tcl "set" label-name (tcl[ canvas "create" "text" image-label-coordinates :text station :anchor "w")))
 939       (when (and image-arrow-coordinates
 940                  (loop
 941                     for tail on image-arrow-coordinates by #'cddr
 942                     always (in-image-p (first tail) (second tail))))
 943         (tcl "set" arrow-name (tcl[ canvas "create" "line" image-arrow-coordinates :arrow "last" :width line-width))))))
 944
 945 (defun image-point-coordinates (image-data-alist global-point-coordinates)
 946   "Return a list (m n) of image coordinates representing
 947 global-point-coordinates in the image described in image-data-alist
 948 but scaled to fit into *image-size*."
 949   (ignore-errors
 950     (convert-image-coordinates
 951      (photogrammetry :reprojection
 952                      image-data-alist
 953                      (pairlis '(:x-global :y-global :z-global)
 954                               (proj:cs2cs
 955                                (list
 956                                 (proj:degrees-to-radians
 957                                  (coordinates-longitude global-point-coordinates))
 958                                 (proj:degrees-to-radians
 959                                  (coordinates-latitude global-point-coordinates))
 960                                 (coordinates-ellipsoid-height global-point-coordinates))
 961                                :destination-cs (cdr (assoc :cartesian-system image-data-alist)))))
 962      image-data-alist)))
 963
 964 (defun in-image-p (m n)
 965   "Check if m, n lay inside *image-size*."
 966   (and m n (<= 0 m (first *image-size*)) (<= 0 n (second *image-size*))))
 967
 968 (defun-cached sections (table)
 969   "Return list of distinct pairs of vnk, nnk found in table in
 970 current database."
 971   (query (:order-by (:select 'vnk 'nnk (:max 'nk-station)
 972                              :from table
 973                              :where (:and (:not-null 'vnk) (:not-null 'nnk))
 974                              :group-by 'vnk 'nnk)
 975                     'vnk 'nnk)))
 976
 977 (defun stations (table vnk nnk &optional (step 1))
 978   "Return a list of plists of :longitude, :latitude,
 979 :ellipsoid-height, :station, :azimuth of stations step metres apart
 980 between vnk and nnk."
 981   (let ((stations
 982          (query
 983           (:order-by
 984            (:select (:as (:st_x 't1.the-geom) 'longitude)
 985                     (:as (:st_y 't1.the-geom) 'latitude)
 986                     (:as (:st_z 't1.the-geom) 'ellipsoid-height)
 987                     (:as 't1.nk-station 'station)
 988                     (:as (:st_azimuth 't1.the-geom 't2.the-geom) 'azimuth)
 989                     :from (:as table 't1)
 990                     :left-join (:as table 't2)
 991                     :on (:and (:= 't1.nk-station (:- 't2.nk-station 1))
 992                               (:= 't2.vnk vnk)
 993                               (:= 't2.nnk nnk))
 994                     :where (:and (:= 't1.vnk vnk)
 995                                  (:= 't1.nnk nnk)
 996                                  (:= 0 (:% 't1.nk-station step))))
 997            't1.nk-station)
 998           :plists)))
 999     (setf
1000      (getf (nth (- (length stations) 1) stations) :azimuth)
1001      (getf (nth (- (length stations) 2) stations) :azimuth))
1002     stations))
1003
1004 (defun-cached all-stations (table vnk nnk)
1005   "Return a vector of coordinates of all points between vnk and nnk,
1006 station (in metres) being the vector index."
1007   (let* ((stations (stations table vnk nnk))
1008          (result (make-array (list (1+ (getf (first (last stations)) :station)))
1009                              :initial-element nil)))
1010     (loop
1011        for i in stations
1012        do (destructuring-bind (&key longitude latitude ellipsoid-height station azimuth)
1013               i
1014             (setf (svref result station)
1015                   (make-coordinates :longitude longitude
1016                                     :latitude latitude
1017                                     :ellipsoid-height ellipsoid-height
1018                                     :azimuth azimuth))))
1019     result))
1020
1021 (defun-cached road-section-image-data (provenience-string table vnk nnk step rear-view-p)
1022   "Return a list of instances of image data corresponding to stations,
1023 which are step metres apart, found in table in current database.
1024 provenience-string only serves as a marker of the provenience of image
1025 data once cached."
1026   (remove nil ;; (mapcar #'(lambda (x)
1027           ;;             (apply #'image-data :rear-view-p rear-view-p x))
1028           ;;         (stations table vnk nnk step))
1029           (loop
1030              with azimuth-fallback = nil
1031              for station in (stations table vnk nnk step)
1032              when (not (eq (getf station :azimuth) :null))
1033              do (setf azimuth-fallback (getf station :azimuth))
1034              and collect (apply #'image-data :rear-view-p rear-view-p station)
1035              end
1036              when (and azimuth-fallback
1037                        (eq (getf station :azimuth) :null))
1038              do (setf (getf station :azimuth) azimuth-fallback)
1039              and collect (apply #'image-data :rear-view-p rear-view-p station))))
1040
1041 (defun provenience-string (url)
1042   "Turn url recognisably into something suitable as part of a file
1043 name."
1044   (format nil "~A_~A~{_~A~}"
1045           (puri:uri-host url)
1046           (puri:uri-port url)
1047           (cl-utilities:split-sequence
1048            #\/ (puri:uri-path url) :remove-empty-subseqs t)))
1049
1050 (defun cache-file-name (kind &rest args)
1051   "Return pathname for a cache file distinguishable by kind and args."
1052   (make-pathname :directory *cache-dir*
1053                  :name (format nil "~{~:[f~;~:*~(~A~)~]_~}~A"
1054                                args
1055                                *fasttrack-version*)
1056                  :type (string-downcase kind)))
1057
1058 ;; (defun road-section-image-data-pathname (vnk nnk step rear-view-p)
1059 ;;   "Return pathname of a cached set of image data between vnk and nnk,
1060 ;; step metres apart."
1061 ;;   (make-pathname :directory *cache-dir*
1062 ;;                  :name (format nil "~A_~A_~D_~:[f~;r~]_~A"
1063 ;;                                vnk nnk step rear-view-p
1064 ;;                                *fasttrack-version*)
1065 ;;                  :type "image-data"))
1066
1067 (defun cache-images (road-section-image-data)
1068   "Download images described in road-section-image-data into their
1069 canonical places."
1070   (loop
1071      for i in road-section-image-data
1072      do (download-image i)))
1073
1074 (defun get-image-data (road-section-image-data station step)
1075   "Return image data for the image near station."
1076   (find (* step (round station step)) road-section-image-data
1077         :key #'image-data-station
1078         :test #'=))
1079
1080 (defun get-image-namestring (road-section-image-data station step)
1081   "Return path to image near station.  Download it if necessary."
1082   (let ((image-data (get-image-data road-section-image-data station step)))
1083     (when image-data (namestring (download-image image-data)))))
1084
1085 (defun get-image-data-alist (road-section-image-data station step)
1086   "Return as an alist data for the image near station."
1087   (image-data-alist (get-image-data road-section-image-data station step)))
1088
1089 (defun image-data (&key longitude latitude ellipsoid-height station azimuth rear-view-p)
1090   "Get from Phoros server image data for location near longitude,
1091 latitude."
1092   (let* ((coordinates (make-coordinates :longitude longitude
1093                                         :latitude latitude
1094                                         :ellipsoid-height ellipsoid-height
1095                                         :azimuth azimuth))
1096          (image-data (phoros-nearest-image-data coordinates rear-view-p)))
1097     (when (image-data-p image-data)
1098       (setf (image-data-station image-data) station)
1099       (setf (image-data-station-coordinates image-data) coordinates)
1100       image-data)))
1101
1102 (define-condition phoros-server-error (error)
1103    ((body :reader body :initarg :body)
1104     (status-code :reader status-code :initarg :status-code)
1105     (headers :reader headers :initarg :headers)
1106     (url :reader url :initarg :url)
1107     (reason-phrase :reader reason-phrase :initarg :reason-phrase))
1108   (:report (lambda (condition stream)
1109              (format stream "Can't connect to Phoros server: ~A (~D)"
1110                      (reason-phrase condition) (status-code condition)))))
1111
1112 (defun phoros-lib-url (canonical-url suffix)
1113   "Replace last path element of canonical-url by lib/<suffix>."
1114   (let* ((old-path (puri:uri-parsed-path canonical-url))
1115          (new-path (append (butlast old-path) (list "lib" suffix)))
1116          (new-url (puri:copy-uri canonical-url)))
1117     (setf (puri:uri-parsed-path new-url) new-path)
1118     new-url))
1119
1120 (defun phoros-login (url user-name user-password)
1121   "Log into Phoros server; return T if successful.  Try logging out
1122 first."
1123   (setf *phoros-url* (puri:parse-uri url))
1124   (setf drakma:*allow-dotless-cookie-domains-p* t)
1125   (pushnew (cons "application" "json") drakma:*text-content-types* :test #'equal)
1126   (phoros-logout)
1127   (setf *phoros-cookies* (make-instance 'drakma:cookie-jar))
1128   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
1129       (drakma:http-request *phoros-url* :cookie-jar *phoros-cookies*)
1130     (declare (ignore stream must-close))
1131     (assert (= status-code 200) ()
1132             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
1133     (multiple-value-bind (body status-code headers authenticate-url stream must-close reason-phrase)
1134         (drakma:http-request (phoros-lib-url *phoros-url* "authenticate")
1135                              :cookie-jar *phoros-cookies*
1136                              :form-data t
1137                              :method :post
1138                              :parameters (pairlis '("user-name" "user-password")
1139                                                   (list user-name user-password)))
1140       (declare (ignore stream must-close))
1141       (assert (< status-code 400) ()
1142               'phoros-server-error :body body :status-code status-code :headers headers :url authenticate-url :reason-phrase reason-phrase)
1143       (= status-code 302))))
1144
1145 (defun phoros-logout ()
1146   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
1147       (drakma:http-request (phoros-lib-url *phoros-url* "logout")
1148                            :cookie-jar *phoros-cookies*)
1149     (declare (ignore stream must-close))
1150     (assert (= status-code 200) ()
1151             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)))
1152
1153 (defun heading (azimuth rear-view-p)
1154   "Return as a string the one of east, west, north, south which best
1155 describes azimuth."
1156   (cond ((<= (* 1/4 pi) azimuth (* 3/4 pi)) (if rear-view-p "west" "east"))
1157         ((<= (* 3/4 pi) azimuth (* 5/4 pi)) (if rear-view-p "north" "south"))
1158         ((<= (* 5/4 pi) azimuth (* 7/4 pi)) (if rear-view-p "east" "west"))
1159         ((or (<= (* 5/4 pi) azimuth pi) (<= 0 (* 1/4 pi))) (if rear-view-p "south" "north"))))
1160
1161 (defun phoros-nearest-image-data (coordinates rear-view-p)
1162   "Return a set of image-data."
1163   (multiple-value-bind (body status-code headers url stream must-close reason-phrase)
1164       (drakma:http-request (phoros-lib-url *phoros-url* "nearest-image-data")
1165                            :cookie-jar *phoros-cookies*
1166                            :method :post
1167                            :content-type "text/plain; charset=UTF-8"
1168                            :content (json:encode-json-plist-to-string (list :longitude (coordinates-longitude coordinates)
1169                                                                             :latitude (coordinates-latitude coordinates)
1170                                                                             :zoom 20
1171                                                                             :count 1
1172                                                                             :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
1173     (declare (ignore stream must-close))
1174     (assert (= status-code 200) ()
1175             'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
1176     (unless (string-equal body "null")
1177       (apply #'make-image-data :allow-other-keys t
1178              (plist-from-alist
1179               (car (json:decode-json-from-string body)))))))
1180
1181 (defun download-file (url path)
1182   "Unless already there, store content from url under path.  Return
1183 nil if nothing needed storing."
1184   (ensure-directories-exist path)
1185   (with-open-file (file-stream path :direction :output
1186                                :element-type 'unsigned-byte
1187                                :if-exists nil)
1188     (when file-stream
1189       (multiple-value-bind
1190             (body status-code headers url stream must-close reason-phrase)
1191           (drakma:http-request url
1192                                :cookie-jar *phoros-cookies*
1193                                :method :get)
1194         (declare (ignore stream must-close))
1195         (setf *t* url)
1196         (assert (= status-code 200) ()
1197                 'phoros-server-error :body body :status-code status-code :headers headers :url url :reason-phrase reason-phrase)
1198         (write-sequence body file-stream)
1199         reason-phrase))))
1200
1201 (defun download-image (image-data)
1202   "If not already there, download a png image, shrink it, convert it
1203 into jpg, and store it under the cache path.  Return that path."
1204   (multiple-value-bind (url origin-path destination-path)
1205       (image-url image-data)
1206     (unless (probe-file destination-path)
1207       (download-file url origin-path)
1208       (apply #'convert-image-file origin-path destination-path *image-size*)
1209       (delete-file origin-path))
1210     destination-path))
1211
1212 (defun image-data-alist (image-data)
1213   "Return an alist representation of image-data."
1214   (when image-data
1215     (loop
1216        for i in (append (mapcar #'ensure-hyphen-before-digit *aggregate-view-columns*) '(station station-coordinates))
1217        collect (intern (string i) 'keyword) into keys
1218        collect (funcall (intern (concatenate 'string (string 'image-data-)
1219                                              (string i)))
1220                         image-data)
1221        into values
1222        finally (return (pairlis keys values)))))
1223
1224 (defun plist-from-alist (alist)
1225   (loop
1226      for (key . value) in alist
1227      collect key
1228      collect value))
1229
1230 (defun image-url (image-data)
1231   "Return an image URL made from ingredients found in image-data, the
1232 corresponding cache path, and the corresponding cache path for the
1233 shrunk image."
1234   (let* ((path
1235           (format nil "~A/~A/~A/~D.png"
1236                   (puri:uri-path (phoros-lib-url *phoros-url* "photo"))
1237                   (image-data-directory image-data)
1238                   (image-data-filename image-data)
1239                   (image-data-byte-position image-data)))
1240          (query
1241           (format nil "mounting-angle=~D~
1242                        &bayer-pattern=~{~D~#^,~}~
1243                        &color-raiser=~{~D~#^,~}"
1244                   (image-data-mounting-angle image-data)
1245                   (map 'list #'identity (image-data-bayer-pattern image-data))
1246                   (map 'list #'identity (image-data-color-raiser image-data))))
1247          (url (puri:copy-uri *phoros-url* :path path :query query))
1248          (host (puri:uri-host url))
1249          (port (puri:uri-port url))
1250          (cache-directory (append *cache-dir*
1251                                   (list (format nil "~A_~D" host port))
1252                                   (cdr (pathname-directory (puri:uri-path url)))))
1253          (cache-name (pathname-name (puri:uri-path url)))
1254          (cache-type (pathname-type (puri:uri-path url))))
1255     (values url
1256             (make-pathname :directory cache-directory
1257                            :name cache-name
1258                            :type cache-type)
1259             (make-pathname :directory cache-directory
1260                            :name cache-name
1261                            :type "jpg"))))
1262
1263 (defun convert-image-file (origin-file destination-file width height)
1264   "Convert origin-file into destination-file of a maximum size of
1265 width x height."
1266   (lisp-magick:with-magick-wand (wand :load (namestring origin-file))
1267     (let ((a (/ (lisp-magick:magick-get-image-width wand)
1268                 (lisp-magick:magick-get-image-height wand))))
1269       (if (> a (/ width height))
1270           (lisp-magick:magick-scale-image wand width (truncate (/ width a)))
1271           (lisp-magick:magick-scale-image wand (truncate (* a height)) height)))
1272     (lisp-magick:magick-write-image wand (namestring destination-file))))
1273
1274 (defun convert-image-coordinates (original-coordinates-alist image-data-alist)
1275   "Convert image coordinates from original-coordinates-alist for the
1276 image in image-data-alist into a list of coordinates for that image
1277 scaled and centered to *image-size*."
1278   (let* ((original-m (cdr (assoc :m original-coordinates-alist)))
1279          (original-n (cdr (assoc :n original-coordinates-alist)))
1280          (original-width (cdr (assoc :sensor-width-pix image-data-alist)))
1281          (original-height (cdr (assoc :sensor-height-pix image-data-alist)))
1282          (new-width (first *image-size*))
1283          (new-height (second *image-size*))
1284          (scaling-factor (min (/ new-width original-width) (/ new-height original-height)))
1285          (new-m-offset (/ (- new-width (* original-width scaling-factor)) 2))
1286          (new-n-offset (/ (- new-height (* original-height scaling-factor)) 2))
1287          (new-m (+ (* original-m scaling-factor) new-m-offset))
1288          (new-n (- new-height           ;flip n
1289                    (+ (* original-n scaling-factor) new-n-offset))))
1290     (mapcar #'round (list new-m new-n))))