1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2012, 2016, 2017 Bert Burgemeister
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.
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.
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.
19 (in-package #:phoros-fasttrack
)
21 (defparameter *phoros-version
*
22 (asdf:component-version
(asdf:find-system
:phoros
))
23 "Phoros version as defined in system definition.")
25 (cffi:define-foreign-library phoml
26 (:unix
(:or
"./libphoml.so"
27 "./phoml/lib/libphoml.so"))
28 (t (:default
"libphoml")))
30 (setf *read-default-float-format
* 'double-float
)
32 (defparameter *photogrammetry-mutex
* (bt:make-lock
"photogrammetry"))
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*")
38 (defstruct (db-credentials (:type list
)) database user password host
(port-key :port
:read-only t
) (port 5432) (ssl-key :use-ssl
:read-only t
) (ssl :no
) (modifiedp-key :modifiedp
:read-only t
) (modifiedp t
) (table-key :table
:read-only t
) table
(allow-other-keys-key :allow-other-keys
:read-only t
) (allow-other-keys-value t
:read-only t
))
40 (defvar *postgresql-road-network-credentials
* (make-db-credentials)
41 "A list: (database user password host :port 5432 :use-ssl ssl-p.")
43 (defvar *postgresql-zeb-credentials
* (make-db-credentials)
44 "A list: (database user password host :port 5432 use-ssl :ssl-p.")
46 (defvar *road-network-chart-configuration
* nil
47 "Database columns selected for rendering.")
49 (defvar *zeb-chart-configuration
* nil
50 "Database columns selected for rendering.")
52 (defvar *accidents-chart-configuration
* (list nil nil nil
)
53 "Accidents rendering parameters.")
55 (defvar *postgresql-accidents-credentials
* (make-db-credentials)
56 "A list: (database user password host &key :port 5432 :use-ssl ssl-p.")
58 (defvar *postgresql-road-network-ok
* nil
59 "t if database connection could be established.")
61 (defvar *postgresql-zeb-ok
* nil
62 "t if database connection could be established.")
64 (defvar *postgresql-accidents-ok
* nil
65 "t if database connection could be established.")
70 (defvar *road-section
* nil
71 "If there is a chart, we store a list of its parameters (table vnk
72 nnk road-section-length) here.")
74 (defvar *road-section-raw-data
* (make-hash-table :size
97)
75 "Undigested selected row numbers from road section dialog")
77 (defvar *road-section-selection
* '()
78 "Row numbers of the road sections selected for processing.")
80 (defvar *road-network-chart-raw-data
* (make-hash-table :size
997 :test
#'equal
)
81 "Raw messages from the road network part of the chart dialog")
83 (defvar *accidents-chart-raw-data
* (list nil nil nil
)
84 "Undigested input from the accidents part of the chart dialog.")
86 (defvar *zeb-chart-raw-data
* (make-hash-table :size
997 :test
#'equal
)
87 "Raw messages from road section dialog")
89 (defparameter *aggregate-view-columns
*
91 'recorded-device-id
;debug
92 'device-stage-of-life-id
;debug
93 'generic-device-id
;debug
96 'filename
'byte-position
'point-id
98 ;;'coordinates ;the search target
99 'longitude
'latitude
'ellipsoid-height
101 'east-sd
'north-sd
'height-sd
102 'roll
'pitch
'heading
103 'roll-sd
'pitch-sd
'heading-sd
104 'sensor-width-pix
'sensor-height-pix
106 'bayer-pattern
'color-raiser
108 'dx
'dy
'dz
'omega
'phi
'kappa
109 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
110 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
112 'b-drotx
'b-droty
'b-drotz
)
113 "Most of the column names of aggregate-view.")
115 (defvar *phoros-cookies
* nil
116 "Container for cookies sent by Phoros server")
118 (defvar *phoros-url
* nil
119 "URL of the Phoros project currently in use.")
121 (defvar *phoros-credentials
* '("user" "password")
122 "List of (user password) used for login at *phoros-url*.")
124 (defvar *cache-dir
* '(:relative
"cache"))
126 (defparameter *image-size
* '(800 700)
127 "Image size in pixels in a list (width height).")
129 (defparameter *chart-height
* 155
130 "Height of chart in pixels.")
132 (defparameter *chart-fringe
* 20
133 "Lower, uncharted part of chart.")
135 (defparameter *chart-tail
* 200
136 "Rightmost, uncharted part of chart.")
138 (defparameter *scale-distance
* 40
139 "Horizontal distance between two scales.")
141 (defvar *cruise-control
* nil
)
142 (defvar *cruise-control-backward-p
* nil
)
144 (defvar *rear-view-image-done
* nil
)
145 (defvar *front-view-image-done
* nil
)
147 (defparameter *caching-images-p
* nil
)
149 (defvar *pipeglade-pid-file
* "fasttrack-pipeglade.pid")
151 (defparameter *cursor-color
* "orange"
152 "Color of cursor in both chart and images.")
154 (defparameter *big-step
* 10
155 "Station increment/decrement.")
157 (defparameter *pipeglade-out-lock
* (bt:make-lock
))
158 (defparameter *pipeglade-out-fifo
* "in.fifo")
159 (defparameter *pipeglade-in-fifo
* "out.fifo")
161 (defun pipeglade-out (widget action
&rest data
)
162 "Send a pipeglade command to UI."
163 (bt:with-lock-held
(*pipeglade-out-lock
*)
164 (with-open-file (out *pipeglade-out-fifo
*
167 :if-does-not-exist
:error
)
168 (format out
"~A:~A~{ ~@[~A~]~}~%" widget action data
))))
171 (defun ensure-hyphen-before-digit (symbol)
172 "Return symbol with hyphens inserted after each letter that is
173 followed by a digit. "
177 with need-hyphen-before-next-digit-p
178 for c across
(string symbol
)
179 if
(and need-hyphen-before-next-digit-p
(digit-char-p c
))
180 collect
#\- and collect c and do
(setf need-hyphen-before-next-digit-p nil
)
181 else collect c and do
(setf need-hyphen-before-next-digit-p nil
)
183 if
(alpha-char-p c
) do
(setf need-hyphen-before-next-digit-p t
) end
)
187 (defmacro with-statusbar-message
(message &body body
)
188 "Push message to statusbar while body is executing."
191 (pipeglade-out "statusbar" "push_id" (sxhash ,message
) ,message
)
193 (pipeglade-out "statusbar" "pop_id" (sxhash ,message
))))
195 (defmacro with-spinner
(spinner &body body
)
196 "Let spinner spin while body is executing."
199 (pipeglade-out ,spinner
"start")
201 (pipeglade-out ,spinner
"stop")))
203 (define-condition attention
() ())
205 (defmacro defun-cached
(name (&rest args
) &body body
&aux
(doc ""))
206 "Define a function whose return value must be readibly printable, is
207 being read from a chache if possible, and is being cached if
208 necessary. The function defined has a secondary return value
209 cached-p. If function is called with :from-cache-only t, let it
210 return nil and nil if there is nothing cached. If function is
211 called with a :message keyarg, a pretty-printed version will be
212 shown as part of the statusbar message."
213 (when (stringp (car body
))
214 (setf doc
(car body
))
215 (setf body
(cdr body
)))
216 (cl-utilities:with-unique-names
(input-stream output-stream
)
217 `(defun ,name
(,@args
&key from-cache-only create-fresh-cache message
)
219 (flet ((read-from-cache ()
220 (with-open-file (,input-stream
(cache-file-name ',name
,@args
)
222 :if-does-not-exist
:error
)
223 (values (read ,input-stream
) t
)))
225 (values (with-statusbar-message (format nil
"populating cache [~(~A~)~@[ ~A~]]" ',name message
)
226 (with-open-file (,output-stream
(cache-file-name ',name
,@args
)
228 :if-exists
:supersede
)
229 (prin1 (progn ,@body
)
232 (ensure-directories-exist (cache-file-name ',name
,@args
))
235 ((file-error (lambda (c)
236 (invoke-restart 'restart-create-fresh-cache
"FILE")))
237 (end-of-file (lambda (c)
238 (invoke-restart 'restart-create-fresh-cache
"EOF"))))
239 (restart-case (if create-fresh-cache
242 (restart-create-fresh-cache (para)
245 (,name
,@args
:create-fresh-cache t
:message message
)))))))))
247 (defun empty-image-data-p (image-data)
248 (and (not (image-data-station image-data
))
249 (empty-coordinates-p (image-data-station-coordinates image-data
))))
251 (defun empty-coordinates-p (coordinates)
252 (not (or (coordinates-longitude coordinates
)
253 (coordinates-latitude coordinates
)
254 (coordinates-ellipsoid-height coordinates
)
255 (coordinates-azimuth coordinates
))))
257 (defun image-data-equal (i1 i2
)
258 (and (eql (image-data-station i1
) (image-data-station i2
))
259 (coordinates-equal (image-data-station-coordinates i1
) (image-data-station-coordinates i2
))
260 (equal (image-data-filename i1
) (image-data-filename i2
))
261 (eql (image-data-byte-position i1
) (image-data-byte-position i2
))))
263 (defun coordinates-equal (c1 c2
)
264 (and (eql (coordinates-longitude c1
) (coordinates-longitude c2
))
265 (eql (coordinates-latitude c1
) (coordinates-latitude c2
))
266 (eql (coordinates-ellipsoid-height c1
) (coordinates-ellipsoid-height c2
))
267 (eql (coordinates-azimuth c1
) (coordinates-azimuth c2
))))
269 (defun display-date-and-image (time-widget img-widget draw-widget spinner-widget image-data
)
270 "Display image and its trigger time on UI. Return the time the UI
271 is estimated to take."
272 (let ((sleep-duration 0))
273 (with-spinner spinner-widget
274 (pipeglade-out time-widget
"set_text" (iso-time (image-data-trigger-time image-data
)))
276 (let ((image-filename (namestring (download-image image-data
))))
279 (pipeglade-out draw-widget
"remove" 2)
280 (pipeglade-out img-widget
"set_from_file" image-filename
)
281 (setf sleep-duration
.3))
283 (pipeglade-out img-widget
"set_from_file" "public_html/phoros-logo-background.png")
284 (setf sleep-duration
.1))))
285 (phoros-server-error ()
286 (pipeglade-out draw-widget
"remove" 2)
287 (pipeglade-out img-widget
"set_from_file" "public_html/phoros-logo-background.png")
288 (setf sleep-duration
1)))
291 (defun clear-date-image-and-arrow (time-widget img-widget draw-widget
)
292 (pipeglade-out img-widget
"set_from_file" "public_html/phoros-logo-background.png")
293 (pipeglade-out time-widget
"set_text")
294 (pipeglade-out draw-widget
"remove" 2))
296 (defun display-image-arrow (draw-widget image-arrow-coordinates station
)
297 "Display a station marker in the image on UI. Return the time the
298 UI is estimated to take."
299 (if image-arrow-coordinates
300 (let* ((point-radius 5)
301 (image-label-coordinates (ignore-errors
302 (list (- (first image-arrow-coordinates
) point-radius
)
303 (- (second image-arrow-coordinates
) point-radius
)))))
304 (pipeglade-out draw-widget
"remove" 2)
305 (pipeglade-out draw-widget
"move_to" 2 (first image-arrow-coordinates
) (second image-arrow-coordinates
))
306 (pipeglade-out draw-widget
"line_to" 2 (first (last image-arrow-coordinates
2)) (second (last image-arrow-coordinates
2)))
307 (pipeglade-out draw-widget
"stroke" 2)
308 (pipeglade-out draw-widget
"arc" 2 (first image-arrow-coordinates
) (second image-arrow-coordinates
) point-radius
0 360)
309 (pipeglade-out draw-widget
"stroke" 2)
310 (pipeglade-out draw-widget
"move_to" 2 (first image-label-coordinates
) (second image-label-coordinates
))
311 (pipeglade-out draw-widget
"rel_move_for" 2 "se" station
)
312 (pipeglade-out draw-widget
"show_text" 2 station
)
315 (pipeglade-out draw-widget
"remove" 2)
318 (defmacro image-worker
(view-direction)
319 (let (global-image-data global-image-arrow-coordinates global-image-done time-widget spinner-widget draw-widget img-widget
)
320 (ecase view-direction
322 (setf global-image-data
'*rear-view-image-data
*)
323 (setf global-image-arrow-coordinates
'*rear-view-image-arrow-coordinates
*)
324 (setf global-image-done
'*rear-view-image-done
*)
325 (setf time-widget
"rear_view_time")
326 (setf spinner-widget
"spinner_rearview")
327 (setf draw-widget
"draw_rearview")
328 (setf img-widget
"img_rearview"))
330 (setf global-image-data
'*front-view-image-data
*)
331 (setf global-image-arrow-coordinates
'*front-view-image-arrow-coordinates
*)
332 (setf global-image-done
'*front-view-image-done
*)
333 (setf time-widget
"front_view_time")
334 (setf spinner-widget
"spinner_frontview")
335 (setf draw-widget
"draw_frontview")
336 (setf img-widget
"img_frontview")))
337 (cl-utilities:with-unique-names
(current-image-data
339 current-image-arrow-coordinates
344 image-arrow-coordinates
348 image-label-coordinates
)
350 (let ((current-image-data *empty-image-data
*)
352 (current-road-section nil
)
353 (current-image-arrow-coordinates nil
))
355 (let ((station *station
*)
356 (road-section *road-section
*)
357 (image-data ,global-image-data
)
358 (image-arrow-coordinates ,global-image-arrow-coordinates
)
362 (if (image-data-equal current-image-data image-data
)
363 (if (and (eql current-station station
)
364 (equal current-road-section road-section
))
366 (incf sleep-duration
.1)
368 (return-from image-worker
))
370 (psetf current-station station
371 current-road-section road-section
)
372 (return-from image-output
)))
374 (psetf current-image-data image-data
375 current-station station
376 current-road-section road-section
)
377 (if (empty-image-data-p image-data
)
379 (clear-date-image-and-arrow ,time-widget
,img-widget
,draw-widget
)
380 (incf sleep-duration
.1)
381 (return-from image-worker
))
383 (display-date-and-image ,time-widget
,img-widget
,draw-widget
,spinner-widget image-data
))))))
384 (if (equal current-image-arrow-coordinates image-arrow-coordinates
)
386 (incf sleep-duration
.1)
387 (return-from image-worker
))
389 (setf current-image-arrow-coordinates image-arrow-coordinates
)
391 (display-image-arrow ,draw-widget image-arrow-coordinates station
)))))
392 (sleep sleep-duration
)
393 (setf ,global-image-done t
))))))))
395 (eval '(defstruct coordinates
401 (eval `(defstruct image-data
402 ;; fasttrack auxiliary slots
406 ;; original Phoros image data slots
407 ,@(mapcar #'ensure-hyphen-before-digit
*aggregate-view-columns
*)))
409 (defparameter *empty-coordinates
*
410 (make-coordinates :longitude nil
412 :ellipsoid-height nil
414 "Representation of a zero value for coordinates.")
416 (defparameter *empty-image-data
*
417 (make-image-data :station nil
418 :station-coordinates
*empty-coordinates
*)
419 "Representation of a zero value for image-data.")
421 (defvar *rear-view-image-data
* *empty-image-data
*
422 "The currently displayed image.")
424 (defvar *front-view-image-data
* *empty-image-data
*
425 "The currently displayed image.")
427 (defvar *rear-view-image-arrow-coordinates
* nil
)
428 (defvar *front-view-image-arrow-coordinates
* nil
)
430 (defvar *show-rear-view-p
* t
)
432 (defvar *show-front-view-p
* t
)
434 (defun start-pipeglade ()
435 (let* ((stale-pipeglade-pid
436 (with-open-file (stream *pipeglade-pid-file
*
437 :direction
:input
:if-does-not-exist
:create
)
439 (stale-pipeglade-program-name
440 (uiop:run-program
(format nil
"ps -p ~A -o comm=" stale-pipeglade-pid
) :output
:string
:ignore-error-status t
))
441 (length (min (length "pipeglade") (length stale-pipeglade-program-name
))))
442 (when (string= "pipeglade" stale-pipeglade-program-name
:end2 length
)
443 (uiop:run-program
(format nil
"kill ~A" stale-pipeglade-pid
))))
444 (let ((pipeglade-args "-i in.fifo -o out.fifo -u fasttrack.ui -b -l log.log --name fasttrack --class Phoros"))
446 for i in
'("./pipeglade" "~/pipeglade/pipeglade" "pipeglade")
448 finally
(uiop:run-program
(format nil
"~A ~A" i pipeglade-args
) :output
*pipeglade-pid-file
*))))
450 (defun version-number-parts (dotted-string)
451 "Return the three version number components of something like
454 (values-list (mapcar #'parse-integer
455 (cl-utilities:split-sequence
#\. dotted-string
)))))
457 (defun fasttrack-version (&key major minor revision
)
458 "Return version of this program, either one integer part as denoted by
459 the key argument, or the whole dotted string."
460 (multiple-value-bind (major-number minor-number revision-number
)
461 (version-number-parts *fasttrack-version
*)
462 (cond (major major-number
)
464 (revision revision-number
)
465 (t *fasttrack-version
*))))
467 (defun check-dependencies ()
468 "Say OK if the necessary external dependencies are available."
471 (let ((utm-coordinate-system
472 (format nil
"+proj=utm +ellps=WGS84 +zone=~D" 33)))
473 (proj:cs2cs
(list (proj:degrees-to-radians
12)
474 (proj:degrees-to-radians
52) 0)
475 :destination-cs utm-coordinate-system
))
476 (phoros-photogrammetry:del-all
) ;check photogrammetry
477 (format *error-output
* "~&dependencies OK~%"))
478 (error (e) (format *error-output
* "~A~&" e
))))
483 (in-package #:phoros-fasttrack
) ;for reading of cached #S(...) forms
484 (cffi:use-foreign-library phoml
)
487 (restore-road-network-credentials)
488 (restore-zeb-credentials)
489 (restore-accidents-credentials)
490 (restore-phoros-credentials)
491 (restore-road-network-chart-configuration)
492 (restore-zeb-chart-configuration)
493 (restore-accidents-chart-configuration)
494 (restore-road-section)
495 (update-credentials-dialog)
496 ;; Kludge: tickle the dialog to make spinbuttons receptive
497 (pipeglade-out "chart_configuration" "set_visible" 1)
498 (pipeglade-out "chart_configuration" "set_visible" 0)
499 (pipeglade-out "chart_road_network" "set_line_cap" 1 "round")
500 (pipeglade-out "chart_road_network" "set_line_join" 1 "round")
501 (pipeglade-out "chart_zeb" "set_line_cap" 1 "round")
502 (pipeglade-out "chart_zeb" "set_line_join" 1 "round")
503 (pipeglade-out "chart_accidents" "set_line_join" 1 "miter")
504 (pipeglade-out "chart_accidents" "set_line_width" 1 1)
505 (pipeglade-out "chart_cursor" "set_source_rgba" 1 *cursor-color
*)
506 (pipeglade-out "chart_cursor" "set_line_width" 1 3)
507 (pipeglade-out "chart_cursor" "set_dash" 1 3)
508 (pipeglade-out "chart_cursor" "set_font_size" 1 10)
509 (pipeglade-out "chart_road_network_scale" "set_font_size" 1 10)
510 (pipeglade-out "zeb_network_scale" "set_font_size" 1 10)
511 (dolist (image '("img_rearview" "img_frontview"))
512 (pipeglade-out image
"set_from_file" "public_html/phoros-logo-background.png"))
513 (dolist (drawing-area '("draw_rearview" "draw_frontview"))
514 (pipeglade-out drawing-area
"set_source_rgba" 1 *cursor-color
*)
515 (pipeglade-out drawing-area
"set_line_cap" 1 "round")
516 (pipeglade-out drawing-area
"set_line_width" 1 2)
517 (pipeglade-out drawing-area
"set_font_size" 1 10)
518 (pipeglade-out "version" "set_text" "version" *phoros-version
*))
519 (with-open-file (in *pipeglade-in-fifo
*
521 :if-does-not-exist
:error
)
523 (image-worker :rear-view
)
524 :name
"rear-view-image-worker")
526 (image-worker :front-view
)
527 :name
"front-view-image-worker")
529 #'jump-to-station-worker
530 :name
"jump-to-station-worker")
532 #'cruise-control-worker
533 :name
"cruise-control-worker")
534 (check-credentials-dialog-statuses)
536 (apply #'phoros-login
*phoros-url
* *phoros-credentials
*)
537 (phoros-server-error ()))
538 ;; getting rid of initial feedback from credentials dialog:
539 (with-statusbar-message "please wait" (sleep 1))
541 (populate-road-section-dialog)
542 (restore-road-section-image-counts)
543 (restore-road-section-selection)
544 (update-road-section-selection)
545 ;; (set-road-section)
546 (update-station (saved-station))
547 (populate-chart-dialog)
549 (with-statusbar-message "starting browser"
550 (uiop:run-program
(format nil
"firefox '~A' &" *phoros-url
*)))
552 for message
= (read-line in nil
)
555 ((message-name= "quit" message
)
556 (pipeglade-out "_" "main_quit")
559 ((and (message-name= "main" message
)
560 (string= (message-info message
) "closed"))
561 (pipeglade-out "_" "main_quit")
563 ((message-name= "station_scale" message
)
564 (setf *station
* (parse-integer (message-data message
) :junk-allowed t
)) ;picked up by jump-to-station-worker
565 (save-place *station
* 'station
))
566 ((message-name= "show_road_network_chart" message
)
567 (pipeglade-out "chart_road_network" "set_visible" (message-info message
))
568 (pipeglade-out "chart_road_network_scale" "set_visible" (message-info message
)))
569 ((message-name= "show_zeb_chart" message
)
570 (pipeglade-out "chart_zeb" "set_visible" (message-info message
))
571 (pipeglade-out "chart_zeb_scale" "set_visible" (message-info message
)))
572 ((message-name= "show_accidents_chart" message
)
573 (pipeglade-out "chart_accidents" "set_visible" (message-info message
)))
574 ((message-name= "show_rear_view" message
)
575 (setf *show-rear-view-p
* (string= (message-info message
) "1")))
576 ((message-name= "show_front_view" message
)
577 (setf *show-front-view-p
* (string= (message-info message
) "1")))
578 ((message-name= "big_step" message
)
579 (let* ((step (parse-integer (message-data message
) :junk-allowed t
))
580 (label-text (format nil
"~D m" step
)))
581 (pipeglade-out "back" "set_label" label-text
)
582 (pipeglade-out "forward" "set_label" label-text
)
583 (pipeglade-out "big_step_back" "set_label" label-text
)
584 (pipeglade-out "big_step_forward" "set_label" label-text
)
585 (pipeglade-out "station_scale" "set_increments" 1 step
)
586 (setf *big-step
* step
)))
587 ((message-name= "step_back" message
)
588 (stop-cruise-control)
589 (update-station (1- (saved-station))))
590 ((message-name= "step_forward" message
)
591 (stop-cruise-control)
592 (update-station (1+ (saved-station))))
593 ((message-name= "big_step_back" message
)
594 (stop-cruise-control)
595 (update-station (- (saved-station) *big-step
*)))
596 ((message-name= "big_step_forward" message
)
597 (stop-cruise-control)
598 (update-station (+ (saved-station) *big-step
*)))
599 ((message-name= "back" message
)
600 (stop-cruise-control)
601 (cruise-control :backwardp t
))
602 ((message-name= "forward" message
)
603 (stop-cruise-control)
604 (cruise-control :backwardp nil
))
605 ((message-name= "stop" message
)
606 (stop-cruise-control))
607 ((message-name= "first_section" message
)
608 (stop-cruise-control)
609 (set-road-section :direction
:first
)
612 ((message-name= "previous_section" message
)
613 (stop-cruise-control)
614 (set-road-section :direction
:predecessor
)
617 ((message-name= "next_section" message
)
618 (stop-cruise-control)
619 (set-road-section :direction
:successor
)
622 ((message-name= "last_section" message
)
623 (stop-cruise-control)
624 (set-road-section :direction
:last
)
627 ((message-name= "road_sections" message
)
628 (collect-road-section-select message
))
629 ((message-name= "road_section_ok" message
)
630 (digest-road-section-raw-data))
631 ((message-name= "road_section_cncl" message
)
632 (restore-road-section-selection)
633 (setf *caching-images-p
* nil
)
634 (pipeglade-out "road_section" "set_visible" 0))
635 ((message-name= "road_section_cache" message
)
636 (digest-road-section-raw-data)
638 ((message-name= "road_network" message
)
639 (collect-raw-message message
*road-network-chart-raw-data
*))
640 ((message-name= "zeb" message
)
641 (collect-raw-message message
*zeb-chart-raw-data
*))
642 ((message-name= "render_accidents" message
)
643 (setf (first *accidents-chart-raw-data
*) (message-info message
)))
644 ((message-name= "accidents_from" message
)
645 (setf (second *accidents-chart-raw-data
*) (message-data message
)))
646 ((message-name= "accidents_to" message
)
647 (setf (third *accidents-chart-raw-data
*) (message-data message
)))
648 ((message-name= "chart_configuration_ok" message
)
649 (setf *road-network-chart-configuration
* (digest-chart-raw-data *road-network-chart-raw-data
*))
650 (save-place *road-network-chart-configuration
* 'road-network-chart-configuration
)
651 (setf *zeb-chart-configuration
* (digest-chart-raw-data *zeb-chart-raw-data
*))
652 (save-place *zeb-chart-configuration
* 'zeb-chart-configuration
)
653 (digest-accidents-chart-raw-data)
654 (update-accidents-chart-dialog)
655 (pipeglade-out "text_values" "clear")
657 ((message-name= "chart_configuration_cncl" message
)
658 (update-accidents-chart-dialog)
659 (setf *accidents-chart-raw-data
* (list nil nil nil
))
660 (pipeglade-out "chart_configuration" "set_visible" 0))
661 ((message-name= "credentials_check" message
)
662 (check-credentials-dialog-statuses))
663 ((message-name= "credentials_ok" message
)
664 (check-credentials-dialog-statuses)
665 (when (db-credentials-modifiedp *postgresql-road-network-credentials
*)
666 (invalidate-road-section-selection)
667 (invalidate-road-section)
668 (invalidate-road-network-chart-configuration)
669 (populate-road-section-dialog)
670 (update-chart-dialog)
671 (save-road-network-credentials nil
))
672 (when (db-credentials-modifiedp *postgresql-zeb-credentials
*)
673 (update-chart-dialog)
674 (invalidate-zeb-chart-configuration)
675 (pipeglade-out "text_values" "clear")
677 (save-zeb-credentials nil
))
678 (when (db-credentials-modifiedp *postgresql-accidents-credentials
*)
680 (save-accidents-credentials nil
))
681 (handler-case (apply #'phoros-login
*phoros-url
* *phoros-credentials
*)
682 (phoros-server-error ()))
683 (forget-images-being-launched)
684 (update-station (saved-station))
685 (update-chart-dialog))
686 ((message-name= "road_network_host" message
)
687 (setf (db-credentials-host *postgresql-road-network-credentials
*) (message-data message
))
688 (save-road-network-credentials t
))
689 ((message-name= "road_network_port" message
)
690 (setf (db-credentials-port *postgresql-road-network-credentials
*)
691 (parse-integer (message-data message
) :junk-allowed t
))
692 (save-road-network-credentials t
))
693 ((message-name= "road_network_ssl" message
)
694 (setf (db-credentials-ssl *postgresql-road-network-credentials
*) (if (string= (message-data message
) "1") :yes
:no
))
695 (save-road-network-credentials t
))
696 ((message-name= "road_network_database" message
)
697 (setf (db-credentials-database *postgresql-road-network-credentials
*) (message-data message
))
698 (save-road-network-credentials t
))
699 ((message-name= "road_network_user" message
)
700 (setf (db-credentials-user *postgresql-road-network-credentials
*) (message-data message
))
701 (save-road-network-credentials t
))
702 ((message-name= "road_network_password" message
)
703 (setf (db-credentials-password *postgresql-road-network-credentials
*) (message-data message
))
704 (save-road-network-credentials t
))
705 ((message-name= "road_network_table" message
)
706 (setf (db-credentials-table *postgresql-road-network-credentials
*) (message-data message
))
707 (save-road-network-credentials t
))
708 ((message-name= "zeb_host" message
)
709 (setf (db-credentials-host *postgresql-zeb-credentials
*) (message-data message
))
710 (save-zeb-credentials t
))
711 ((message-name= "zeb_port" message
)
712 (setf (db-credentials-port *postgresql-zeb-credentials
*)
713 (parse-integer (message-data message
) :junk-allowed t
))
714 (save-zeb-credentials t
))
715 ((message-name= "zeb_ssl" message
)
716 (setf (db-credentials-ssl *postgresql-zeb-credentials
*) (if (string= (message-info message
) "1") :yes
:no
))
717 (save-zeb-credentials t
))
718 ((message-name= "zeb_database" message
)
719 (setf (db-credentials-database *postgresql-zeb-credentials
*) (message-data message
))
720 (save-zeb-credentials t
))
721 ((message-name= "zeb_user" message
)
722 (setf (db-credentials-user *postgresql-zeb-credentials
*) (message-data message
))
723 (save-zeb-credentials t
))
724 ((message-name= "zeb_password" message
)
725 (setf (db-credentials-password *postgresql-zeb-credentials
*) (message-data message
))
726 (save-zeb-credentials t
))
727 ((message-name= "zeb_table" message
)
728 (setf (db-credentials-table *postgresql-zeb-credentials
*) (message-data message
))
729 (save-zeb-credentials t
))
730 ((message-name= "accidents_host" message
)
731 (setf (db-credentials-host *postgresql-accidents-credentials
*) (message-data message
))
732 (save-accidents-credentials t
))
733 ((message-name= "accidents_port" message
)
734 (setf (db-credentials-port *postgresql-accidents-credentials
*)
735 (parse-integer (message-data message
) :junk-allowed t
))
736 (save-accidents-credentials t
))
737 ((message-name= "accidents_ssl" message
)
738 (setf (db-credentials-ssl *postgresql-accidents-credentials
*) (if (string= (message-data message
) "1") :yes
:no
))
739 (save-accidents-credentials t
))
740 ((message-name= "accidents_database" message
)
741 (setf (db-credentials-database *postgresql-accidents-credentials
*) (message-data message
))
742 (save-accidents-credentials t
))
743 ((message-name= "accidents_user" message
)
744 (setf (db-credentials-user *postgresql-accidents-credentials
*) (message-data message
))
745 (save-accidents-credentials t
))
746 ((message-name= "accidents_password" message
)
747 (setf (db-credentials-password *postgresql-accidents-credentials
*) (message-data message
))
748 (save-accidents-credentials t
))
749 ((message-name= "accidents_table" message
)
750 (setf (db-credentials-table *postgresql-accidents-credentials
*) (message-data message
))
751 (save-accidents-credentials t
))
752 ((message-name= "phoros_url" message
)
753 (setf *phoros-url
* (message-data message
))
754 (save-phoros-credentials))
755 ((message-name= "phoros_user" message
)
756 (setf (first *phoros-credentials
*) (message-data message
))
757 (save-phoros-credentials))
758 ((message-name= "phoros_password" message
)
759 (setf (second *phoros-credentials
*) (message-data message
))
760 (save-phoros-credentials))
761 ((message-name= "phoros" message
)
762 (run-phoros-browser))
764 (print (list "fallen through:" message
)))))))
765 (sb-sys:interactive-interrupt
() (kill-pipeglade))
771 (defun kill-pipeglade ()
773 (with-open-file (stream *pipeglade-pid-file
* :direction
:input
)
775 (uiop:run-program
(format nil
"kill ~A" pipeglade-pid
))))
777 (defun invalidate-road-section ()
778 (setf *road-section
* nil
)
781 (defun invalidate-road-section-selection ()
782 (setf *road-section-selection
* '())
783 (save-road-section-selection))
785 (defun invalidate-road-network-chart-configuration ()
786 (setf *road-network-chart-configuration
* nil
)
787 (save-place *road-network-chart-configuration
* 'road-network-chart-configuration
))
789 (defun invalidate-zeb-chart-configuration ()
790 (setf *zeb-chart-configuration
* nil
)
791 (save-place *zeb-chart-configuration
* 'zeb-chart-configuration
))
793 (defun message-name= (string message
)
794 (let ((colon-position (position #\
: message
)))
795 (string= string
(subseq message
0 colon-position
))))
797 (defun message-info (message)
798 (let ((colon-position (position #\
: message
))
799 (space-position (position #\Space message
)))
800 (subseq message
(1+ colon-position
) space-position
)))
802 (defun message-data (message)
803 (let ((space-position (position #\Space message
)))
805 (subseq message
(1+ space-position
)))))
807 (defun message-data-list (message)
808 (cl-utilities:split-sequence
#\Space
(message-data message
)))
810 (defun collect-road-section-select (message)
811 (let ((data (message-data-list message
)))
812 (if (string= (second data
) "4") ;"select" column
813 (setf (gethash (parse-integer (first data
)) ;row number
814 *road-section-raw-data
*)
815 (string= (third data
) "1")))))
817 (defun collect-accidents-message-data (&key
(renderp 0 renderp-p
) (from nil from-p
) (to nil to-p
) (ok-pressed nil ok-pressed-p
))
818 (when renderp-p
(setf (first *accidents-chart-raw-data
*) renderp
))
819 (when from-p
(setf (second *accidents-chart-raw-data
*) (parse-integer from
:junk-allowed t
)))
820 (when to-p
(setf (third *accidents-chart-raw-data
*) (parse-integer to
:junk-allowed t
))))
822 (defun collect-raw-message (message place
)
823 (unless (string= (message-info message
) "clicked")
824 (let ((data (message-data-list message
)))
825 (setf (gethash (list (parse-integer (first data
)) ;row number
826 (parse-integer (second data
))) ;column number
830 (defun digest-road-section-raw-data ()
831 (when (and *postgresql-road-network-credentials
* *postgresql-road-network-ok
*)
832 (let ((sections (sections (make-symbol (db-credentials-table *postgresql-road-network-credentials
*)))))
833 (maphash (lambda (key value
)
835 (pushnew key
*road-section-selection
*)
836 (setf *road-section-selection
* (remove key
*road-section-selection
*))))
837 *road-section-raw-data
*)
838 (setf *road-section-selection
* (sort *road-section-selection
* #'<))
839 (save-road-section-selection)
840 (set-road-section :direction
:first
)
841 ;; (save-road-section)
843 ;; (when (update-station) ;new section
844 ;; (restore-road-section-image-counts)
846 (clrhash *road-section-raw-data
*))))
848 (defstruct (data-style (:type list
)) chartp drawablep textp name color width dash
)
850 ;; (defun clear-main-window ()
851 ;; (dolist (drawingarea '("chart_accidents" "chart_road_network" "chart_zeb" "chart_cursor" "chart_road_network_scale" "chart_zeb_scale" "draw_rearview" "draw_frontview"))
852 ;; (pipeglade-out drawingarea "remove" 2))
853 ;; (dolist (image '("img_rearview" "img_frontview"))
854 ;; (pipeglade-out image "set_from_file"))
855 ;; (pipeglade-out "text_values" "clear"))
857 (defun digest-chart-raw-data (raw-data)
858 "Return the information read from raw-data in chart configuration format."
861 for
(row column
) being each hash-key of raw-data
862 when
(zerop column
) ;arbitrary column representing its row
865 (make-array (list row-count
))))
867 for i from
0 below row-count
869 (setf (svref chart-configuration i
)
872 for
(row column
) being each hash-key of raw-data using
(hash-value value
)
876 (setf (data-style-name (svref chart-configuration row
)) value
))
879 (setf (data-style-width (svref chart-configuration row
)) value
))
881 (setf (data-style-color (svref chart-configuration row
)) value
))
883 (setf (data-style-dash (svref chart-configuration row
)) value
))
885 (setf (data-style-chartp (svref chart-configuration row
)) (string= value
"1")))
887 (setf (data-style-textp (svref chart-configuration row
)) (string= value
"1")))
889 (setf (data-style-drawablep (svref chart-configuration row
)) (string= value
"1")))))
890 chart-configuration
))
892 (defun digest-accidents-chart-raw-data ()
893 (setf *accidents-chart-configuration
*
894 (mapcar (lambda (configuration-value raw-value
)
895 (or (format nil
"~D" (parse-integer raw-value
:junk-allowed t
)) configuration-value
))
896 *accidents-chart-configuration
*
897 *accidents-chart-raw-data
*))
898 (save-accidents-chart-configuration))
900 (defun road-network-chart-data (column vnk nnk chart-height
)
901 "Return a list of lists of station and column values between vnk
902 and nnk scaled into chart-height; the minimum column value; and the
903 maximum column value. Both minimum and maximum are nil if data is
905 (let ((table (intern (db-credentials-table *postgresql-road-network-credentials
*))))
906 (with-connection *postgresql-road-network-credentials
*
907 (setf column
(intern (string-upcase column
)))
908 (destructuring-bind (minimum maximum
)
909 (query (:select
(:type
(:min column
) real
)
910 (:type
(:max column
) real
)
912 :where
(:and
(:= 'vnk vnk
)
915 (if (and (numberp minimum
) (numberp maximum
))
916 (let* ((span (- maximum minimum
))
919 (/ chart-height span
)))
922 (+ chart-height
(* m minimum
)))))
926 (:- b
(:* m
(:type column real
)))
928 :where
(:and
(:= 'vnk vnk
)
931 ;; (unless (zerop span) minimum)
932 ;; (unless (zerop span) maximum)
936 (values nil nil nil
))))))
938 (defun zeb-chart-data (column vnk nnk chart-height
)
939 "Return a list of lists of station and column values between vnk
940 and nnk scaled into chart-height; the minimum column value; and the
941 maximum column value. Both minimum and maximum are nil if data is
943 (let ((table (intern (db-credentials-table *postgresql-zeb-credentials
*))))
944 (with-connection *postgresql-zeb-credentials
*
945 (setf column
(intern (string-upcase column
)))
946 (destructuring-bind (minimum maximum
)
947 (query (:select
(:type
(:min column
) real
)
948 (:type
(:max column
) real
)
950 :where
(:and
(:= 'vnk vnk
)
953 (if (and (numberp minimum
) (numberp maximum
))
954 (let* ((span (- maximum minimum
))
957 (/ chart-height span
)))
960 (+ chart-height
(* m minimum
)))))
964 (:- b
(:* m
(:type column real
)))
966 (:- b
(:* m
(:type column real
)))
968 :where
(:and
(:= 'vnk vnk
)
971 ;; (unless (zerop span) minimum)
972 ;; (unless (zerop span) maximum)
976 (values nil nil nil
))))))
980 (defun road-network-text-value (column vnk nnk station
)
981 "Return column value at station between vnk and nnk."
982 (when *postgresql-road-network-ok
*
983 (let ((table (intern (db-credentials-table *postgresql-road-network-credentials
*))))
984 (with-connection *postgresql-road-network-credentials
*
985 (setf column
(intern (string-upcase column
)))
986 (query (:select column
988 :where
(:and
(:= 'vnk vnk
)
990 (:= 'nk_station station
)))
993 (defun zeb-text-value (column vnk nnk station
)
994 "Return column value at station between vnk and nnk."
995 (when *postgresql-zeb-ok
*
996 (let ((table (intern (db-credentials-table *postgresql-zeb-credentials
*))))
997 (with-connection *postgresql-zeb-credentials
*
998 (setf column
(intern (string-upcase column
)))
999 (query (:select column
1001 :where
(:and
(:= 'vnk vnk
)
1003 (:between station
'vst
'bst
)))
1006 (defun show-text (row-number station text-data-function column vnk nnk color width dash
)
1007 (let ((value (funcall text-data-function column vnk nnk station
)))
1008 (pipeglade-out "text_values" "set" row-number
0 column
)
1009 (pipeglade-out "text_values" "set" row-number
1 value
)
1010 (pipeglade-out "text_values" "set" row-number
2 color
)
1011 (pipeglade-out "text_values" "set" row-number
3 (* 4 (parse-integer width
:junk-allowed t
))))) ;text size
1013 (defun put-text-values (vnk nnk station
)
1014 (let ((row-number 0))
1015 (when (vectorp *road-network-chart-configuration
*)
1017 for style-definition across
*road-network-chart-configuration
*
1019 (when (data-style-textp style-definition
)
1020 (show-text row-number station
#'road-network-text-value
(data-style-name style-definition
) vnk nnk
(data-style-color style-definition
) (data-style-width style-definition
) (data-style-dash style-definition
))
1021 (incf row-number
))))
1022 (when (vectorp *zeb-chart-configuration
*)
1024 for style-definition across
*zeb-chart-configuration
*
1026 (when (data-style-textp style-definition
)
1027 (show-text row-number station
#'zeb-text-value
(data-style-name style-definition
) vnk nnk
(data-style-color style-definition
) (data-style-width style-definition
) (data-style-dash style-definition
))
1028 (incf row-number
))))))
1030 (defun accidents-data (vnk nnk
&key
1031 (year-min most-negative-fixnum
)
1032 (year-max most-positive-fixnum
))
1033 "Return a list of plists containing accident data for the road
1034 section between vnk and nnk."
1035 (when *postgresql-accidents-ok
*
1036 (let ((table (intern (db-credentials-table *postgresql-accidents-credentials
*))))
1037 (with-connection *postgresql-accidents-credentials
*
1039 (:select
'nk-station
'fahrtrichtung
'unfalltyp
'unfallkategorie
'alkohol
1041 :where
(:and
(:= 'vnk vnk
)
1043 (:between
'jahr year-min year-max
)))
1044 'nk-station
'jahr
'monat
'tag
'stunde
'minuten
)
1047 (defun populate-road-section-dialog ()
1048 (when *postgresql-road-network-ok
*
1049 (with-statusbar-message "populating road section list"
1050 (with-spinner "road_section_spinner"
1051 (pipeglade-out "road_sections" "clear")
1052 (with-connection *postgresql-road-network-credentials
*
1053 (let ((sections (sections (make-symbol (db-credentials-table *postgresql-road-network-credentials
*)))))
1055 for
(vnk nnk length
) in sections
1056 for row-number from
0
1058 (add-vnk-nnk-leaf vnk nnk length row-number
))))))))
1060 (defun update-credentials-dialog ()
1061 (with-statusbar-message "initialising credentials"
1062 (pipeglade-out "road_network_host" "set_text" (db-credentials-host *postgresql-road-network-credentials
*))
1063 (pipeglade-out "road_network_port" "set_text" (db-credentials-port *postgresql-road-network-credentials
*))
1064 (pipeglade-out "road_network_ssl" "set_active" (if (eq (db-credentials-ssl *postgresql-road-network-credentials
*) :no
) 0 1))
1065 (pipeglade-out "road_network_database" "set_text" (db-credentials-database *postgresql-road-network-credentials
*))
1066 (pipeglade-out "road_network_table" "set_text" (db-credentials-table *postgresql-road-network-credentials
*))
1067 (pipeglade-out "road_network_user" "set_text" (db-credentials-user *postgresql-road-network-credentials
*))
1068 (pipeglade-out "road_network_password" "set_text" (db-credentials-password *postgresql-road-network-credentials
*))
1069 (pipeglade-out "road_network_status" "set_text" "?")
1070 (pipeglade-out "zeb_host" "set_text" (db-credentials-host *postgresql-zeb-credentials
*))
1071 (pipeglade-out "zeb_port" "set_text" (db-credentials-port *postgresql-zeb-credentials
*))
1072 (pipeglade-out "zeb_ssl" "set_active" (if (eq (db-credentials-ssl *postgresql-zeb-credentials
*) :no
) 0 1))
1073 (pipeglade-out "zeb_database" "set_text" (db-credentials-database *postgresql-zeb-credentials
*))
1074 (pipeglade-out "zeb_table" "set_text" (db-credentials-table *postgresql-zeb-credentials
*))
1075 (pipeglade-out "zeb_user" "set_text" (db-credentials-user *postgresql-zeb-credentials
*))
1076 (pipeglade-out "zeb_password" "set_text" (db-credentials-password *postgresql-zeb-credentials
*))
1077 (pipeglade-out "zeb_status" "set_text" "?")
1078 (pipeglade-out "accidents_host" "set_text" (db-credentials-host *postgresql-accidents-credentials
*))
1079 (pipeglade-out "accidents_port" "set_text" (db-credentials-port *postgresql-accidents-credentials
*))
1080 (pipeglade-out "accidents_ssl" "set_active" (if (eq (db-credentials-ssl *postgresql-accidents-credentials
*) :no
) 0 1))
1081 (pipeglade-out "accidents_database" "set_text" (db-credentials-database *postgresql-accidents-credentials
*))
1082 (pipeglade-out "accidents_table" "set_text" (db-credentials-table *postgresql-accidents-credentials
*))
1083 (pipeglade-out "accidents_user" "set_text" (db-credentials-user *postgresql-accidents-credentials
*))
1084 (pipeglade-out "accidents_password" "set_text" (db-credentials-password *postgresql-accidents-credentials
*))
1085 (pipeglade-out "accidents_status" "set_text" "?")
1086 (when *phoros-credentials
*
1087 (destructuring-bind (user password
) *phoros-credentials
*
1088 (pipeglade-out "phoros_url" "set_text" *phoros-url
*)
1089 (pipeglade-out "phoros_user" "set_text" user
)
1090 (pipeglade-out "phoros_password" "set_text" password
)
1091 (pipeglade-out "phoros_status" "set_text" "?")))))
1093 (defun check-credentials-dialog-statuses ()
1094 (with-statusbar-message "checking road network db connection"
1095 (multiple-value-bind (message successp
) (check-db *postgresql-road-network-credentials
*)
1096 (pipeglade-out "road_network_status" "set_text" message
)
1097 (setf *postgresql-road-network-ok
* successp
)))
1098 (with-statusbar-message "checking zeb db connection"
1099 (multiple-value-bind (message successp
) (check-db *postgresql-zeb-credentials
*)
1100 (pipeglade-out "zeb_status" "set_text" message
)
1101 (setf *postgresql-zeb-ok
* successp
)))
1102 (with-statusbar-message "checking accidents db connection"
1103 (multiple-value-bind (message successp
) (check-db *postgresql-accidents-credentials
*)
1104 (pipeglade-out "accidents_status" "set_text" message
)
1105 (setf *postgresql-accidents-ok
* successp
)))
1106 (with-statusbar-message "checking Phoros connection"
1107 (pipeglade-out "phoros_status" "set_text" (and *phoros-url
*
1108 *phoros-credentials
*
1109 (apply #'check-phoros
*phoros-url
* *phoros-credentials
*)))))
1111 (defun save-place (place filename-stump
)
1112 "Save place into a file whose name is based on symbol filename-stump."
1113 (let ((cache-file-name (cache-file-name filename-stump
)))
1114 (ensure-directories-exist cache-file-name
)
1115 (with-open-file (stream cache-file-name
1117 :if-exists
:supersede
)
1118 (prin1 place stream
))))
1120 (defmacro restore-place
(place filename-stump
&optional default
)
1121 "Restore place from a file whose name is based on symbol filename-stump."
1122 (cl-utilities:with-unique-names
(stream)
1123 `(with-open-file (stream (cache-file-name ,filename-stump
)
1125 :if-does-not-exist nil
)
1127 (setf ,place
(read stream
))
1128 (setf ,place
,default
)))))
1131 (defun save-road-section-selection ()
1132 "Save the list of road sections selected for processing."
1133 (save-place *road-section-selection
* 'road-section-selection
))
1135 (defun restore-road-section-selection ()
1136 (restore-place *road-section-selection
* 'road-section-selection
))
1138 (defun update-road-section-selection ()
1139 (when *postgresql-road-network-ok
*
1140 (with-statusbar-message "restoring road section selection"
1141 (with-spinner "road_section_spinner"
1142 (with-connection *postgresql-road-network-credentials
*
1143 (let ((sections (sections (make-symbol (db-credentials-table *postgresql-road-network-credentials
*)))))
1145 for row-number from
0 below
(length sections
)
1147 (if (find row-number
*road-section-selection
*)
1148 (pipeglade-out "road_sections" "set" row-number
4 1)
1149 (pipeglade-out "road_sections" "set" row-number
4 0))))))
1150 (pipeglade-out "road_sections" "scroll"
1151 (or (ignore-errors (apply #'min
*road-section-selection
*))
1155 (defun restore-road-section-image-counts ()
1156 (when *postgresql-road-network-ok
*
1157 (with-statusbar-message "restoring road section image counts"
1158 (with-connection *postgresql-road-network-credentials
*
1159 (let* ((table (make-symbol (db-credentials-table *postgresql-road-network-credentials
*)))
1160 (sections (sections table
)))
1162 for
(vnk nnk
) in sections
1163 for row-number from
0
1164 do
(multiple-value-bind (rearview-image-data rearview-cached-p
)
1165 (road-section-image-data (provenience-string *phoros-url
*) table vnk nnk
10 t
:from-cache-only t
)
1166 (multiple-value-bind (frontview-image-data frontview-cached-p
)
1167 (road-section-image-data (provenience-string *phoros-url
*) table vnk nnk
10 nil
:from-cache-only t
)
1168 (when (and rearview-cached-p frontview-cached-p
)
1169 (pipeglade-out "road_sections" "set" row-number
3 (+ (length rearview-image-data
) (length frontview-image-data
))))))))))))
1171 (defun save-road-network-credentials (modifiedp)
1172 (setf (db-credentials-modifiedp *postgresql-road-network-credentials
*) modifiedp
)
1173 (save-place *postgresql-road-network-credentials
* 'road-network-credentials
))
1175 (defun restore-road-network-credentials ()
1176 (restore-place *postgresql-road-network-credentials
* 'road-network-credentials
*postgresql-road-network-credentials
*))
1178 (defun save-zeb-credentials (modifiedp)
1179 (setf (db-credentials-modifiedp *postgresql-zeb-credentials
*) modifiedp
)
1180 (save-place *postgresql-zeb-credentials
* 'zeb-credentials
))
1182 (defun restore-zeb-credentials ()
1183 (restore-place *postgresql-zeb-credentials
* 'zeb-credentials
*postgresql-zeb-credentials
*))
1185 (defun save-accidents-credentials (modifiedp)
1186 (setf (db-credentials-modifiedp *postgresql-accidents-credentials
*) modifiedp
)
1187 (save-place *postgresql-accidents-credentials
* 'accidents-credentials
))
1189 (defun restore-accidents-credentials ()
1190 (restore-place *postgresql-accidents-credentials
* 'accidents-credentials
*postgresql-accidents-credentials
*))
1192 (defun save-phoros-credentials ()
1193 (save-place *phoros-credentials
* 'phoros-credentials
)
1194 (save-place *phoros-url
* 'phoros-url
))
1196 (defun restore-phoros-credentials ()
1197 (restore-place *phoros-credentials
* 'phoros-credentials
*phoros-credentials
*)
1198 (restore-place *phoros-url
* 'phoros-url
*phoros-url
*))
1200 (defun save-road-section ()
1201 "Save road-section into cache directory."
1202 (save-place *road-section
* 'road-section
))
1204 (defun restore-road-section ()
1205 (restore-place *road-section
* 'road-section
))
1207 (defun save-accidents-chart-configuration ()
1208 (save-place *accidents-chart-configuration
* 'accidents-chart-configuration
))
1210 (defun saved-station ()
1211 (let ((cache-file-name (cache-file-name 'station
))
1213 (ensure-directories-exist cache-file-name
)
1214 (with-open-file (stream cache-file-name
1216 :if-does-not-exist nil
)
1217 (when stream
(setf station
(read stream
)))
1220 (defun restore-road-network-chart-configuration ()
1221 (unless (db-credentials-modifiedp *postgresql-road-network-credentials
*)
1222 (restore-place *road-network-chart-configuration
* 'road-network-chart-configuration
)))
1224 (defun restore-zeb-chart-configuration ()
1225 (unless (db-credentials-modifiedp *postgresql-zeb-credentials
*)
1226 (restore-place *zeb-chart-configuration
* 'zeb-chart-configuration
)))
1228 (defun restore-accidents-chart-configuration ()
1229 (unless (db-credentials-modifiedp *postgresql-accidents-credentials
*)
1230 (restore-place *accidents-chart-configuration
* 'accidents-chart-configuration
(list "1" "1999" "2030"))))
1232 (defun set-road-section (&key direction
)
1233 (let* ((table (make-symbol (db-credentials-table *postgresql-road-network-credentials
*)))
1234 (sections (sections table
))
1235 (sections-current (position (cdr *road-section
*) sections
:test
#'equal
))
1236 (selection-current (position sections-current
*road-section-selection
*)))
1237 (cond ((and *road-section-selection
* (eq direction
:predecessor
))
1238 (let ((selection-predecessor (ignore-errors (nth (1- selection-current
) *road-section-selection
*))))
1239 (when selection-predecessor
1240 (setf *road-section
*
1241 (cons table
(nth selection-predecessor sections
)))
1242 (save-road-section))))
1243 ((and *road-section-selection
* (eq direction
:successor
))
1244 (let* ((selection-successor (nth (1+ selection-current
) *road-section-selection
*)))
1245 (when selection-successor
1246 (setf *road-section
*
1247 (cons table
(nth selection-successor sections
)))
1248 (save-road-section))))
1249 ((and *road-section-selection
* (eq direction
:last
))
1250 (setf *road-section
* (cons table
1251 (nth (car (last *road-section-selection
*)) sections
)))
1252 (save-road-section))
1253 ((and *road-section-selection
* (eq direction
:first
))
1254 (setf *road-section
* (cons table
1255 (nth (first *road-section-selection
*) sections
)))
1256 (save-road-section))
1257 ((not *road-section-selection
*)
1258 (setf *road-section
* nil
))
1260 (error "impossible road section")))))
1262 (defun update-station (station)
1263 "Change station widget in UI."
1264 (when (numberp station
)
1265 (pipeglade-out "station_scale" "set_value" station
)))
1267 (defun jump-to-station-worker ()
1268 (let ((current-station)
1269 (current-road-section))
1271 (if (or (not *road-section
*)
1272 (and (eql current-station
*station
*)
1273 (equal current-road-section
*road-section
*)))
1278 (psetf current-station
*station
*
1279 current-road-section
*road-section
*)
1281 (destructuring-bind (table vnk nnk road-section-length
)
1282 current-road-section
1283 (pipeglade-out "station" "set_text" current-station
)
1284 (place-chart-cursor current-station
)
1285 (put-image :vnk vnk
:nnk nnk
:station current-station
:step
10 :rear-view-p t
)
1286 (put-image :vnk vnk
:nnk nnk
:station current-station
:step
10 :rear-view-p nil
)
1287 (put-text-values vnk nnk current-station
))
1288 (database-connection-error ())
1289 (database-error ())))))))
1291 (defun check-db (db-credentials &aux result
)
1292 "Check database connection and presence of table or view table-name.
1293 Return a string describing the outcome."
1294 (let ((table-name (db-credentials-table db-credentials
)))
1296 (trivial-timeout:with-timeout
(3)
1297 (with-connection db-credentials
1298 (if (or (table-exists-p table-name
)
1299 (view-exists-p table-name
))
1300 (setf result
(list "ok" t
))
1301 (setf result
(list "table or view missing" nil
)))))
1302 (database-connection-error (e) (setf result
(list e nil
)))
1303 (cl+ssl
:ssl-error-verify
(e) (setf result
(list e nil
)))
1304 (sb-bsd-sockets:name-service-error
(e) (setf result
(list e nil
)))
1305 (database-error (e) (setf result
(list e nil
)))
1306 (trivial-timeout:timeout-error
() (setf result
(list "timeout" nil
))))
1307 (values-list result
)))
1309 (defun check-phoros (url user-name password
)
1310 "Check connection to phoros server. Return a string describing the
1312 (let ((*phoros-url
* url
)
1313 (*phoros-cookies
* nil
))
1315 (handler-case (phoros-login url user-name password
)
1316 (usocket:ns-host-not-found-error
() "host not found")
1317 (usocket:connection-refused-error
() "connection refused")
1318 (error (c) (format nil
"~A" c
))
1319 (:no-error
(result) (if result
"ok" "wrong user or password")))
1322 (defun populate-chart-dialog ()
1323 (with-statusbar-message "initialising chart configuration"
1324 (when *postgresql-road-network-ok
*
1325 (update-chart-dialog-treeview "road_network" *postgresql-road-network-credentials
* *road-network-chart-configuration
*))
1326 (when *postgresql-zeb-ok
*
1327 (update-chart-dialog-treeview "zeb" *postgresql-zeb-credentials
* *zeb-chart-configuration
*))
1328 (when *postgresql-accidents-ok
*
1329 (update-accidents-chart-dialog))))
1332 (defun update-chart-dialog ()
1333 (with-statusbar-message "updating chart configuration"
1334 (when (and (db-credentials-modifiedp *postgresql-road-network-credentials
*)
1335 *postgresql-road-network-ok
*)
1336 (update-chart-dialog-treeview "road_network" *postgresql-road-network-credentials
* *road-network-chart-configuration
*)
1337 (save-road-network-credentials nil
))
1338 (when (and (db-credentials-modifiedp *postgresql-zeb-credentials
*)
1339 *postgresql-zeb-ok
*)
1340 (update-chart-dialog-treeview "zeb" *postgresql-zeb-credentials
* *zeb-chart-configuration
*)
1341 (save-zeb-credentials nil
))
1342 (when (and (db-credentials-modifiedp *postgresql-accidents-credentials
*)
1343 *postgresql-accidents-ok
*)
1344 (update-accidents-chart-dialog)
1345 (save-accidents-credentials nil
))))
1347 (defun update-chart-dialog-treeview (treeview db-credentials chart-configuration
)
1348 (with-statusbar-message "updating treeview configuration"
1350 (with-connection db-credentials
1351 (present-db-columns (table-description (db-credentials-table db-credentials
)) treeview chart-configuration
))
1352 (database-connection-error ()))))
1354 (defun update-accidents-chart-dialog ()
1355 (pipeglade-out "render_accidents" "set_active" (first *accidents-chart-configuration
*))
1356 (pipeglade-out "accidents_from" "set_text" (second *accidents-chart-configuration
*))
1357 (pipeglade-out "accidents_to" "set_text" (third *accidents-chart-configuration
*)))
1359 (defun present-db-columns (columns treeview chart-configuration
)
1360 (pipeglade-out treeview
"clear")
1362 for
(column-name type
) in
(sort columns
#'string-lessp
:key
#'car
)
1363 for row-number from
0
1365 (let ((selected-column (find column-name chart-configuration
:key
#'data-style-name
:test
#'string-equal
))
1366 (drawablep (numeric-type-p type
)))
1367 (pipeglade-out treeview
"set" row-number
0 column-name
)
1368 (pipeglade-out treeview
"set" row-number
1 type
)
1369 (pipeglade-out treeview
"set" row-number
2 (or (data-style-width selected-column
) 2))
1370 (pipeglade-out treeview
"set" row-number
3 (or (data-style-color selected-column
) "black"))
1371 (pipeglade-out treeview
"set" row-number
4 (or (data-style-dash selected-column
) ""))
1372 (pipeglade-out treeview
"set" row-number
5 (if (and drawablep
(data-style-chartp selected-column
)) 1 0))
1373 (pipeglade-out treeview
"set" row-number
6 (if (data-style-textp selected-column
) 1 0))
1374 (pipeglade-out treeview
"set" row-number
7 (if drawablep
1 0))
1375 (pipeglade-out treeview
"set_cursor" row-number
))) ;tickle initial pipeglade output
1376 (pipeglade-out treeview
"set_cursor")
1377 (pipeglade-out treeview
"scroll" 0 0))
1379 (defun numeric-type-p (type)
1380 (some #'identity
(mapcar (lambda (x) (search x type
))
1381 '("float" "double" "int" "numeric" "serial"))))
1383 (defun add-vnk-nnk-leaf (vnk nnk length row-number
)
1384 "Put a leaf into road-sections tree."
1385 (pipeglade-out "road_sections" "set" row-number
0 vnk
)
1386 (pipeglade-out "road_sections" "set" row-number
1 nnk
)
1387 (pipeglade-out "road_sections" "set" row-number
2 length
))
1389 (defun prepare-chart ()
1390 "Prepare chart for the road section between vnk and nnk in table in
1392 (when *road-section
*
1393 (destructuring-bind (table vnk nnk road-section-length
) *road-section
*
1394 (pipeglade-out "ovl_chart" "set_size_request" (+ *chart-tail
* road-section-length
) (+ *chart-height
* *chart-fringe
*))
1395 (pipeglade-out "vnk" "set_text" vnk
)
1396 (pipeglade-out "nnk" "set_text" nnk
)
1397 (pipeglade-out "length" "set_text" road-section-length
)
1398 (draw-chart-cursor-scale road-section-length
)
1399 (pipeglade-out "station_scale" "set_range" 0 road-section-length
)
1400 ;; (setf *road-section* (list table vnk nnk road-section-length))
1401 ;; (save-road-section)
1402 (draw-graphs vnk nnk
)
1403 (update-station (saved-station))
1404 ;; (pipeglade-out "station_scale" "set_value" (saved-station))
1407 (defun place-chart-cursor (station)
1408 "Move chart cursor to station."
1410 (pipeglade-out "chart_cursor" "remove" 2)
1411 (pipeglade-out "chart_cursor" "move_to" 2 station
0)
1412 (pipeglade-out "chart_cursor" "line_to" 2 station
(+ *chart-height
* *chart-fringe
*))
1413 (pipeglade-out "chart_cursor" "stroke" 2)
1414 (pipeglade-out "chart_scroll" "hscroll_to_range" (- station
200) (+ station
200))
1415 (pipeglade-out "chart_road_network_scale" "translate" "=3" station
0)
1416 (pipeglade-out "chart_zeb_scale" "translate" "=3" station
0)))
1418 (defun refresh-chart ()
1420 (when (= (length *road-section
*) 4)
1423 (defun draw-graphs (vnk nnk
)
1424 "Draw graphs for the columns in *zeb-chart-configuration* and
1425 *road-network-chart-configuration*. Delete existing graphs first."
1426 (with-statusbar-message "drawing chart"
1427 (with-spinner "chart_spinner"
1428 (pipeglade-out "chart_road_network" "remove" 2)
1429 (pipeglade-out "chart_road_network_scale" "remove" 2)
1430 (pipeglade-out "chart_road_network_scale" "translate" "=3" 0 0)
1431 (pipeglade-out "chart_zeb" "remove" 2)
1432 (pipeglade-out "chart_zeb_scale" "remove" 2)
1433 (pipeglade-out "chart_zeb_scale" "translate" "=3" 0 0)
1434 (let ((scale-position *scale-distance
*))
1435 (with-statusbar-message "drawing road-network chart"
1436 (when (vectorp *road-network-chart-configuration
*)
1438 for style-definition across
*road-network-chart-configuration
*
1440 (when (data-style-chartp style-definition
)
1443 (draw-graph #'road-network-chart-data
"chart_road_network" (data-style-name style-definition
) vnk nnk
(data-style-color style-definition
) (data-style-width style-definition
) (data-style-dash style-definition
))
1444 (draw-scale scale-position
#'road-network-chart-data
"chart_road_network_scale" (data-style-name style-definition
) vnk nnk
(data-style-color style-definition
) (data-style-width style-definition
) (data-style-dash style-definition
))
1445 (incf scale-position
*scale-distance
*))
1446 (database-error (e) (format t
"(draw-graphs), road-network: ~A~%" e
)))))))
1447 (with-statusbar-message "drawing zeb chart"
1448 (when (vectorp *zeb-chart-configuration
*)
1450 for style-definition across
*zeb-chart-configuration
*
1452 (when (data-style-chartp style-definition
)
1455 (draw-graph #'zeb-chart-data
"chart_zeb" (data-style-name style-definition
) vnk nnk
(data-style-color style-definition
) (data-style-width style-definition
) (data-style-dash style-definition
))
1456 (draw-scale scale-position
#'zeb-chart-data
"chart_zeb_scale" (data-style-name style-definition
) vnk nnk
(data-style-color style-definition
) (data-style-width style-definition
) (data-style-dash style-definition
))
1457 (incf scale-position
*scale-distance
*))
1458 (database-error (e) (format t
"(draw-graphs), zeb: ~A~%" e
))))))))
1459 (pipeglade-out "chart_accidents" "remove" 2)
1462 (draw-accidents vnk nnk
))
1463 (database-error (e) (format t
"(draw-graphs), accidents: ~A~%" e
))))))
1465 (defun draw-graph (chart-data-function chart column vnk nnk color width dash
)
1466 (multiple-value-bind (line minimum maximum
)
1467 (funcall chart-data-function column vnk nnk
*chart-height
*)
1468 (let ((line-fragments
1469 (cl-utilities:split-sequence-if
#'(lambda (x)
1470 (eq (second x
) :null
))
1472 :remove-empty-subseqs t
)))
1473 (pipeglade-out chart
"set_source_rgba" 2 color
)
1474 (pipeglade-out chart
"set_line_width" 2 width
)
1475 (pipeglade-out chart
"set_dash" 2 dash
)
1476 (dolist (line-fragment line-fragments
)
1477 (pipeglade-out chart
"move_to" 2 (first (car line-fragment
)) (second (car line-fragment
)))
1478 (dolist (line-vertex (cdr line-fragment
))
1479 (pipeglade-out chart
"line_to" 2 (first line-vertex
) (second line-vertex
)))
1480 (pipeglade-out chart
"stroke" 2)))))
1482 (defun draw-scale (position chart-data-function chart column vnk nnk color width dash
)
1483 (multiple-value-bind (line minimum maximum
)
1484 (funcall chart-data-function column vnk nnk
*chart-height
*)
1485 (pipeglade-out chart
"set_source_rgba" 2 color
)
1486 (pipeglade-out chart
"set_line_width" 2 width
)
1487 (pipeglade-out chart
"move_to" 2 position
0)
1488 (pipeglade-out chart
"line_to" 2 position
*chart-height
*)
1489 (dolist (tick (axis-ticks minimum maximum
5 *chart-height
* t
))
1490 (pipeglade-out chart
"move_to" 2 position
(format nil
"~F" (second tick
)))
1491 (pipeglade-out chart
"rel_line_to" 2 (* 2 (parse-integer width
)) 0)
1492 (pipeglade-out chart
"move_to" 2 position
(format nil
"~F" (second tick
)))
1493 (pipeglade-out chart
"rel_move_to" 2 (- (parse-integer width
)) 0)
1494 (pipeglade-out chart
"rel_move_for" 2 "e" (first tick
))
1495 (pipeglade-out chart
"show_text" 2 (first tick
)))
1496 (pipeglade-out chart
"move_to" 2 position
(format nil
"~F" (+ *chart-height
* (/ *chart-fringe
* 2))))
1497 (pipeglade-out chart
"rel_move_for" 2 "c" column
)
1498 (pipeglade-out chart
"show_text" 2 column
)
1499 (pipeglade-out chart
"stroke" 2)))
1501 (defun draw-chart-cursor-scale (length)
1502 (let ((y-position (+ *chart-height
* *chart-fringe
*))
1503 (number-of-ticks (round length
100)))
1504 (pipeglade-out "chart_cursor" "remove" 4)
1505 (dolist (tick (axis-ticks 0 length number-of-ticks length nil
))
1506 (pipeglade-out "chart_cursor" "move_to" 4 (second tick
) y-position
)
1507 (pipeglade-out "chart_cursor" "line_to" 4 (second tick
) (- y-position
3))
1508 (pipeglade-out "chart_cursor" "rel_move_for" 4 "s" (first tick
))
1509 (pipeglade-out "chart_cursor" "show_text" 4 (first tick
)))
1510 (pipeglade-out "chart_cursor" "stroke" 4)))
1512 (defun axis-ticks (minimum maximum n chart-size reversep
)
1513 (let ((range (- maximum minimum
)))
1515 (list (list (format nil
"~F" minimum
) (/ chart-size
2)))
1516 (let* ((a (if reversep
1517 (- (/ chart-size range
))
1518 (/ chart-size range
)))
1521 (- (* a maximum
) chart-size
)))
1522 (min-step (/ range
(1+ n
)))
1523 (max-step (/ range
(1- n
)))
1524 (max-exp (log max-step
10))
1525 (int-exp (floor max-exp
))
1526 (norm-min (floor (/ min-step
(expt 10 int-exp
))))
1527 (norm-max (floor (/ max-step
(expt 10 int-exp
))))
1529 ((or (= norm-min
1) (= norm-max
1))
1531 ((or (<= norm-min
4 norm-max
) (<= norm-min
5 norm-max
) (<= norm-min
6 norm-max
))
1533 ((or (<= norm-min
2) (<= norm-min
3 norm-max
))
1538 norm-max
))) ;can't happen
1539 (step (* norm
(expt 10 int-exp
)))
1540 (start (- minimum
(nth-value 1 (fceiling minimum step
)))))
1542 for i from start to maximum by step
1543 collect
(list (if (minusp int-exp
)
1544 (format nil
"~,VF" (- int-exp
) i
)
1545 (format nil
"~A" (round i
)))
1548 (defun draw-accidents (vnk nnk
)
1549 (when (string-equal (first *accidents-chart-configuration
*) "1")
1550 (let* ((year-min (second *accidents-chart-configuration
*))
1551 (year-max (third *accidents-chart-configuration
*))
1552 (accidents (accidents-data vnk nnk
:year-min year-min
:year-max year-max
))
1553 (current-station -
1)
1554 (zeroth-position -
1)
1557 (dolist (accident accidents
)
1558 (unless (= current-station
(getf accident
:nk-station
))
1559 (setf y1-position
(- *chart-height
* zeroth-position
))
1560 (setf y2-position zeroth-position
)
1561 (setf y0-position
(+ (/ *chart-height
* 2) zeroth-position
)))
1562 (setf current-station
(getf accident
:nk-station
))
1563 (cond ((= 1 (getf accident
:fahrtrichtung
))
1564 (draw-accident accident
(decf y1-position
10)))
1565 ((= 2 (getf accident
:fahrtrichtung
))
1566 (draw-accident accident
(incf y2-position
10)))
1568 (draw-accident accident
(incf y0-position
10))))))))
1570 (defun draw-accident (accident y-position
)
1571 "Put graphical representation of accident on chart."
1572 (destructuring-bind (&key nk-station fahrtrichtung unfalltyp unfallkategorie alkohol
)
1574 (when (and (numberp alkohol
) (plusp alkohol
)) (draw-triangle nk-station y-position
"lightblue"))
1575 (case unfallkategorie
1576 (1 (draw-rectangle nk-station y-position
10 "black")
1577 (draw-circle nk-station y-position
8 (accident-type-color unfalltyp
)))
1578 (2 (draw-circle nk-station y-position
8 (accident-type-color unfalltyp
)))
1579 (3 (draw-circle nk-station y-position
6 (accident-type-color unfalltyp
)))
1580 (4 (draw-circle nk-station y-position
6 "white")
1581 (draw-circle nk-station y-position
4 (accident-type-color unfalltyp
)))
1582 (5 (draw-circle nk-station y-position
4 (accident-type-color unfalltyp
)))
1583 (6 (draw-triangle nk-station y-position
"lightblue")
1584 (draw-circle nk-station y-position
4 (accident-type-color unfalltyp
)))
1585 (t (draw-circle nk-station y-position
4 (accident-type-color unfalltyp
))))))
1587 (defun draw-circle (x y diameter color
)
1588 (pipeglade-out "chart_accidents" "set_source_rgba" 2 "black")
1589 (pipeglade-out "chart_accidents" "arc" 2 x y
(/ diameter
2) 0 360)
1590 (pipeglade-out "chart_accidents" "stroke_preserve" 2)
1591 (pipeglade-out "chart_accidents" "set_source_rgba" 2 color
)
1592 (pipeglade-out "chart_accidents" "fill" 2))
1594 (defun draw-rectangle (x y diameter color
)
1595 (let ((radius (/ diameter
2)))
1596 (pipeglade-out "chart_accidents" "set_source_rgba" 2 color
)
1597 (pipeglade-out "chart_accidents" "rectangle" 2 (- x radius
) (- y radius
) diameter diameter
)
1598 (pipeglade-out "chart_accidents" "fill" 2)))
1600 (defun draw-triangle (x y color
)
1601 (pipeglade-out "chart_accidents" "set_source_rgba" 2 "black")
1602 (pipeglade-out "chart_accidents" "move_to" 2 (- x
3) (- y
6))
1603 (pipeglade-out "chart_accidents" "line_to" 2 (+ x
3) (- y
6))
1604 (pipeglade-out "chart_accidents" "line_to" 2 x
(+ y
9))
1605 (pipeglade-out "chart_accidents" "close_path" 2)
1606 (pipeglade-out "chart_accidents" "stroke_preserve" 2)
1607 (pipeglade-out "chart_accidents" "set_source_rgba" 2 color
)
1608 (pipeglade-out "chart_accidents" "fill" 2))
1610 (defun accident-type-color (accident-type)
1621 (defun iso-time (time)
1623 (multiple-value-bind (seconds deciseconds
)
1625 (multiple-value-bind (second minute hour date month year day daylight-p zone
)
1626 (decode-universal-time seconds
)
1627 (format nil
"~D-~2,'0D-~2,'0D\\n~2,'0D:~2,'0D:~2,'0D~3,3FZ" year month date hour minute second deciseconds
)))))
1629 (defun image-point-coordinates (image-data-alist global-point-coordinates
)
1630 "Return a list (m n) of image coordinates representing
1631 global-point-coordinates in the image described in image-data-alist
1632 but scaled to fit into *image-size*."
1634 (convert-image-coordinates
1635 (photogrammetry :reprojection
1637 (pairlis '(:x-global
:y-global
:z-global
)
1640 (proj:degrees-to-radians
1641 (coordinates-longitude global-point-coordinates
))
1642 (proj:degrees-to-radians
1643 (coordinates-latitude global-point-coordinates
))
1644 (coordinates-ellipsoid-height global-point-coordinates
))
1645 :destination-cs
(cdr (assoc :cartesian-system image-data-alist
)))))
1649 (defun in-image-p (m n
)
1650 "Check if m, n lay inside *image-size*."
1651 (and m n
(<= 0 m
(first *image-size
*)) (<= 0 n
(second *image-size
*))))
1653 (defun-cached sections
(table)
1654 "Return list of distinct pairs of vnk, nnk found in table in
1656 (query (:order-by
(:select
'vnk
'nnk
(:max
'nk-station
)
1657 :from
(intern (db-credentials-table *postgresql-road-network-credentials
*))
1658 :where
(:and
(:not-null
'vnk
) (:not-null
'nnk
))
1659 :group-by
'vnk
'nnk
)
1662 (defun stations (table vnk nnk
&optional
(step 1))
1663 "Return a list of plists of :longitude, :latitude,
1664 :ellipsoid-height, :station, :azimuth of stations step metres apart
1665 between vnk and nnk."
1666 (when (and table vnk nnk
)
1669 (with-open-file (s "ttt" :direction
:output
:if-exists
:append
:if-does-not-exist
:create
))
1672 (:select
(:as
(:st_x
't1.the-geom
) 'longitude
)
1673 (:as
(:st_y
't1.the-geom
) 'latitude
)
1674 (:as
(:st_z
't1.the-geom
) 'ellipsoid-height
)
1675 (:as
't1.nk-station
'station
)
1676 (:as
(:st_azimuth
't1.the-geom
't2.the-geom
) 'azimuth
)
1677 :from
(:as table
't1
)
1678 :left-join
(:as table
't2
)
1679 :on
(:and
(:= 't1.nk-station
(:-
't2.nk-station
1))
1682 :where
(:and
(:= 't1.vnk vnk
)
1684 (:= 0 (:%
't1.nk-station step
))))
1687 (with-open-file (s "ttt" :direction
:output
:if-exists
:append
:if-does-not-exist
:create
)))))
1689 (getf (nth (- (length stations
) 1) stations
) :azimuth
)
1690 (getf (nth (- (length stations
) 2) stations
) :azimuth
))
1693 (defun-cached all-stations
(table vnk nnk
)
1694 "Return a vector of coordinates of all points between vnk and nnk,
1695 station (in metres) being the vector index."
1696 (when (and table vnk nnk
)
1697 (let* ((stations (stations table vnk nnk
))
1698 (result (make-array (list (1+ (getf (first (last stations
)) :station
)))
1699 :initial-element nil
)))
1702 do
(destructuring-bind (&key longitude latitude ellipsoid-height station azimuth
)
1704 (setf (svref result station
)
1705 (make-coordinates :longitude longitude
1707 :ellipsoid-height ellipsoid-height
1708 :azimuth azimuth
))))
1711 (defun-cached road-section-image-data
(provenience-string table vnk nnk step rear-view-p
)
1712 "Return a list of instances of image data corresponding to stations,
1713 which are step metres apart, found in table in current database.
1714 provenience-string only serves as a marker of the provenience of image
1716 (remove nil
;; (mapcar #'(lambda (x)
1717 ;; (apply #'image-data :rear-view-p rear-view-p x))
1718 ;; (stations table vnk nnk step))
1720 with azimuth-fallback
= nil
1721 for station in
(stations table vnk nnk step
)
1722 when
(not (eq (getf station
:azimuth
) :null
))
1723 do
(setf azimuth-fallback
(getf station
:azimuth
))
1724 and collect
(apply #'image-data
:rear-view-p rear-view-p station
)
1726 when
(and azimuth-fallback
1727 (eq (getf station
:azimuth
) :null
))
1728 do
(setf (getf station
:azimuth
) azimuth-fallback
)
1729 and collect
(apply #'image-data
:rear-view-p rear-view-p station
))))
1731 (defun provenience-string (url)
1732 "Turn url recognisably into something suitable as part of a file
1734 (let ((parsed-url (puri:parse-uri url
)))
1735 (format nil
"~A_~A~{_~A~}"
1736 (puri:uri-host parsed-url
)
1737 (puri:uri-port parsed-url
)
1738 (cl-utilities:split-sequence
1739 #\
/ (puri:uri-path parsed-url
) :remove-empty-subseqs t
))))
1741 (defun cache-file-name (kind &rest args
)
1742 "Return pathname for a cache file distinguishable by kind and args."
1743 (make-pathname :directory
*cache-dir
*
1744 :name
(format nil
"~{~:[f~;~:*~(~A~)~]_~}~S.~S"
1746 (fasttrack-version :major t
)
1747 (fasttrack-version :minor t
))
1748 :type
(string-downcase kind
)))
1750 (defun cache-images ()
1751 "Download images of road-sections selected in dialog into their
1753 (unless *caching-images-p
*
1754 (setf *caching-images-p
* t
)
1757 (when *postgresql-road-network-ok
*
1758 (with-statusbar-message "caching images"
1759 (with-spinner "road_section_spinner"
1761 ((phoros-server-error (lambda (e) (invoke-restart 'retry
))))
1762 (with-connection *postgresql-road-network-credentials
*
1763 (let* ((table (make-symbol (db-credentials-table *postgresql-road-network-credentials
*)))
1764 (sections (sections table
)))
1766 for selected-section in
*road-section-selection
*
1768 (cache-road-section-images (nth selected-section sections
) table
))))))))
1769 (setf *caching-images-p
* nil
))
1770 :name
"cache-images")))
1772 (let ((retry-delay 1))
1773 (defun cache-road-section-images (section table
)
1774 (destructuring-bind (vnk nnk length
)
1779 for image-data in
(road-section-image-data (provenience-string *phoros-url
*) table vnk nnk
10 t
)
1780 do
(if *caching-images-p
*
1781 (download-image image-data
)
1784 for image-data in
(road-section-image-data (provenience-string *phoros-url
*) table vnk nnk
10 nil
)
1785 do
(if *caching-images-p
*
1786 (download-image image-data
)
1788 (setf retry-delay
1))
1790 (with-statusbar-message (format nil
"error while caching images; retry after ~A seconds" retry-delay
)
1791 (sleep retry-delay
))
1792 (when (< retry-delay
15)
1793 (incf retry-delay
1))
1794 (cache-road-section-images section table
))))))
1796 (defun get-image-data (road-section-image-data station step
)
1797 "Return image data for the image near station."
1798 (or (find (* step
(round station step
)) road-section-image-data
1799 :key
#'image-data-station
1801 *empty-image-data
*))
1803 (defun get-image-data-alist (road-section-image-data station step
)
1804 "Return as an alist data for the image near station."
1805 (image-data-alist (get-image-data road-section-image-data station step
)))
1807 (defun image-data (&key longitude latitude ellipsoid-height station azimuth rear-view-p
)
1808 "Get from Phoros server image data for location near longitude,
1811 (let* ((coordinates (make-coordinates :longitude longitude
1813 :ellipsoid-height ellipsoid-height
1815 (image-data (phoros-nearest-image-data coordinates rear-view-p
)))
1816 (when (image-data-p image-data
)
1817 (setf (image-data-station image-data
) station
)
1818 (setf (image-data-station-coordinates image-data
) coordinates
)
1820 (phoros-server-error (e) (format t
"(image-data): ~A" e
))))
1822 (define-condition phoros-server-error
(error)
1823 ((body :reader body
:initarg
:body
)
1824 (status-code :reader status-code
:initarg
:status-code
)
1825 (headers :reader headers
:initarg
:headers
)
1826 (url :reader url
:initarg
:url
)
1827 (reason-phrase :reader reason-phrase
:initarg
:reason-phrase
))
1828 (:report
(lambda (condition stream
)
1829 (format stream
"Can't connect to Phoros server: ~A (~D)"
1830 (reason-phrase condition
) (status-code condition
)))))
1832 (defun phoros-lib-url (canonical-url suffix
)
1833 "Replace last path element of canonical-url by lib/<suffix>."
1834 (let* ((parsed-canonical-url (puri:parse-uri canonical-url
))
1835 (old-path (puri:uri-parsed-path parsed-canonical-url
))
1836 (new-path (append (butlast old-path
) (list "lib" suffix
)))
1837 (new-url (puri:copy-uri parsed-canonical-url
)))
1838 (setf (puri:uri-parsed-path new-url
) new-path
)
1841 (defun phoros-login (url user-name user-password
)
1842 "Log into Phoros server; return T if successful. Try logging out
1844 ;; (setf *phoros-url* url)
1845 (setf drakma
:*allow-dotless-cookie-domains-p
* t
)
1846 (pushnew (cons "application" "json") drakma
:*text-content-types
* :test
#'equal
)
1848 (setf *phoros-cookies
* (make-instance 'drakma
:cookie-jar
))
1849 (multiple-value-bind (body status-code headers url stream must-close reason-phrase
)
1850 (drakma:http-request
(puri:parse-uri url
) :cookie-jar
*phoros-cookies
*)
1851 (declare (ignore stream must-close
))
1852 (assert (= status-code
200) ()
1853 'phoros-server-error
:body body
:status-code status-code
:headers headers
:url url
:reason-phrase reason-phrase
)
1854 (multiple-value-bind (body status-code headers authenticate-url stream must-close reason-phrase
)
1855 (drakma:http-request
(phoros-lib-url url
"authenticate")
1856 :cookie-jar
*phoros-cookies
*
1859 :parameters
(pairlis '("user-name" "user-password")
1860 (list user-name user-password
)))
1861 (declare (ignore stream must-close
))
1862 (assert (< status-code
400) ()
1863 'phoros-server-error
:body body
:status-code status-code
:headers headers
:url authenticate-url
:reason-phrase reason-phrase
)
1864 (let ((body-strings (cl-utilities:split-sequence
#\Space
(substitute-if-not #\Space
#'alphanumericp body
))))
1865 (and (not (find "Rejected" body-strings
:test
#'string
=))
1866 (not (find "Retry" body-strings
:test
#'string
=))
1867 (= status-code
200)))))) ;should be 302 (?)
1869 (defun phoros-logout ()
1870 (drakma:http-request
(phoros-lib-url *phoros-url
* "logout")))
1872 (defun run-phoros-browser ()
1873 (when *road-section
*
1874 (with-statusbar-message "calling browser synchronously"
1875 (destructuring-bind (table vnk nnk road-section-length
)
1877 (let ((current-coordinates (svref (all-stations table vnk nnk
) (saved-station))))
1879 (uiop:run-program
(format nil
"firefox '~A/lib/set-cursor?bbox=~F,~F,~F,~F&longitude=~F&latitude=~F'"
1881 (- (coordinates-longitude current-coordinates
) .02)
1882 (- (coordinates-latitude current-coordinates
) .01)
1883 (+ (coordinates-longitude current-coordinates
) .02)
1884 (+ (coordinates-latitude current-coordinates
) .01)
1885 (coordinates-longitude current-coordinates
)
1886 (coordinates-latitude current-coordinates
)
1888 (type-error () nil
))
1889 (uiop:run-program
(format nil
"firefox '~A'" *phoros-url
*)))))))
1892 (defun heading (azimuth rear-view-p
)
1893 "Return as a string the one of east, west, north, south which best
1895 (cond ((<= (* 1/4 pi
) azimuth
(* 3/4 pi
)) (if rear-view-p
"west" "east"))
1896 ((<= (* 3/4 pi
) azimuth
(* 5/4 pi
)) (if rear-view-p
"north" "south"))
1897 ((<= (* 5/4 pi
) azimuth
(* 7/4 pi
)) (if rear-view-p
"east" "west"))
1898 ((or (<= (* 5/4 pi
) azimuth pi
) (<= 0 (* 1/4 pi
))) (if rear-view-p
"south" "north"))))
1900 (defun phoros-nearest-image-data (coordinates rear-view-p
)
1901 "Return a set of image-data."
1902 (multiple-value-bind (body status-code headers url stream must-close reason-phrase
)
1903 (drakma:http-request
(phoros-lib-url *phoros-url
* "nearest-image-data")
1904 :cookie-jar
*phoros-cookies
*
1906 :content-type
"text/plain; charset=UTF-8"
1907 :content
(json:encode-json-plist-to-string
(list :longitude
(coordinates-longitude coordinates
)
1908 :latitude
(coordinates-latitude coordinates
)
1911 :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
1912 (declare (ignore stream must-close
))
1913 (assert (= status-code
200) ()
1914 'phoros-server-error
:body body
:status-code status-code
:headers headers
:url url
:reason-phrase reason-phrase
)
1915 (unless (string-equal body
"null")
1916 (apply #'make-image-data
:allow-other-keys t
1918 (car (json:decode-json-from-string body
)))))))
1920 (defun download-file (url path
)
1921 "Unless already there, store content from url under path. Return
1922 nil if nothing needed storing."
1924 (ensure-directories-exist path
)
1925 (with-open-file (file-stream path
:direction
:output
1926 :element-type
'unsigned-byte
1929 (with-statusbar-message (format nil
"downloading ~A" url
)
1930 (multiple-value-bind
1931 (body status-code headers url stream must-close reason-phrase
)
1932 (drakma:http-request url
1933 :cookie-jar
*phoros-cookies
*
1935 (declare (ignore stream must-close
))
1937 (assert (= status-code
200) ()
1938 'phoros-server-error
:body body
:status-code status-code
:headers headers
:url url
:reason-phrase reason-phrase
)
1939 (write-sequence body file-stream
)
1942 (defun download-image (image-data)
1943 "If not already there, download a png image, shrink it, convert it
1944 into jpg, and store it under the cache path. Return that path."
1945 (multiple-value-bind (url origin-path destination-path
)
1946 (image-url image-data
)
1947 (when destination-path
1948 (unless (probe-file destination-path
)
1949 (download-file url origin-path
)
1950 (apply #'convert-image-file origin-path destination-path
*image-size
*)
1951 (delete-file origin-path
))
1954 (defun remember-image-being-launched (image-data image-arrow-coordinates rear-view-p
)
1956 (if *show-rear-view-p
*
1958 (psetf *rear-view-image-data
* image-data
1959 *rear-view-image-arrow-coordinates
* image-arrow-coordinates
))
1961 (setf *rear-view-image-data
* *empty-image-data
*)
1962 (pipeglade-out "draw_rearview" "remove" 2)
1963 (pipeglade-out "img_rearview" "set_from_file" "public_html/phoros-logo-background.png")))
1964 (if *show-front-view-p
*
1966 (psetf *front-view-image-data
* image-data
1967 *front-view-image-arrow-coordinates
* image-arrow-coordinates
))
1969 (setf *front-view-image-data
* *empty-image-data
*)
1970 (pipeglade-out "draw_frontview" "remove" 2)
1971 (pipeglade-out "img_frontview" "set_from_file" "public_html/phoros-logo-background.png")))))
1973 (defun forget-images-being-launched ()
1974 (setf *rear-view-image-data
* *empty-image-data
*)
1975 (setf *front-view-image-data
* *empty-image-data
*))
1977 (defun image-data-alist (image-data)
1978 "Return an alist representation of image-data."
1981 for i in
(append (mapcar #'ensure-hyphen-before-digit
*aggregate-view-columns
*) '(station station-coordinates
))
1982 collect
(intern (string i
) 'keyword
) into keys
1983 collect
(funcall (intern (concatenate 'string
(string 'image-data-
)
1987 finally
(return (pairlis keys values
)))))
1989 (defun plist-from-alist (alist)
1991 for
(key . value
) in alist
1995 (defun image-url (image-data)
1996 "Return an image URL made from ingredients found in image-data, the
1997 corresponding cache path, and the corresponding cache path for the
2001 (format nil
"~A/~A/~A/~D.png"
2002 (puri:uri-path
(phoros-lib-url *phoros-url
* "photo"))
2003 (image-data-directory image-data
)
2004 (image-data-filename image-data
)
2005 (image-data-byte-position image-data
)))
2007 (format nil
"mounting-angle=~D~
2008 &bayer-pattern=~{~D~#^,~}~
2009 &color-raiser=~{~D~#^,~}"
2010 (image-data-mounting-angle image-data
)
2011 (map 'list
#'identity
(image-data-bayer-pattern image-data
))
2012 (map 'list
#'identity
(image-data-color-raiser image-data
))))
2013 (url (puri:copy-uri
(puri:parse-uri
*phoros-url
*) :path path
:query query
))
2014 (host (puri:uri-host url
))
2015 (port (puri:uri-port url
))
2016 (cache-directory (append *cache-dir
*
2017 (list (format nil
"~A_~D" host port
))
2018 (cdr (pathname-directory (puri:uri-path url
)))))
2019 (cache-name (pathname-name (puri:uri-path url
)))
2020 (cache-type (pathname-type (puri:uri-path url
))))
2022 (make-pathname :directory cache-directory
2025 (make-pathname :directory cache-directory
2029 (defun convert-image-file (origin-file destination-file width height
)
2030 "Convert origin-file into destination-file of a maximum size of
2033 (lisp-magick-wand:with-magick-wand
(wand :load
(namestring origin-file
))
2034 (let ((a (/ (lisp-magick-wand:get-image-width wand
)
2035 (lisp-magick-wand:get-image-height wand
))))
2036 (if (> a
(/ width height
))
2037 (lisp-magick-wand:scale-image wand width
(truncate (/ width a
)))
2038 (lisp-magick-wand:scale-image wand
(truncate (* a height
)) height
)))
2039 (lisp-magick-wand:write-image wand
(namestring destination-file
)))
2040 (lisp-magick-wand:magick-wand-error
()))) ;ignore
2042 (defun convert-image-coordinates (original-coordinates-alist image-data-alist
)
2043 "Convert image coordinates from original-coordinates-alist for the
2044 image in image-data-alist into a list of coordinates for that image
2045 scaled and centered to *image-size*."
2046 (let* ((original-m (cdr (assoc :m original-coordinates-alist
)))
2047 (original-n (cdr (assoc :n original-coordinates-alist
)))
2048 (original-width (cdr (assoc :sensor-width-pix image-data-alist
)))
2049 (original-height (cdr (assoc :sensor-height-pix image-data-alist
)))
2050 (new-width (first *image-size
*))
2051 (new-height (second *image-size
*))
2052 (scaling-factor (min (/ new-width original-width
) (/ new-height original-height
)))
2053 (new-m-offset (/ (- new-width
(* original-width scaling-factor
)) 2))
2054 (new-n-offset (/ (- new-height
(* original-height scaling-factor
)) 2))
2055 (new-m (+ (* original-m scaling-factor
) new-m-offset
))
2056 (new-n (- new-height
;flip n
2057 (+ (* original-n scaling-factor
) new-n-offset
))))
2058 (mapcar #'round
(list new-m new-n
))))
2060 (defun put-image (&key vnk nnk station step rear-view-p
)
2061 "Put an image along with a labelled station marker on screen."
2062 (when (and vnk nnk station
)
2063 (with-connection *postgresql-road-network-credentials
*
2064 (setf station
(or station
0))
2065 (let* ((table (make-symbol (db-credentials-table *postgresql-road-network-credentials
*)))
2067 (image-widget (if rear-view-p
"img_rearview" "img_frontview"))
2068 (drawing-widget (if rear-view-p
"draw_rearview" "draw_frontview"))
2069 (spinner-widget (if rear-view-p
"spinner_rearview" "spinner_frontview"))
2070 (time-widget (if rear-view-p
"rear_view_time" "front_view_time"))
2071 global-point-coordinates
2074 image-arrow-coordinates
2075 global-point-coordinates-thread
)
2076 (setf global-point-coordinates-thread
2079 (with-connection *postgresql-road-network-credentials
*
2080 (setf global-point-coordinates
2081 (subseq (all-stations table vnk nnk
:message
(list vnk nnk
))
2082 (min (length (all-stations table vnk nnk
)) station
)
2083 (min (length (all-stations table vnk nnk
)) (+ station
4))))))
2084 :name
"global-point-coordinates"))
2085 (bt:join-thread global-point-coordinates-thread
)
2086 (setf image-data-alist
2087 (get-image-data-alist (road-section-image-data (provenience-string *phoros-url
*) table vnk nnk step rear-view-p
:message
(list "get-image-data-alist" vnk nnk
(if rear-view-p
"rear-view" "front-view")))
2090 (setf image-arrow-coordinates
2092 for i across global-point-coordinates
2093 append
(image-point-coordinates image-data-alist i
)))
2094 (setf image-label-coordinates
(ignore-errors
2095 (list (- (first image-arrow-coordinates
) point-radius
)
2096 (- (second image-arrow-coordinates
) point-radius
))))
2097 (setf image-data
(get-image-data (road-section-image-data (provenience-string *phoros-url
*) table vnk nnk step rear-view-p
:message
(list "image-data" vnk nnk
(if rear-view-p
"rear-view" "front-view"))) station step
))
2098 (remember-image-being-launched image-data image-arrow-coordinates rear-view-p
)))))
2100 (defun cruise-control (&key backwardp
)
2101 (setf *cruise-control-backward-p
* backwardp
)
2102 (setf *cruise-control
* t
)) ;picked up by cruise-control-worker
2104 (defun stop-cruise-control ()
2105 (setf *cruise-control
* nil
))
2107 (defun cruise-control-worker ()
2109 (let ((road-section-length (fourth *road-section
*)))
2110 (if (and *cruise-control
*
2111 *rear-view-image-done
*
2112 *front-view-image-done
*)
2115 (+ *station
* (if *cruise-control-backward-p
*
2118 (when (< next-station
0)
2119 (setf next-station
0)
2120 (stop-cruise-control))
2121 (when (> next-station road-section-length
)
2122 (setf next-station road-section-length
)
2123 (stop-cruise-control))
2124 (setf *rear-view-image-done
* nil
)
2125 (setf *front-view-image-done
* nil
)
2127 (update-station next-station
)))
2130 (bt:thread-yield
))))))
