Megatest

Check-in [ae5d869b0c]
Login
Overview
Comment:reorganised code layout for run times canvas view
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: ae5d869b0c437093339e5a1b96ca1ad19d091deb
User & Date: matt on 2016-07-23 20:59:40
Other Links: branch diff | manifest | tags
Context
2016-08-12
10:51
Lost changes Closed-Leaf check-in: 824081a391 user: mrwellan tags: lost-v1.61-changes
2016-07-23
21:57
Incremental drawing now working. check-in: efed051fe1 user: matt tags: v1.61
20:59
reorganised code layout for run times canvas view check-in: ae5d869b0c user: matt tags: v1.61
12:47
More on incremental drawing. Added use of -log in tests check-in: 398d85a266 user: matt tags: v1.61
Changes

Modified dashboard.scm from [0acea2413c] to [27c42dd921].

165
166
167
168
169
170
171


172
173
174
175
176
177
178
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180







+
+







  allruns-by-id    ;; hash of run-id -> dboard:rundat records
  done-runs        ;; list of runs already drawn
  not-done-runs    ;; list of runs not yet drawn
  header           ;; header for decoding the run records
  keys             ;; keys for this run (i.e. target components)
  numruns
  tot-runs
  last-data-update ;; last time the data in allruns was updated
  runs-mutex       ;; use to prevent parallel access to draw objects

  ;; Runs view
  buttondat 
  item-test-names
  run-keys
  runs-matrix       ;; used in newdashboard
  start-run-offset  ;; left-right slider value
252
253
254
255
256
257
258

259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275

276
277
278
279
280
281
282
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286







+

















+







	      filters-changed:      #f
	      header:               #f 
	      hide-empty-runs:      #f
	      hide-not-hide-button: #f
	      hide-not-hide:        #t
	      item-test-names:      '()
	      last-db-update:       0
	      last-data-update:     0
	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
	      numruns:              16
	      path-run-ids:         (make-hash-table)
	      run-ids:              (make-hash-table)
	      run-keys:             (make-hash-table)
	      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
	      run-start-row:        0
	      max-row:              0
	      runs-mutex:           (make-mutex)
	      )))
    (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"))
309
310
311
312
313
314
315

316
317
318
319
320
321
322
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327







+







;; used to keep the rundata from rmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  rowsused       ;; hash of lists covering what areas used - replace with quadtree
  tests          ;; hash of id => testdat
  tests-by-name  ;; hash of testfullname => testdat
  key-vals
  last-update    ;; last query to db got records from before last-update
  )

(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100))
1116
1117
1118
1119
1120
1121
1122


1123






1124
1125
1126
1127
1128
1129
1130
1121
1122
1123
1124
1125
1126
1127
1128
1129

1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142







+
+
-
+
+
+
+
+
+







