| ︙ | | | ︙ | |
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
start-test-offset ;; up-down slider value
;; Canvas and drawing data
cnv
cnv-obj
drawing
draw-cache ;;
;; Controls used to launch runs etc.
command
command-tb
run-name ;; from run name setting widget
states ;; states for -state s1,s2 ...
statuses ;; statuses for -status s1,s2 ...
|
>
>
>
|
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
start-test-offset ;; up-down slider value
;; Canvas and drawing data
cnv
cnv-obj
drawing
draw-cache ;;
start-row
run-start-row
max-row
;; Controls used to launch runs etc.
command
command-tb
run-name ;; from run name setting widget
states ;; states for -state s1,s2 ...
statuses ;; statuses for -status s1,s2 ...
|
| ︙ | | | ︙ | |
264
265
266
267
268
269
270
271
272
273
274
275
276
277
|
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))
(define (dboard:setup-tabdat tabdat)
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
|
>
>
|
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
|
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
run-start-row: 0
max-row: 0
)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
|
| ︙ | | | ︙ | |
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
|
(db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
(define (dashboard:run-times-tab-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)
(start-row 0) ;; each run starts in this row
(run-start-row 0)
(max-row 0) ;; the max row seen for this run
(row-height 10)
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
(vector-ref runs-dat 1))
ht))
(run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a runs-header "event_time"))
(time-b (db:get-value-by-header record-b runs-header "event_time")))
(< time-a time-b)))))
(tb (dboard:tabdat-runs-tree tabdat))
(num-runs (length (hash-table-keys runs-hash)))
(run-num 0)
|
|
|
|
<
|
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
|
(db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
(define (dashboard:run-times-tab-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)
;; (start-row 0) ;; each run starts in this row
;; (run-start-row 0)
;; (max-row 0) ;; the max row seen for this run
(row-height 10)
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
(vector-ref runs-dat 1))
ht))
(run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a runs-header "event_time"))
(time-b (db:get-value-by-header record-b runs-header "event_time")))
(< time-a time-b)))))
(tb (dboard:tabdat-runs-tree tabdat))
(num-runs (length (hash-table-keys runs-hash)))
(update-start-time (current-seconds)))
;; fill in the tree
(if tb (for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
(dboard:tabdat-keys tabdat)))
(run-name (db:get-value-by-header run-record runs-header "runname"))
|
| ︙ | | | ︙ | |
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
|
(cnv (dboard:tabdat-cnv tabdat)))
(print "allruns: " allruns)
(let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv)))
;; (print "allruns: " allruns)
(let runloop ((rundat (car allruns))
(runtal (cdr allruns))
(doneruns '()))
(let* ((run (dboard:rundat-run rundat))
(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))
(key-val-dat (dboard:rundat-key-vals rundat))
(run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
|
>
|
>
|
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
|
(cnv (dboard:tabdat-cnv tabdat)))
(print "allruns: " allruns)
(let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv)))
;; (print "allruns: " allruns)
(let runloop ((rundat (car allruns))
(runtal (cdr allruns))
(run-num 1)
(doneruns '())
(run-start-row 0))
(let* ((run (dboard:rundat-run rundat))
(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))
(key-val-dat (dboard:rundat-key-vals rundat))
(run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
|
| ︙ | | | ︙ | |
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
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
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
|
(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))
(test-num 0)
(tot-tests (length testsdat)))
(set! run-num (+ run-num 1))
(set! run-start-row (+ max-row 2))
(set! start-row run-start-row)
;; this is the run title. move this into the box
;; (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 (test-ids)
(let ((test-objs '())
(iterated (> (length test-ids) 1))
(first-rownum #f)
(num-items (length test-ids))
(item-num 0))
(set! test-num (+ test-num 1))
(for-each
(lambda (test-id)
(let* ((testdat (hash-table-ref tests-ht test-id))
(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)))
(set! item-num (+ item-num 1))
;; (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 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-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)
(set! test-objs (cons obj test-objs)))))
;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
))
test-ids)
;; 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-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"))))))
hierdat)
;; placeholder box
(set! max-row (+ max-row 1))
(let ((y (- sizey (* max-row row-height))))
(vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
;; instantiate the component
(let* ((extents (vg:components-get-extents drawing runcomp))
;; move the following into mapping functions in vg.scm
;; (deltax (- llx ulx))
;; (scalex (if (> deltax 0)(/ sizex deltax) 1))
;; (sllx (* scalex llx))
;; (offx (- sllx originx))
(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))
(vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))
(set! max-row (+ max-row 1)))
;; 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 (> (- (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-non-done-runs-set! tabdat tal))
(runloop (car runtal)(cdr runtal) newdoneruns)))))
(vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj)
(canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj)
(print "Number of objs: " (length (vg:draw (dboard:tabdat-drawing tabdat) #t)))
(dboard:tabdat-view-changed-set! tabdat #f)
)))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
|
<
|
|
|
|
<
<
<
<
<
<
<
>
>
|
|
>
>
|
<
<
<
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
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
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
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
|
(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))
(new-run-start-row (+ (dboard:tabdat-max-row tabdat) 2)))
;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
(vg:add-comp-to-lib runslib run-full-name runcomp)
;; (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))
(let ((test-objs '())
(iterated (> (length test-ids) 1))
(first-rownum #f)
(num-items (length test-ids)))
(let testitemloop ((test-id (car test-ids)) ;; loop on test or test items
(tidstal (cdr test-ids))
(item-num 1))
(let* ((testdat (hash-table-ref tests-ht test-id))
(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)
(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 new-run-start-row)) ;; (+ start-row 1)))
(dboard:tabdat-max-row-set! tabdat (max 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 (- 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)
(set! test-objs (cons obj test-objs)))))
;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
(if (not (null? tidstal))
(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 first-rownum 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"))))
(if (not (null? tests-tal))
(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 (- 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
(let* ((extents (vg:components-get-extents drawing runcomp))
;; move the following into mapping functions in vg.scm
;; (deltax (- llx ulx))
;; (scalex (if (> deltax 0)(/ sizex deltax) 1))
;; (sllx (* scalex llx))
;; (offx (- sllx originx))
(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))
(vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)))
;; 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 (> (- (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))
(runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns new-run-start-row)))))
(vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj)
(canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj)
(print "Number of objs: " (length (vg:draw (dboard:tabdat-drawing tabdat) #t)))
(dboard:tabdat-view-changed-set! tabdat #f)
)))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
|
| ︙ | | | ︙ | |