Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1013,12 +1013,11 @@ ;; ;; A gui for launching tests ;; (define (dashboard:run-times commondat tabdat #!key (tab-num #f)) ;; (dashboard:run-times-tab-updater commondat tab-num) - (let ((drawing (vg:drawing-new)) - (lib1 (vg:lib-new)) + (let ((drawing (vg:drawing-new)) (run-times-tab-updater (lambda () (dashboard:run-times-tab-updater commondat tab-num)))) (dboard:tabdat-drawing-set! tabdat drawing) (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num) (iup:vbox @@ -1865,14 +1864,46 @@ (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat)))) (dboard:commondat-please-update-set! commondat #f) recalc)) +;; point inside line +;; +(define-inline (dashboard:px-between px lx1 lx2) + (and (< lx1 px)(> lx2 px))) + +;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing +;; bars? +;; +(define (dashboard:row-collision rowhash rownum x1 x2) + (let ((rowdat (hash-table-ref/default rowhash rownum '())) + (collision #f)) + (for-each + (lambda (bar) + (let ((bx1 (car bar)) + (bx2 (cdr bar))) + (cond + ;; newbar x1 inside bar + ((dashboard:px-between x1 bx1 bx2)(set! collision #t)) + ((dashboard:px-between x2 bx1 bx2)(set! collision #t)) + ((and (<= x1 bx1)(>= x2 bx2))(set! collision #t))))) + rowdat) + collision)) + +(define-inline (dashboard:add-bar rowhash rownum x1 x2) + (hash-table-set! rowhash rownum (cons (cons x1 x2) + (hash-table-ref/default rowhash rownum '())))) + (define (dashboard:run-times-tab-updater commondat tab-num) + ;; each test is an object in the run component + ;; each run is a component + ;; all runs stored in runslib library (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (if tabdat - (begin + (let* ((row-height 10) + (drawing (dboard:tabdat-drawing tabdat)) + (runslib (vg:get/create-lib drawing "runslib"))) (update-rundat tabdat "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 100 ;; (dboard:tabdat-numruns tabdat) "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") @@ -1881,11 +1912,12 @@ (if (not (equal? key "runname")) (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) (if val (set! res (cons (list key val) res)))))) (dboard:tabdat-dbkeys tabdat)) res)) - (let ((allruns (dboard:tabdat-allruns tabdat))) + (let ((allruns (dboard:tabdat-allruns tabdat)) + (rowhash (make-hash-table))) ;; store me in tabdat (print "allruns: " allruns) (for-each (lambda (rundat) (if (vector? rundat) (let* ((run (vector-ref rundat 0)) @@ -1897,20 +1929,32 @@ (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) (if x x ""))))) (run-key (string-intersperse key-vals "\n")) + (run-full-name (string-intersperse key-vals "/")) (runcomp (vg:comp-new));; new component for this run (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) (row-height 4)) + (vg:add-comp-to-lib runslib run-full-name runcomp) ;; get tests in list sorted by event time ascending (for-each (lambda (testdat) - (let ((event-time (db:test-get-event_time testdat)) - (run-duration (db:test-get-run_duration testdat)) - (test-name (db:test-get-testname testdat))) - (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration))) + (let* ((event-time (/ (db:test-get-event_time testdat) 60)) + (run-duration (/ (db:test-get-run_duration testdat) 60)) + (end-time (+ event-time run-duration)) + (test-name (db:test-get-testname testdat)) + (item-path (db:test-get-item_path testdat))) + (let loop ((rownum 0)) + (if (dashboard:row-collision rowhash rownum event-time end-time) + (loop (+ rownum 1)) + (let* ((lly (* rownum row-height)) + (uly (+ lly row-height))) + (dashboard:add-bar rowhash rownum event-time end-time) + (vg:add-objs-to-comp runcomp (vg:make-rect event_time lly end-time uly))))) + ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) + )) testsdat)))) allruns) (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj) (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj) (vg:draw (dboard:tabdat-drawing tabdat)) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -37,14 +37,33 @@ ;; make a rectangle obj ;; (define (vg:make-rect x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)) (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: #f line-color: line-color fill-color: fill-color)) +;; get extents, use knowledge of type ... +;; +(define (vg:obj-get-extents obj) + (let ((type (vg:obj-type obj))) + (case type + ((r)(vg:rect-get-extents obj))))) + +(define (vg:rect-get-extents obj) + (vg:obj-pts obj)) ;; extents are just the points for a rectangle + +;;====================================================================== +;; components +;;====================================================================== + ;; add obj to comp ;; (define (vg:add-objs-to-comp comp . objs) (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs))) + +;; use the struct. leave this here to remind of this! +;; +;; (define (vg:comp-get-objs comp) +;; (vg:comp-objs comp)) ;; add comp to lib ;; (define (vg:add-comp-to-lib lib compname comp) (hash-table-set! (vg:lib-comps lib) compname comp)) @@ -59,14 +78,51 @@ (define (vg:get-component drawing libname compname) (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname)) (inst (hash-table-ref (vg:lib-comps lib) compname))) inst)) +(define (vg:component-get-extents comp) + (let ((llx #f) + (lly #f) + (ulx #f) + (uly #f) + (objs (vg:comp-objs comp))) + (for-each + (lambda (obj) + (let* ((extents (vg:get-extents obj)) + (ollx (list-ref extents 0)) + (olly (list-ref extents 1)) + (oulx (list-ref extents 2)) + (ouly (list-ref extents 3))) + (if (or (not llx)(< ollx llx))(set! llx ollx)) + (if (or (not lly)(< olly llx))(set! llx ollx)) + (if (or (not ulx)(< ollx llx))(set! llx ollx)) + (if (or (not uly)(< ollx llx))(set! llx ollx)))) + objs) + (list llx lly ulx uly))) + + +;;====================================================================== +;; libraries +;;====================================================================== + ;; register lib with drawing + ;; (define (vg:add-lib drawing libname lib) (hash-table-set! (vg:drawing-libs drawing) libname lib)) + +(define (vg:get-lib drawing libname) + (hash-table-ref/default (vg:drawing-libs drawing) libname #f)) + +(define (vg:get/create-lib drawing libname) + (let ((lib (vg:get-lib drawing libname))) + (if lib + lib + (let ((newlib (vg:lib-new))) + (vg:add-lib drawing libname newlib) + newlib)))) ;;====================================================================== ;; map objects given offset, scale and mirror ;;======================================================================