Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -2204,30 +2204,40 @@ ;; (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? +;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; -(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) +(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) + (let ((collision #f) + (lastrow (if num-rows (+ rownum num-rows) rownum))) + (let loop ((i 0) + (rowdat (hash-table-ref/default rowhash rownum '()))) + (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) + (if (< i lastrow) + (loop (+ i 1) + (hash-table-ref/default rowhash (+ rownum i) '())))) 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:add-bar rowhash rownum x1 x2 #!key (num-rows 0)) + (let loop ((i 0)) + (hash-table-set! rowhash + (+ i rownum) + (cons (cons x1 x2) + (hash-table-ref/default rowhash (+ i rownum) '()))) + (if (< i num-rows) + (loop (+ i 1))))) ;; get min or max, use > for max and < for min, this works around the limits on apply ;; (define (dboard:min-max comp lst) (if (null? lst) @@ -2245,37 +2255,39 @@ ;; first group items into lists, then sort by time ;; finally sort by first item time ;; (define (dboard:tests-sort-by-time-group-by-item testsdat) - (let* ((tests (let ((ht (make-hash-table))) - (for-each - (lambda (tdat) - (let ((testname (db:test-get-testname tdat))) - (hash-table-set! - ht - testname - (cons tdat (hash-table-ref/default ht testname '()))))) - testsdat) - ht))) - ;; remove toplevel tests from iterated tests, sort tests in the list by event time - (for-each - (lambda (testname) - (let ((testslst (hash-table-ref tests testname))) - (if (> (length testslst) 1) ;; must be iterated - (hash-table-set! tests - testname - (dboard:sort-testsdat-by-event-time - (filter (lambda (tdat) - (equal? (db:test-get-item-path tdat) "")) - testslst))) - ))) - (hash-table-keys tests)) - (sort (hash-table-values tests) - (lambda (a b) - (< (db:test-get-event_time (car a)) - (db:test-get-event_time (car b))))))) + (if (null? testsdat) + testsdat + (let* ((tests (let ((ht (make-hash-table))) + (for-each + (lambda (tdat) + (let ((testname (db:test-get-testname tdat))) + (hash-table-set! + ht + testname + (cons tdat (hash-table-ref/default ht testname '()))))) + testsdat) + ht))) + ;; remove toplevel tests from iterated tests, sort tests in the list by event time + (for-each + (lambda (testname) + (let ((testslst (hash-table-ref tests testname))) + (if (> (length testslst) 1) ;; must be iterated + (let ((item-tests (filter (lambda (tdat) ;; filter out toplevel tests + (not (equal? (db:test-get-item-path tdat) ""))) + testslst))) + (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition + (hash-table-set! tests + testname + (dboard:sort-testsdat-by-event-time item-tests))))))) + (hash-table-keys tests)) + (sort (hash-table-values tests) + (lambda (a b) + (< (db:test-get-event_time (car a)) + (db:test-get-event_time (car b)))))))) (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 @@ -2382,43 +2394,60 @@ ;; (dashboard:add-bar rowhash start-row x (+ x 100))) (set! start-row (+ start-row 1)) ;; get tests in list sorted by event time ascending (for-each (lambda (testdats) - (for-each - (lambda (testdat) - (let* ((event-time (maptime (db:test-get-event_time testdat))) - (run-duration (* timescale (db:test-get-run_duration testdat))) - (end-time (+ event-time run-duration)) - (test-name (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) - (state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (test-fullname (conc test-name "/" item-path)) - (name-color (gutils:get-color-for-state-status state status))) - ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) - ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) - (let loop ((rownum run-start-row)) ;; (+ start-row 1))) - (set! max-row (max rownum max-row)) ;; track the max row used - (if (dashboard:row-collision rowhash rownum event-time end-time) - (loop (+ rownum 1)) - (let* ((lly (- sizey (* 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 - fill-color: (vg:iup-color->number (car name-color)) - text: (conc test-name "/" item-path) - font: "Helvetica -10") - ;; (vg:make-text (+ event-time 2) - ;; (+ lly 2) - ;; (conc test-name "/" item-path) - ;; font: "Helvetica -10") - )))) - ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) - )) - testdats)) + (let ((test-objs '()) + (iterated (> (length testdats) 1)) + (first-rownum #f) + (num-items (length testdats))) + (for-each + (lambda (testdat) + (let* ((event-time (maptime (db:test-get-event_time testdat))) + (run-duration (* timescale (db:test-get-run_duration testdat))) + (end-time (+ event-time run-duration)) + (test-name (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (test-fullname (conc test-name "/" item-path)) + (name-color (gutils:get-color-for-state-status state status))) + ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) + ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) + (let loop ((rownum run-start-row)) ;; (+ start-row 1))) + (set! max-row (max rownum max-row)) ;; track the max row used + (if (dashboard:row-collision rowhash rownum event-time end-time) + (loop (+ rownum 1)) + (let* ((lly (- sizey (* rownum row-height))) + (uly (+ lly row-height)) + (obj (vg:make-rect event-time lly end-time uly + fill-color: (vg:iup-color->number (car name-color)) + text: (if iterated item-path test-name) + font: "Helvetica -10"))) + ;; (if iterated + ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items)) + (if (not first-rownum) + (begin + (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items) + (set! first-rownum rownum))) + (dashboard:add-bar rowhash rownum event-time end-time) + (vg:add-objs-to-comp runcomp obj) + (set! test-objs (cons obj test-objs))))) + ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) + )) + testdats) + ;; If it is an iterated test put box around it now. + (if iterated + (let* ((xtents (vg:get-extents-for-objs drawing test-objs)) + (llx (- (car xtents) 5)) + (lly (- (cadr xtents) 10)) + (ulx (+ 5 (caddr xtents))) + (uly (+ 0 (cadddr xtents)))) + (dashboard:add-bar rowhash first-rownum llx ulx num-rows: num-items) + (vg:add-objs-to-comp runcomp (vg:make-rect llx lly ulx uly + text: (db:test-get-testname (car testdats)) + font: "Helvetica -10")))))) hierdat) ;; placeholder box (set! max-row (+ max-row 1)) (let ((y (- sizey (* max-row row-height)))) (vg:add-objs-to-comp runcomp (vg:make-rect 0 y 0 y))) Index: vg-test.scm ================================================================== --- vg-test.scm +++ vg-test.scm @@ -11,13 +11,13 @@ (define d1 (vg:drawing-new)) (define l1 (vg:lib-new)) (define c1 (vg:comp-new)) (define c2 (vg:comp-new)) -(let ((r1 (vg:make-rect 20 20 40 40 text: "r1" font: "Helvetica, -20")) - (r2 (vg:make-rect 40 40 80 80 text: "r2" font: "Helvetica, -10")) - (t1 (vg:make-text 40 40 "The middle" font: "Helvetica, -10"))) +(let ((r1 (vg:make-rect 20 20 30 30 text: "r1" font: "Helvetica, -20")) + (r2 (vg:make-rect 30 30 60 60 text: "r2" font: "Helvetica, -10")) + (t1 (vg:make-text 60 60 "The middle" font: "Helvetica, -10"))) (vg:add-objs-to-comp c1 r1 r2 t1)) ;; add the c1 component to lib l1 with name firstcomp (vg:add-comp-to-lib l1 "firstcomp" c1) (vg:add-comp-to-lib l1 "secondcomp" c2) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -168,33 +168,45 @@ ;; get component from drawing (look in apropriate lib) given libname and compname (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:get-extents-for-objs drawing objs) + (let ((extents #f)) + (for-each + (lambda (obj) + (set! extents + (vg:get-extents-for-two-rects + extents + (vg:obj-get-extents drawing obj)))) + objs) + extents)) + +;; given rectangles r1 and r2, return the box that bounds both +;; +(define (vg:get-extents-for-two-rects r1 r2) + (if (not r1) + r2 + (if (not r2) + #f ;; no extents from #f #f + (list (min (car r1)(car r2)) ;; llx + (min (cadr r1)(cadr r2)) ;; lly + (max (caddr r1)(caddr r2)) ;; ulx + (max (cadddr r1)(cadddr r2)))))) ;; uly (define (vg:components-get-extents drawing . comps) - (let ((llx #f) - (lly #f) - (ulx #f) - (uly #f)) + (let ((extents #f)) (for-each (lambda (comp) - (let ((objs (vg:comp-objs comp))) - (for-each - (lambda (obj) - (let* ((extents (vg:obj-get-extents drawing 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 lly))(set! lly olly)) - (if (or (not ulx)(> oulx ulx))(set! ulx oulx)) - (if (or (not uly)(> ouly uly))(set! uly ouly)))) - objs))) + (let* ((objs (vg:comp-objs comp))) + (set! extents + (vg:get-extents-for-two-rects + extents + (vg:get-extents-for-objs drawing objs))))) comps) - (list llx lly ulx uly))) + extents)) ;;====================================================================== ;; libraries ;;====================================================================== @@ -338,11 +350,18 @@ (let* ((prev-font (canvas-font cnv)) (font-changed (and font (not (equal? font prev-font))))) (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) (if font-changed (canvas-font-set! cnv prev-font)))))) - pts)) ;; return extents + (if (not text) + pts + (if cnv + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax)))) + pts)))) ;; return extents ;; given a rect obj draw it on the canvas applying first the drawing ;; scale and offset ;; (define (vg:draw-text drawing obj #!key (draw #t))