From 718f1aff84f53be64f1ad7c9d9c23b4bb2bbd1ee Mon Sep 17 00:00:00 2001 From: Bert Burgemeister Date: Thu, 2 Aug 2012 14:54:59 +0200 Subject: [PATCH] Chart dialog; drawing chart from database --- fasttrack.lisp | 291 ++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 256 insertions(+), 35 deletions(-) diff --git a/fasttrack.lisp b/fasttrack.lisp index d22201a..193f0f6 100644 --- a/fasttrack.lisp +++ b/fasttrack.lisp @@ -49,6 +49,12 @@ "Name of table or view in database described by *postgresql-zeb-credentials*") +(defvar *zeb-column-selection* nil + "Database columns selected for rendering.") + +(defvar *accidents-column-selection* nil + "Database columns selected for rendering.") + (defvar *postgresql-accidents-credentials* nil "A list: (database user password host &key (port 5432) use-ssl).") @@ -56,6 +62,10 @@ "Name of table or view in database described by *postgresql-accidents-credentials*") +(defvar *chart-parameters* nil + "If there is a chart, we store a list of its parameters (table vnk + nnk road-section-length) here.") + (defparameter *aggregate-view-columns* (list 'usable 'recorded-device-id ;debug @@ -97,6 +107,9 @@ (defparameter *image-size* '(800 800) "Image size in pixels in a list (width height).") +(defparameter *chart-height* 200 + "Height of chart in pixels.") + (defvar *jump-to-station-event* nil "Remembering event id of chart click event jumptostation.") @@ -144,6 +157,7 @@ followed by a digit. " (defun main () (restore-credentials) + (restore-column-selection) (apply #'phoros-login *phoros-url* *phoros-credentials*) (with-tk ((make-instance 'ffi-tk)) (tcl "package" "require" "Img") @@ -156,6 +170,7 @@ followed by a digit. " (tcl ".menubar.file" "add" "command" :label "Kaputt" :command (tcl{ "destroy" ".")) (tcl ".menubar.file" "add" "command" :label "choose road section ..." :command (event-handler* (road-section-dialog))) (tcl ".menubar.file" "add" "command" :label "server credentials ..." :command (event-handler* (credentials-dialog))) + (tcl ".menubar.file" "add" "command" :label "chart configuration ..." :command (event-handler* (chart-dialog))) (tcl ".menubar.file" "add" "command" :label "Do Stuff" :command (event-handler* (print "doing stuff") (print "doing more stuff") (tcl "set" "feet" 500))) (bind-event "." "<>" ((ddd #\d)) (print (list "ddd" ddd))) @@ -163,26 +178,23 @@ followed by a digit. " (tcl "grid" (tcl[ "ttk::frame" ".f" :borderwidth 3 :relief "groove") :column 0 :row 0 :sticky "nwes") - (tcl "set" "chart1" (tcl[ "canvas" ".f.chart1" :xscrollcommand ".f.h set")) + (tcl "set" "chart1" (tcl[ "canvas" ".f.chart1" :xscrollcommand ".f.h set" :height *chart-height*)) - (tcl "grid" (tcl[ "canvas" ".f.rearview" :bg "black" (mapcan #'list '(:width :height) *image-size*)) :column 0 :row 0 :sticky "nwes") - (tcl "grid" (tcl[ "canvas" ".f.frontview" :bg "black" (mapcan #'list '(:width :height) *image-size*)) :column 1 :row 0 :sticky "nwes") + (tcl "grid" (tcl[ "canvas" ".f.rearview" :background "black" (mapcan #'list '(:width :height) *image-size*)) :column 0 :row 0 :sticky "nwes") + (tcl "grid" (tcl[ "canvas" ".f.frontview" :background "black" (mapcan #'list '(:width :height) *image-size*)) :column 1 :row 0 :sticky "nwes") (tcl "grid" (lit "$chart1") :column 0 :row 1 :sticky "nwes" :columnspan 2) (tcl "grid" (tcl[ "tk::scrollbar" ".f.h" :orient "horizontal" :command ".f.chart1 xview") :column 0 :row 2 :sticky "we" :columnspan 2) (tcl "grid" (tcl[ "ttk::label" ".f.l1" :background "grey") :column 0 :row 3 :sticky "nwes") (tcl "grid" (tcl[ "ttk::label" ".f.l2" :textvariable "meters" :background "red") :column 1 :row 3 :sticky "nwes") - (tcl ".f.chart1" "create" "line" '(30 30 40 40 50 30 600 40) :fill "red" :tags "lll") - ;; (tcl ".f.chart1" "scale" "lll" 0 0 .1 1) - (tcl "image" "create" "photo" "rearview") (tcl "image" "create" "photo" "frontview") (tcl ".f.rearview" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "rearview") (tcl ".f.frontview" "create" "image" (mapcar #'(lambda (x) (/ x 2)) *image-size*) :image "frontview") - (tcl "set" "chartbackground" (tcl[ ".f.chart1" "create" "rectangle" 0 0 0 400 :width 0 :fill "green")) + (tcl "set" "chartbackground" (tcl[ ".f.chart1" "create" "rectangle" 0 0 0 *chart-height* :width 0 :fill "white")) ;; (tcl "set" "ppp" (tcl ".f.chart1" "create" "line" ;; (loop @@ -199,19 +211,57 @@ followed by a digit. " (tcl ".f.chart1" "bind" (lit "$chartbackground") "" "event generate . <> -data [.f.chart1 canvasx %x]") - ;; (prepare-chart 'bew-landstr-kleinpunkte "4252017" "4252011") - ;; (tcl "foreach w [ winfo children .f ] {grid configure $w -padx 5 -pady 5}") ;; (tcl "focus" ".f.feet") - + (chart-dialog) (mainloop))) +(defun zeb-data (column vnk nnk chart-height) + "Return a list of alternating station and column values between vnk +and nnk scaled into chart-height; the minimum column value; and the +maximum column value. Both minimum and maximum are nil if data is +constant." + (with-connection *postgresql-zeb-credentials* + (setf column (intern (string-upcase column))) + (destructuring-bind (minimum maximum) + (mapcar #'(lambda (x) (if (numberp x) + (coerce x 'double-float) + x)) + (query (:select (:min column) + (:max column) + :from (intern *postgresql-zeb-table*) + :where (:and (:= 'vnk vnk) + (:= 'nnk nnk))) + :list)) + (if (and (numberp minimum) (numberp maximum)) + (let* ((span (- maximum minimum)) + (m (if (zerop span) + 0 + (/ chart-height span))) + (b (if (zerop span) + (* chart-height 1/2) + (+ chart-height (* m minimum))))) + (values + (mapcar #'(lambda (x) (if (numberp x) + (coerce x 'double-float) + x)) + (reduce #'nconc + (query (:select 'vst + (:- b (:* m column)) + 'bst + (:- b (:* m column)) + :from (intern *postgresql-zeb-table*) + :where (:and (:= 'vnk vnk) + (:= 'nnk nnk)))))) + (unless (zerop span) minimum) + (unless (zerop span) maximum))) + (values nil nil nil))))) + (defun road-section-dialog () (tcl "tk::toplevel" ".choose-road-section") - (tcl "set" "chooseroadsectiontree" (tcl[ "ttk::treeview" ".choose-road-section.tree" :columns "length number-of-images" :yscrollcommand ".choose-road-section.v set" :height 20)) + (tcl "set" "chooseroadsectiontree" (tcl[ "ttk::treeview" ".choose-road-section.tree" :columns "length number-of-images" :yscrollcommand ".choose-road-section.v set" :height 40)) (tcl "grid" (lit "$chooseroadsectiontree") :column 0 :row 0 :sticky "nwes") (tcl "grid" (tcl[ "tk::scrollbar" ".choose-road-section.v" :orient "vertical" :command ".choose-road-section.tree yview") :column 1 :row 0 :sticky "ns") - ;; (tcl "set" "chart1" (tcl[ "canvas" ".f.chart1" :xscrollcommand ".f.h set")) (tcl "grid" (tcl[ "ttk::button" ".choose-road-section.close-button" :text "close" :command (event-handler* (print *choose-road-section-event*) (unregister-event *choose-road-section-event*) (tcl "destroy" ".choose-road-section"))) @@ -249,14 +299,14 @@ followed by a digit. " (tcl "grid" (tcl[ "ttk::labelframe" ".credentials-dialog.db" :text "database credentials") :column 0 :row 0 :columnspan 5 :sticky "w") (tcl "grid" (tcl[ "ttk::labelframe" ".credentials-dialog.phoros" :text "phoros credentials") :column 0 :row 1 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.hosts" :text "host") :column 0 :row 1 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.ports" :text "port") :column 0 :row 2 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.use-ssls" :text "ssl") :column 0 :row 3 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.databases" :text "database") :column 0 :row 4 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.tables" :text "table") :column 0 :row 5 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.users" :text "user") :column 0 :row 6 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.passwords" :text "password") :column 0 :row 7 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.status" :text "status") :column 0 :row 8 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.hosts" :text "host" :font "TkHeadingFont") :column 0 :row 1 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.ports" :text "port" :font "TkHeadingFont") :column 0 :row 2 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.use-ssls" :text "ssl" :font "TkHeadingFont") :column 0 :row 3 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.databases" :text "database" :font "TkHeadingFont") :column 0 :row 4 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.tables" :text "table" :font "TkHeadingFont") :column 0 :row 5 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.users" :text "user" :font "TkHeadingFont") :column 0 :row 6 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.passwords" :text "password" :font "TkHeadingFont") :column 0 :row 7 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.status" :text "status" :font "TkHeadingFont") :column 0 :row 8 :sticky "w") (destructuring-bind (database user password host &key (port 5432) (use-ssl :no)) *postgresql-road-network-credentials* @@ -267,7 +317,7 @@ followed by a digit. " (tcl "set" "roadnetworktable" *postgresql-road-network-table*) (tcl "set" "roadnetworkuser" user) (tcl "set" "roadnetworkpassword" password)) - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.road-network-header" :text "road network" :width 30) :column 1 :row 0 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.road-network-header" :text "road network" :width 30 :font "TkHeadingFont") :column 1 :row 0 :sticky "w") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-host" :textvariable "roadnetworkhost") :column 1 :row 1 :sticky "we") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.road-network-port" :textvariable "roadnetworkport") :column 1 :row 2 :sticky "we") (tcl "grid" (tcl[ "ttk::checkbutton" ".credentials-dialog.db.roadnetwork-use-ssl" :variable "roadnetworkusessl" :onvalue "yes" :offvalue "no") :column 1 :row 3 :sticky "w") @@ -286,7 +336,7 @@ followed by a digit. " (tcl "set" "zebtable" *postgresql-zeb-table*) (tcl "set" "zebuser" user) (tcl "set" "zebpassword" password)) - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.zeb-header" :text "ZEB" :width 30) :column 2 :row 0 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.zeb-header" :text "ZEB" :width 30 :font "TkHeadingFont") :column 2 :row 0 :sticky "w") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-host" :textvariable "zebhost") :column 2 :row 1 :sticky "we") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.zeb-port" :textvariable "zebport") :column 2 :row 2 :sticky "we") (tcl "grid" (tcl[ "ttk::checkbutton" ".credentials-dialog.db.zeb-use-ssl" :variable "zebusessl" :onvalue "yes" :offvalue "no") :column 2 :row 3 :sticky "w") @@ -305,7 +355,7 @@ followed by a digit. " (tcl "set" "accidentstable" *postgresql-accidents-table*) (tcl "set" "accidentsuser" user) (tcl "set" "accidentspassword" password)) - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.accidents-header" :text "accidents" :width 30) :column 3 :row 0 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.db.accidents-header" :text "accidents" :width 30 :font "TkHeadingFont") :column 3 :row 0 :sticky "w") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-host" :textvariable "accidentshost") :column 3 :row 1 :sticky "we") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.db.accidents-port" :textvariable "accidentsport") :column 3 :row 2 :sticky "we") (tcl "grid" (tcl[ "ttk::checkbutton" ".credentials-dialog.db.accidents-use-ssl" :variable "accidentsusessl" :onvalue "yes" :offvalue "no") :column 3 :row 3 :sticky "w") @@ -319,10 +369,10 @@ followed by a digit. " (tcl "set" "phorosurl" (with-output-to-string (s) (puri:render-uri *phoros-url* s))) (tcl "set" "phorosuser" user) (tcl "set" "phorospassword" password)) - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.url" :text "URL") :column 0 :row 0 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.user" :text "user") :column 0 :row 1 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.password" :text "password") :column 0 :row 2 :sticky "w") - (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.status" :text "status") :column 0 :row 3 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.url" :text "URL" :font "TkHeadingFont") :column 0 :row 0 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.user" :text "user" :font "TkHeadingFont") :column 0 :row 1 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.password" :text "password" :font "TkHeadingFont") :column 0 :row 2 :sticky "w") + (tcl "grid" (tcl[ "ttk::label" ".credentials-dialog.phoros.status" :text "status" :font "TkHeadingFont") :column 0 :row 3 :sticky "w") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.phoros.phoros-url" :textvariable "phorosurl" :width 45) :column 1 :row 0) (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.phoros.phoros-user" :textvariable "phorosuser") :column 1 :row 1 :sticky "we") (tcl "grid" (tcl[ "ttk::entry" ".credentials-dialog.phoros.phoros-password" :textvariable "phorospassword") :column 1 :row 2 :sticky "we") @@ -357,10 +407,6 @@ followed by a digit. " (tcl ".credentials-dialog.check-button" "invoke") - ;; (setf *choose-road-section-event* - ;; (bind-event ".choose-road-section.tree" "" () - ;; (let ((vnk-nnk-length (read-from-string (tcl ".choose-road-section.tree" "focus")))) - ;; (apply #'prepare-chart 'bew-landstr-kleinpunkte vnk-nnk-length)))) (mainloop))) (defun save-credentials (credentials-string) @@ -400,6 +446,40 @@ saved by save-credentials if not) into their respective variables." (setf *phoros-url* (puri:parse-uri phoros-url)) (setf *phoros-credentials* (list phoros-user phoros-password))))))) +(defun save-column-selection (column-selection-string) + "Save input from chart-dialog into cache directory." + (let ((cache-file-name (cache-file-name 'column-selection))) + (ensure-directories-exist cache-file-name) + (with-open-file (stream cache-file-name + :direction :output + :if-exists :supersede) + (prin1 column-selection-string stream)))) + +(defun restore-column-selection (&optional column-selection-string) + "Put database columns selected for rendering (from +column-selection-string if any, or previously saved by +save-column-selection if not) into their respective variables." + (let ((cache-file-name (cache-file-name 'column-selection))) + (with-open-file (stream cache-file-name + :direction :input + :if-does-not-exist nil) + (when (and stream (not column-selection-string)) + (setf column-selection-string (read stream))) + (when column-selection-string + (loop + for column-definition on (cdr (cl-utilities:split-sequence #\Space column-selection-string)) ;ignore purpose string + by #'(lambda (x) (nthcdr 6 x)) ;by number of values per column definition + for (table-kind column-name selectedp color width dash) = column-definition + when (and (string-equal selectedp "1") + (string-equal table-kind "zeb")) + collect (list column-name color width dash) into zeb-column-selection + when (and (string-equal selectedp "1") + (string-equal table-kind "accidents")) + collect (list column-name color width dash) into accidents-column-selection + finally + (setf *zeb-column-selection* zeb-column-selection) + (setf *accidents-column-selection* accidents-column-selection)))))) + (defun check-db (db-credentials table-name &aux result) "Check database connection and presence of table or view table-name. Return a string describing the outcome." @@ -426,6 +506,124 @@ outcome." (:no-error (result) (if result "ok" "wrong user or password"))) (ignore-errors (phoros-logout))))) +(defun chart-dialog () + (flet ((send-column-selection (purpose) + (tcl{ "event" "generate" ".chart-dialog" "<>" + :data (tcl[ "list" + (string purpose) + (with-connection *postgresql-zeb-credentials* + (loop + for (column-name) in (table-description *postgresql-zeb-table*) + collect (lit (concatenate 'string "zeb " column-name " $zeb_" column-name " $zeb_" column-name "_color" " $zeb_" column-name "_width" " $zeb_" column-name "_dash")))) + (with-connection *postgresql-accidents-credentials* + (loop + for (column-name) in (table-description *postgresql-accidents-table*) + collect (lit (concatenate 'string "accidents " column-name " $accidents_" column-name " $accidents_" column-name "_color" " $accidents_" column-name "_width" " $accidents_" column-name "_dash")))))))) + (tcl "tk::toplevel" ".chart-dialog") + (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) + (tcl "grid" (tcl[ "tk::scrollbar" ".chart-dialog.h" :orient "horizontal" :command ".chart-dialog.t xview") :column 0 :row 1 :sticky "we") + (tcl "grid" (tcl[ "tk::scrollbar" ".chart-dialog.v" :orient "vertical" :command ".chart-dialog.t yview") :column 1 :row 0 :sticky "sn") + (tcl ".chart-dialog.t" "window" "create" "end" :window (tcl[ "ttk::frame" ".chart-dialog.t.f")) + (tcl "grid" (tcl[ "ttk::labelframe" ".chart-dialog.t.f.zeb" :text "ZEB" :borderwidth 3 :relief "groove") :column 0 :row 0 :sticky "n") + (tcl "grid" (tcl[ "ttk::labelframe" ".chart-dialog.t.f.accidents" :text "accidents" :borderwidth 3 :relief "groove") :column 1 :row 0 :sticky "ns") + (tcl "grid" (tcl[ "ttk::frame" ".chart-dialog.buttons") :column 2 :row 0 :sticky "n") + (tcl "grid" (tcl[ "ttk::button" ".chart-dialog.buttons.cancel" :text "cancel" :command (tcl{ "destroy" ".chart-dialog")) :column 0 :row 0) + (tcl "grid" (tcl[ "ttk::button" ".chart-dialog.buttons.save" :text "save" :command (send-column-selection :save)) :column 0 :row 1) + (tcl "grid" (tcl[ "ttk::button" ".chart-dialog.buttons.ok" :text "ok" :command (send-column-selection :ok)) :column 0 :row 2) + + (with-connection *postgresql-zeb-credentials* + (present-db-columns (table-description *postgresql-zeb-table*) ".chart-dialog.t.f.zeb" "zeb_" *zeb-column-selection*)) + (with-connection *postgresql-accidents-credentials* + (present-db-columns (table-description *postgresql-accidents-table*) ".chart-dialog.t.f.accidents" "accidents_" *accidents-column-selection*)) + (bind-event ".chart-dialog" "<>" ((payload #\d)) + (let ((purpose (first (cl-utilities:split-sequence #\Space payload)))) + (cond ((string-equal purpose "ok") + (restore-column-selection payload) + (refresh-chart) + (tcl "destroy" ".chart-dialog")) + ((string-equal purpose "save") + (save-column-selection payload))))) + (mainloop))) + +(defun lit$ (tcl-variable) + (lit (concatenate 'string "$" tcl-variable))) + +(defun present-db-columns (columns tcl-path variable-prefix column-selection) + (loop + for (column-name type) in columns + ;; name of checkbutton and trunk of the other element's names + for variable-name = (concatenate 'string variable-prefix column-name) + for path-name = (concatenate 'string tcl-path "." column-name) + ;; rest of the input elements + for label-path-name = (concatenate 'string tcl-path "." column-name "_label") + for width-variable-name = (concatenate 'string variable-name "_width") + for width-path-name = (concatenate 'string tcl-path "." column-name "_width") + for color-variable-name = (concatenate 'string variable-name "_color") + for color-path-name = (concatenate 'string tcl-path "." column-name "_color") + for dash-variable-name = (concatenate 'string variable-name "_dash") + for dash-path-name = (concatenate 'string tcl-path "." column-name "_dash") + for sample-path-name = (concatenate 'string tcl-path "." column-name "_sample") + for sample-line-path-name = (concatenate 'string tcl-path "." column-name "_sample_line") + for i from 0 + do + (when (zerop (mod i 25)) + (let* ((name-header-path-name (concatenate 'string tcl-path "." column-name "_name_header")) + (type-header-path-name (concatenate 'string tcl-path "." column-name "_type_header")) + (width-header-path-name (concatenate 'string tcl-path "." column-name "_width_header")) + (color-header-path-name (concatenate 'string tcl-path "." column-name "_color_header")) + (dash-header-path-name (concatenate 'string tcl-path "." column-name "_dash_header")) + (sample-header-path-name (concatenate 'string tcl-path "." column-name "_sample_header"))) + (tcl "grid" (tcl[ "ttk::label" name-header-path-name :text "column" :font "TkHeadingFont") :column 0 :row i :sticky "w") + (tcl "grid" (tcl[ "ttk::label" type-header-path-name :text "type" :font "TkHeadingFont") :column 1 :row i :sticky "w") + (tcl "grid" (tcl[ "ttk::label" width-header-path-name :text "width" :font "TkHeadingFont") :column 2 :row i :sticky "w") + (tcl "grid" (tcl[ "ttk::label" color-header-path-name :text "color" :font "TkHeadingFont") :column 3 :row i :sticky "w") + (tcl "grid" (tcl[ "ttk::label" dash-header-path-name :text "dash" :font "TkHeadingFont") :column 4 :row i :sticky "w") + (tcl "grid" (tcl[ "ttk::label" sample-header-path-name :text "sample" :font "TkHeadingFont") :column 5 :row i)) + (incf i)) + (let ((selected-column (find column-name column-selection :key #'first :test #'string-equal))) + (tcl "grid" (tcl[ "ttk::checkbutton" path-name :text column-name :variable variable-name) :column 0 :row i :sticky "w") + (tcl "grid" (tcl[ "ttk::label" label-path-name :text type) :column 1 :row i :sticky "w") + (tcl "grid" (tcl[ "tk::spinbox" width-path-name :width 2 :textvariable width-variable-name :values "1 2 3 4 5 6" + :state "readonly" + :command (tcl{ "set" variable-name 1 (lit ";") + sample-path-name "itemconfigure" sample-line-path-name :width (lit$ width-variable-name))) + :column 2 :row i) + (tcl "grid" (tcl[ "ttk::button" color-path-name + :width 1 + :command (tcl{ "set" "tmp" (tcl[ "tk_chooseColor" :initialcolor (lit$ color-variable-name)) + (lit ";") + (lit "if { $tmp != {}} { set") color-variable-name (lit$ "tmp; set") variable-name 1 (lit "}") + (lit ";") + sample-path-name "itemconfigure" sample-line-path-name :fill (lit$ color-variable-name))) + :column 3 :row i) + (tcl "grid" (tcl[ "tk::spinbox" dash-path-name :width 2 :textvariable dash-variable-name :values "{} -.-. --- ... " + :state "readonly" + :command (tcl{ "set" variable-name 1 (lit ";") + sample-path-name "itemconfigure" sample-line-path-name :dash (lit$ dash-variable-name))) :column 4 :row i) + + (tcl "grid" (tcl[ "canvas" sample-path-name :background "white" :width 100 :height 20) :column 5 :row i) + (if selected-column + (progn + (tcl "set" variable-name 1) + (tcl "set" color-variable-name (color selected-column)) + (tcl "set" width-variable-name (line-width selected-column)) + (tcl "set" dash-variable-name (dash selected-column))) + (progn + (tcl "set" variable-name 0) + (tcl "set" color-variable-name "black") + (tcl "set" width-variable-name 2) + (tcl "set" dash-variable-name ""))) + (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))))) + +(defun color (column-definition) + (second column-definition)) + +(defun line-width (column-definition) + (third column-definition)) + +(defun dash (column-definition) + (fourth column-definition)) + (defun add-vnk-nnk-leaf (vnk nnk length number-of-images) "Put a leaf labelled vnk-nnk into road-sections tree." (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 "?")))) @@ -433,21 +631,44 @@ outcome." (defun prepare-chart (table vnk nnk road-section-length) "Prepare chart for the road section between vnk and nnk in table in current database." + (setf *chart-parameters* (list table vnk nnk road-section-length)) (when *jump-to-station-event* (unregister-event *jump-to-station-event*)) - (tcl ".f.chart1" "configure" :scrollregion (format nil "~D ~D ~D ~D" 0 0 road-section-length 400)) - (tcl ".f.chart1" "coords" (lit "$chartbackground") 0 0 road-section-length 400) + (tcl ".f.chart1" "configure" :scrollregion (format nil "~D ~D ~D ~D" 0 0 road-section-length *chart-height*)) + (tcl ".f.chart1" "coords" (lit "$chartbackground") 0 0 road-section-length *chart-height*) + + (draw-zeb-graphs vnk nnk) + (tcl "if" (tcl[ "info" "exists" "cursor") (tcl{ ".f.chart1" "delete" (lit "$cursor"))) - (tcl "set" "cursor" (tcl[ ".f.chart1" "create" "line" 0 0 0 400 :width 2)) + (tcl "set" "cursor" (tcl[ ".f.chart1" "create" "line" 0 0 0 *chart-height* :width 2)) (setf *jump-to-station-event* (bind-event "." "<>" ((station #\d)) (setf station (max 0 ;appearently necessary; not sure why. (round (parse-number:parse-number station)))) (tcl "set" "meters" station) - (tcl ".f.chart1" "coords" (lit "$cursor") station 0 station 400) + (tcl ".f.chart1" "coords" (lit "$cursor") station 0 station *chart-height*) (put-image :table table :vnk vnk :nnk nnk :station station :step 10 :rear-view-p t) (put-image :table table :vnk vnk :nnk nnk :station station :step 10 :rear-view-p nil))) (tcl "event" "generate" "." "<>" :data (tcl[ ".f.chart1" "canvasx" 0))) +(defun refresh-chart () + "Redraw chart." + (when *chart-parameters* (apply #'prepare-chart *chart-parameters*))) + +(defun draw-zeb-graphs (vnk nnk) + "Draw graphs for the columns in *zeb-column-selection*. Delete +existing graphs first." + (tcl ".f.chart1" "delete" (lit "graph")) + (loop + for (column-name color width dash) in *zeb-column-selection* + do (draw-zeb-graph column-name vnk nnk color width dash))) + +(defun draw-zeb-graph (column vnk nnk color width dash) + (multiple-value-bind (line minimum maximum) + (zeb-data column vnk nnk *chart-height*) ;TODO: take care of data with gaps + (print (list :column column :min minimum :max maximum :color color :width width :dash dash)) + (when line + (tcl ".f.chart1" "create" "line" line :tags "graph" :joinstyle "round" :capstyle "round" :fill color :width width :dash dash)))) + (defun put-image (&key table vnk nnk station step rear-view-p) "Put an image along with a labelled station marker on screen." (with-connection *postgresql-road-network-credentials* -- 2.11.4.GIT