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