(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
  (let ((drawing               (vg:drawing-new))
	(run-times-tab-updater (lambda ()	
				 (debug:catch-and-dump 
				  (lambda ()
				    (let ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num)))
				      (if tabdat
					  (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
						(now-time         (current-seconds)))
					  (dashboard:run-times-tab-updater commondat tabdat tab-num))))
					    (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
					    (if (> (- now-time last-data-update) 5)
						(begin
						  (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
						  (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
						  (dboard:tabdat-last-data-update-set! tabdat now-time)))))))
				  "dashboard:run-times-tab-updater"))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 200
     (let* ((tb      (iup:treebox
1138
1139
1140
1141
1142
1143
1144
1145

1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164

1165



1166
1167
1168
1169
1170
1171
1172
1150
1151
1152
1153
1154
1155
1156

1157

1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176

1177
1178
1179
1180
1181
1182
1183
1184
1185
1186







-
+
-


















+
-
+
+
+







			 (lambda ()
			   (let* ((run-path (tree:node->path obj id))
				  (run-id    (tree-path->run-id tabdat (cdr run-path))))
			     (print "run-path: " run-path)
			     (if (number? run-id)
				 (begin
				   (dboard:tabdat-curr-run-id-set! tabdat run-id)
				   ;; (dashboard:update-run-summary-tab)
				   (dboard:tabdat-view-changed-set! tabdat #t))
				   )
				 (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))))
			 "treebox"))
			;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		      )))
       (dboard:tabdat-runs-tree-set! tabdat tb)
       tb)
     (iup:vbox
      (let* ((cnv-obj (iup:canvas 
		       ;; #:size "500x400"
		       #:expand "YES"
		       #:scrollbar "YES"
		       #:posx "0.5"
		       #:posy "0.5"
		       #:action (make-canvas-action
				  (lambda (c xadj yadj)
				    (debug:catch-and-dump
				     (lambda ()
				       (if (not (dboard:tabdat-cnv tabdat))
					   (let ((cnv     (dboard:tabdat-cnv tabdat)))
					   (dboard:tabdat-cnv-set! tabdat c))
					     (dboard:tabdat-cnv-set! tabdat c)
					     (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)
								  (dboard:tabdat-cnv tabdat))))
				       (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)
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
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458











2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471














































2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493

2494
2495
2496
2497
2498
2499
2500
2501
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
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
2637
2638
2639
2640
2641
2642
2643
2644
2645
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
2453

2454
2455
2456
2457
2458
2459











2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470













2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
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
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
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







+
+
-
+
-
-
-
-
-
-
-
-
-
+















-
+
+

+
+
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+












-
-
-
-
-
-
-
-
-
-






-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-







	 (hash-table-keys test-ids-by-name))
	;; finally sort by the event time of the first test
	(sort (hash-table-values test-ids-by-name)
	      (lambda (a b)
		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

;; run times tab data updater
;;
(define (dashboard:run-times-tab-updater commondat tabdat tab-num)
(define (dashboard:run-times-tab-run-data-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))
  (let* ((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)))
	 (update-start-time (current-seconds))
	 (inc-mode      #f))
    ;; fill in the tree
    (if (and tb 
	     (not inc-mode))
	(for-each
    (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"))
			      (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
			      (run-path   (append key-vals (list run-name)))
			      (existing   (tree:find-node tb run-path)))
			 (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
			     (begin
			       (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
	 (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"))
		  (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
		  (run-path   (append key-vals (list run-name)))
		  (existing   (tree:find-node tb run-path)))
	     (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
		 (begin
		   (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
			       ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
			       ;;    		 (conc rownum ":" colnum) col-name)
			       ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
			       ;; Here we update the tests treebox and tree keys
			       (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
					      userdata: (conc "run-id: " run-id))
			       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
			       ;; (set! colnum (+ colnum 1))
			       ))))
		     run-ids))
    ;;
    (if (and tabdat
	     (dboard:tabdat-view-changed tabdat))
		   ;; Here we update the tests treebox and tree keys
		   (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
				  userdata: (conc "run-id: " run-id))
		   (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
		   ;; (set! colnum (+ colnum 1))
		   ))))
	 run-ids))
    (print "Updating rundat")
    (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" "%")
		   (let ((res '()))
		     (for-each (lambda (key)
				 (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))))

;; run times canvas updater
;;
(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)))
    (if (and cnv dwg)
	(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)))
	  (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat))
	  (print "Updating rundat")
	  (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" "%")
			 (let ((res '()))
			   (for-each (lambda (key)
				       (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 ((incdraw (not (null? (dboard:tabdat-not-done-runs tabdat)))) ;; if there are tests to draw from not-done-runs then this is an incremental draw
		(allruns (if incdraw
			     (dboard:tabdat-not-done-runs tabdat)
			     (dboard:tabdat-allruns tabdat)))
	  (let ((allruns (dboard:tabdat-allruns tabdat))
		(rowhash (make-hash-table)) ;; store me in tabdat
		(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))


		       (not-drawn (dboard:rundat-tests-notdrawn-tests rundat))



		       (hierdat   (or not-drawn (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"))
		       (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)
		       (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))
		       (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))
		       (run-full-name (string-intersperse key-vals "/")))
		  (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))
			     (new-run-start-row (+ (dboard:tabdat-max-row tabdat) 2)))
			;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
			(mutex-lock! mtx)
			(vg:add-comp-to-lib runslib run-full-name runcomp)
			(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))
			  (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)
				(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 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))
				(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   (- 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))
			;; 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)))))
			       (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))
			(mutex-unlock! mtx)
			(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 #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)))))))
	      (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"))))

(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 [99d7742afe] to [e3c87e0aa9].

326
327
328
329
330
331
332



333
334
335
336
337
338
339
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342







+
+
+







	 (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))))
     xtnt-lst)
    (list llx lly ulx uly)))

(define (vg:lib-get-component lib instname)
  (hash-table-ref/default  (vg:lib-comps lib) instname #f))

;;======================================================================
;; color
;;======================================================================

(define (vg:rgb->number r g b #!key (a 0))
  (bitwise-ior
    (arithmetic-shift a 24)
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596














597
598
599
600
581
582
583
584
585
586
587












588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605







-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+




	(append pts pts))))

(define (vg:draw drawing draw-mode . instnames)
  (let ((insts (vg:drawing-insts drawing))
	(res   '()))
    (for-each 
     (lambda (instname)
       (let* ((inst     (hash-table-ref insts instname))
	      (libname  (vg:inst-libname inst))
	      (compname (vg:inst-compname inst))
	      (comp     (vg:get-component drawing libname compname)))
	 ;; (print "comp: " comp)
	 (for-each
	  (lambda (obj)
	    ;; (print "obj: " (vg:obj-pts obj))
	    (let ((obj-xfrmd (vg:map-obj drawing inst obj)))
	      ;; (print "obj-xfrmd: " (vg:obj-pts obj-xfrmd))
	      (set! res (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))) ;;
	  (vg:comp-objs comp))))
       (let* ((inst     (hash-table-ref/default insts instname #f)))
	 (if inst
	     (let* ((libname  (vg:inst-libname inst))
		    (compname (vg:inst-compname inst))
		    (comp     (vg:get-component drawing libname compname)))
	       ;; (print "comp: " comp)
	       (for-each
		(lambda (obj)
		  ;; (print "obj: " (vg:obj-pts obj))
		  (let ((obj-xfrmd (vg:map-obj drawing inst obj)))
		    ;; (print "obj-xfrmd: " (vg:obj-pts obj-xfrmd))
		    (set! res (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))) ;;
		(vg:comp-objs comp)))
	     (print "no such instance " instname))))
     (if (null? instnames)
	 (hash-table-keys insts)
	 instnames))
    res)) ;;  (hash-table-values insts))))