Overview
| Comment: | Bit better on the layout, still broken |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.61 |
| Files: | files | file ages | folders |
| SHA1: |
1fd3017375d114918282c48a18817c32 |
| User & Date: | matt on 2016-07-23 23:26:59 |
| Other Links: | branch diff | manifest | tags |
Context
|
2016-07-23
| ||
| 23:29 | Bit better on the layout, still broken check-in: 738b9f950c user: matt tags: v1.61 | |
| 23:26 | Bit better on the layout, still broken check-in: 1fd3017375 user: matt tags: v1.61 | |
| 21:57 | Incremental drawing now working. check-in: efed051fe1 user: matt tags: v1.61 | |
Changes
Modified dashboard.scm from [c13d28ecc7] to [7ca6ec0324].
| ︙ | ︙ | |||
2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 |
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
(vch (dboard:tabdat-view-changed tabdat)))
(if (and cnv dwg vch)
(begin
(mutex-lock! mtx)
(canvas-clear! cnv)
(vg:draw dwg tabdat)
(mutex-unlock! mtx)
(dboard:tabdat-view-changed-set! tabdat #f)))))
;; run times tab
;;
(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
;; each test is an object in the run component
;; each run is a component
;; all runs stored in runslib library
(let* ((canvas-margin 10)
(row-height 10)
(not-done-runs (dboard:tabdat-not-done-runs tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat)))
(if tabdat
(let* ((drawing (dboard:tabdat-drawing tabdat))
(runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
(compute-start (current-seconds)))
| > > < < | | > > | < | > < > > | | 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 |
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
(vch (dboard:tabdat-view-changed tabdat)))
(if (and cnv dwg vch)
(begin
(vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
(vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
(mutex-lock! mtx)
(canvas-clear! cnv)
(vg:draw dwg tabdat)
(mutex-unlock! mtx)
(dboard:tabdat-view-changed-set! tabdat #f)))))
;; run times tab
;;
(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
;; each test is an object in the run component
;; each run is a component
;; all runs stored in runslib library
(let* ((canvas-margin 10)
(row-height 10)
(not-done-runs (dboard:tabdat-not-done-runs tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat)))
(if tabdat
(let* ((drawing (dboard:tabdat-drawing tabdat))
(runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
(compute-start (current-seconds)))
(let* ((allruns (dboard:tabdat-allruns tabdat))
(num-runs (length allruns))
(cnv (dboard:tabdat-cnv tabdat)))
(print "allruns: " allruns)
(let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv))
((calc-y) (lambda (rownum)
(- sizey (* rownum row-height)))))
;; (print "allruns: " allruns)
(let runloop ((rundat (car allruns))
(runtal (cdr allruns))
(run-num 1)
(doneruns '()))
(let* ((run (dboard:rundat-run rundat))
(rowhash (make-hash-table)) ;; store me in tabdat
(key-val-dat (dboard:rundat-key-vals rundat))
(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 "/"))
(last-run-max-row (dboard:tabdat-max-row tabdat)))
(if (not (vg:lib-get-component runslib run-full-name))
(let* ((hierdat (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat))) ;; hierarchial list of ids
(tests-ht (dboard:rundat-tests rundat))
(all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat
(testsdat (hash-table-values tests-ht))
(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)
(run-start (dboard:min-max < (map db:test-get-event_time testsdat)))
(run-end (dboard:min-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))
(if (> run-duration 0)
run-duration
(current-seconds)))) ;; a least lously guess
(maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
(num-tests (length hierdat))
(tot-tests (length testsdat))
)
;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
(mutex-lock! mtx)
(vg:add-comp-to-lib runslib run-full-name runcomp)
;; Have to keep moving the instantiated box as it is anchored at the lower left
(vg:instantiate drawing "runslib" run-full-name run-full-name 0 (calc-y last-run-max-row)) ;; 0) ;; (calc-y (dboard:tabdat-max-row tabdat)))
(mutex-unlock! mtx)
;; (set! run-start-row (+ max-row 2))
;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
;; get tests in list sorted by event time ascending
(let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
(tests-tal (cdr hierdat))
(test-num 1))
|
| ︙ | ︙ | |||
2598 2599 2600 2601 2602 2603 2604 | (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) (if (> item-num 50) (if (eq? 0 (modulo item-num 50)) (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) | | > | | | | | | > | > | | > > | | 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 |
(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)
(if (> item-num 50)
(if (eq? 0 (modulo item-num 50))
(print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
(let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1)))
(dboard:tabdat-max-row-set! tabdat (max (+ last-run-max-row rownum)
(dboard:tabdat-max-row tabdat))) ;; track the max row used
(if (dashboard:row-collision rowhash rownum event-time end-time)
(loop (+ rownum 1))
(let* ((lly (calc-y rownum)) ;; (- sizey (* rownum row-height)))
(uly (+ lly row-height))
(obj (vg:make-rect-obj 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-obj-to-comp runcomp obj)
;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat)))
(dboard:tabdat-view-changed-set! tabdat #t)
(set! test-objs (cons obj test-objs)))))
;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
(let ((newdoneruns (cons rundat doneruns)))
(if (not (null? tidstal))
(if #f ;; (> (- (current-seconds) update-start-time) 5)
(begin
(print "drawing runs taking too long.... have " (length runtal) " remaining")
;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
;; (dboard:tabdat-not-done-runs-set! tabdat runtal)
)
(testitemloop (car tidstal)(cdr tidstal)(+ item-num 1)))))))
;; 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 0 llx ulx num-rows: num-items)
(vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
font: "Helvetica -10"))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
(dboard:tabdat-view-changed-set! tabdat #t) ;; trigger a redraw
))
(if (not (null? tests-tal))
(if #f ;; (> (- (current-seconds) update-start-time) 5)
(print "drawing runs taking too long")
(testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1))))))
;; placeholder box
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
(let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
(vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
;; instantiate the component
(mutex-lock! mtx)
(let* ((extents (vg:components-get-extents drawing runcomp))
(new-xtnts (apply vg:grow-rect 5 5 extents))
(llx (list-ref new-xtnts 0))
(lly (list-ref new-xtnts 1))
(ulx (list-ref new-xtnts 2))
(uly (list-ref new-xtnts 3))
) ;; (vg:components-get-extents d1 c1)))
(vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name)))
(mutex-unlock! mtx)
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
)
;; end of the run handling loop
(let ((newdoneruns (cons rundat doneruns)))
(if (null? runtal)
(begin
(dboard:tabdat-not-done-runs-set! tabdat '())
(dboard:tabdat-done-runs-set! tabdat allruns))
(if #f ;; (> (- (current-seconds) update-start-time) 5)
(begin
(print "drawing runs taking too long.... have " (length runtal) " remaining")
;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
(dboard:tabdat-not-done-runs-set! tabdat runtal))
(runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns))))))) ;; new-run-start-row
)))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
(let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
|
| ︙ | ︙ |
Modified vg.scm from [e3c87e0aa9] to [a4aecf3ba5].
| ︙ | ︙ | |||
176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
(hash-table-set! (vg:lib-comps lib) compname comp))
;; instanciate component in drawing
;;
(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
(let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
(hash-table-set! (vg:drawing-insts drawing) instname inst)))
;; 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))
| > > > > > | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
(hash-table-set! (vg:lib-comps lib) compname comp))
;; instanciate component in drawing
;;
(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
(let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
(hash-table-set! (vg:drawing-insts drawing) instname inst)))
(define (vg:instance-move drawing instname newx newy)
(let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
(vg:inst-xoff-set! inst newx)
(vg:inst-yoff-set! inst newy)))
;; 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))
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
;; 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)
| | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
;; 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)
r1 ;; #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 ((extents #f))
|
| ︙ | ︙ |