Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -200,11 +200,14 @@ statuses target test-patts tests tests-tree - tot-runs + tot-runs + view-changed + xadj + yadj ) (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) @@ -238,10 +241,13 @@ searchpatts: (make-hash-table) start-run-offset: 0 start-test-offset: 0 state-ignore-hash: (make-hash-table) status-ignore-hash: (make-hash-table) + xadj: 0 + yadj: 0 + view-changed: #t ))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) @@ -1029,21 +1035,30 @@ #:posy "0.5" #:action (make-canvas-action (lambda (c xadj yadj) (if (not (dboard:tabdat-cnv tabdat)) (dboard:tabdat-cnv-set! tabdat c)) - (let ((drawing (dboard:tabdat-drawing tabdat))) - #f ;; finish me!! - ))) + (let ((drawing (dboard:tabdat-drawing tabdat)) + (old-xadj (dboard:tabdat-xadj tabdat)) + (old-yadj (dboard:tabdat-yadj tabdat))) + (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) + (begin + (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:tabdat-xadj-set! tabdat (* -500 (- xadj 0.5))) + (dboard:tabdat-yadj-set! tabdat (* 500 (- yadj 0.5))) + ))))) #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. (let* ((drawing (dboard:tabdat-drawing tabdat)) (scalex (vg:drawing-scalex drawing))) + (dboard:tabdat-view-changed-set! tabdat #t) + (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) (vg:drawing-scalex-set! drawing (+ scalex (if (> step 0) - (* scalex 0.01) - (* scalex -0.01)))))) + (* scalex 0.02) + (* scalex -0.02)))))) ))) cnv-obj)))) ;;====================================================================== ;; S U M M A R Y @@ -1909,15 +1924,18 @@ ;; 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)) (canvas-margin 10) - (start-row 0)) ;; each run starts in this row - (if tabdat - (let* ((row-height 20) - (drawing (dboard:tabdat-drawing tabdat)) + (start-row 0) ;; each run starts in this row + (row-height 10)) + (if (and tabdat + (dboard:tabdat-view-changed tabdat)) + (let* ((drawing (dboard:tabdat-drawing tabdat)) (runslib (vg:get/create-lib drawing "runslib"))) ;; creates and adds lib + (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat)) + (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat)) (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" "%") @@ -1931,11 +1949,11 @@ (let ((allruns (dboard:tabdat-allruns tabdat)) (rowhash (make-hash-table)) ;; store me in tabdat (cnv (dboard:tabdat-cnv tabdat))) (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) - (print "allruns: " allruns) + ;; (print "allruns: " allruns) (for-each (lambda (rundat) (if (vector? rundat) (let* ((run (vector-ref rundat 0)) (testsdat (sort (vector-ref rundat 1) @@ -1949,11 +1967,11 @@ (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) + ;; (row-height 4) (run-start (apply min (map db:test-get-event_time testsdat))) (run-end (apply max (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat))) (timeoffset (- (+ originx canvas-margin) run-start)) (run-duration (- run-end run-start)) (timescale (/ (- sizex (* 2 canvas-margin)) @@ -1961,15 +1979,16 @@ run-duration (current-seconds)))) ;; a least lously guess (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))) ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) (vg:add-comp-to-lib runslib run-full-name runcomp) - (vg:add-objs-to-comp runcomp (vg:make-text - 10 - (- sizey (* start-row row-height)) - run-full-name - font: "Helvetica -10")) + (set! start-row (+ start-row 1)) + (let ((x 10) + (y (- sizey (* start-row row-height)))) + (vg:add-objs-to-comp runcomp (vg:make-text x y run-full-name font: "Helvetica -10")) + (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 (testdat) (let* ((event-time (maptime (db:test-get-event_time testdat))) (run-duration (* timescale (db:test-get-run_duration testdat))) @@ -1987,14 +2006,20 @@ (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: - ;; (string->number (string-substitute " " "" (car name-color)))))))) - (vg:iup-color->number (car name-color))))))) + (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) )) testsdat) ;; instantiate the component (let* ((extents (vg:components-get-extents drawing runcomp)) @@ -2013,11 +2038,12 @@ (vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))))) ;; scalex: scalex scaley: 1))))) allruns) (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj) (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj) - (print "All objs: " (vg:draw (dboard:tabdat-drawing tabdat) #t)) + (print "Number of objs: " (length (vg:draw (dboard:tabdat-drawing tabdat) #t))) + (dboard:tabdat-view-changed-set! tabdat #f) ))) (print "no tabdat for run-times-tab-updater")))) (define (dashboard:runs-tab-updater commondat tab-num) (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) Index: vg-test.scm ================================================================== --- vg-test.scm +++ vg-test.scm @@ -11,12 +11,12 @@ (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)) - (r2 (vg:make-rect 40 40 80 80)) +(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"))) (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) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -99,12 +99,12 @@ ;; inst ;; (vg:drawing-apply-scale drawing lstxy))) ;; 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)) +(define (vg:make-rect x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)) + (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color)) ;; make a text obj ;; (define (vg:make-text x1 y1 text #!key (line-color #f)(fill-color #f) (angle #f)(scale-with-zoom #f)(font #f) @@ -228,11 +228,11 @@ (else #f))) ;; given a drawing and a inst map a rectangle to it screen coordinates ;; (define (vg:map-rect drawing inst obj) - (let ((res (make-vg:obj type: 'r + (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy? fill-color: (vg:obj-fill-color obj) text: (vg:obj-text obj) line-color: (vg:obj-line-color obj) font: (vg:obj-font obj))) (pts (vg:obj-pts obj))) @@ -311,16 +311,18 @@ (define (vg:draw-rect drawing obj #!key (draw #t)) (let* ((cnv (vg:drawing-cnv drawing)) (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) (fill-color (vg:obj-fill-color obj)) (line-color (vg:obj-line-color obj)) - (llx (car pts)) - (lly (cadr pts)) - (ulx (caddr pts)) - (uly (cadddr pts)) - (w (- ulx llx)) - (h (- uly lly))) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly))) (if draw (let ((prev-background-color (canvas-background cnv)) (prev-foreground-color (canvas-foreground cnv))) (if fill-color (begin @@ -329,11 +331,17 @@ (if line-color (canvas-foreground-set! cnv line-color) (if fill-color (canvas-foreground-set! cnv prev-foreground-color))) (canvas-rectangle! cnv llx ulx lly uly) - (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (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 ;; given a rect obj draw it on the canvas applying first the drawing ;; scale and offset ;;