Megatest

Diff
Login

Differences From Artifact [2db07e95fc]:

To Artifact [80f5579f81]:


186
187
188
189
190
191
192


193
194
195
196
197
198
199
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201







+
+







  cnv-obj
  drawing
  draw-cache     ;; 
  start-row
  run-start-row
  max-row
  running-layout
  originx
  originy

  ;; 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 ...
261
262
263
264
265
266
267


268
269
270
271
272
273
274
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278







+
+







	      item-test-names:      '()
	      last-db-update:       0
	      last-data-update:     0
	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
	      numruns:              16
	      originx:              #f
	      originy:              #f
	      path-run-ids:         (make-hash-table)
	      run-ids:              (make-hash-table)
	      run-keys:             (make-hash-table)
	      running-layout:       #f
	      searchpatts:          (make-hash-table)
	      start-run-offset:     0
	      start-test-offset:    0
1190
1191
1192
1193
1194
1195
1196
1197
1198


1199
1200
1201
1202
1203
1204
1205
1194
1195
1196
1197
1198
1199
1200


1201
1202
1203
1204
1205
1206
1207
1208
1209







-
-
+
+







				       (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 (* -1000 (- xadj 0.5)))
					       (dboard:tabdat-yadj-set! tabdat (*  1000 (- yadj 0.5)))
					       (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5)))
					       (dboard:tabdat-yadj-set! tabdat (*  2000 (- yadj 0.5)))
					       ))))
				     "iup:canvas action")))
		       #:wheel-cb  (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
				     (debug:catch-and-dump
				      (lambda ()
					(let* ((drawing (dboard:tabdat-drawing tabdat))
					       (scalex  (vg:drawing-scalex drawing)))
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
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







-
+
-


-
-
+
+
+






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




-
+
-







(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))
	 (mtx           (dboard:tabdat-runs-mutex tabdat)))
	 (compute-start (current-seconds)))
    (if tabdat
	(let* ((drawing    (dboard:tabdat-drawing tabdat))
	       (runslib    (vg:get/create-lib drawing "runslib"))) ;; creates and adds lib
	  (print "layout start: " compute-start)
	       (runslib    (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	       (layout-start (current-milliseconds)))
	  (print "layout start: " (current-milliseconds) " layout-start: " layout-start)
	  (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 2)
						     (* rownum row-height)))))
			  ((calc-y)                      (lambda (rownum)
							   (- (/ sizey 2)
							      (* rownum row-height))))
			  ((fixed-originx)               (if (dboard:tabdat-originx tabdat)
							     (dboard:tabdat-originx tabdat)
							     (begin
							       (dboard:tabdat-originx-set! tabdat originx)
							       originx)))
			  ((fixed-originy)               (if (dboard:tabdat-originy tabdat)
							     (dboard:tabdat-originy tabdat)
							     (begin
							       (dboard:tabdat-originy-set! tabdat originy)
							       originy))))
	      ;; (print "allruns: " allruns)
	      (let runloop ((rundat   (car allruns))
			    (runtal   (cdr allruns))
			    (run-num   1)
			    (doneruns '())
			    (doneruns '()))
			    (run-draw-start-time (current-seconds)))
		(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 "")))))
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
2675
2676
2677



2678
2679
2680
2681
2682
2683








2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699



2700
2701
2702
2703
2704
2705
2706
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
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684

2685
2686
2687
2688
2689
2690
2691
2692
2693






2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714



2715
2716
2717
2718
2719
2720
2721
2722
2723
2724







-
+









+












-
-
+




-
+
+


-
-
+
+





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


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









-






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













-
-
-
+
+
+







			     (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))
			     (timeoffset (- (+ fixed-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 "Testing. (maptime run-start=" run-start "): " (maptime run-start) " (maptime run-end=" run-end "): " (maptime run-end) " run-duration: " run-duration)
			;; (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 curr-run-start-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))
			  (let ((test-objs   '())
				(iterated     (> (length test-ids) 1))
			  (let ((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))
					       (item-num 1)
					       (test-objs '()))
			      (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-duration (* timescale (db:test-get-run_duration testdat)))
				     (end-time     (+ event-time test-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)))
				     (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)
				     (new-test-objs 
				    (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)))
				  (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)))
					(dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum)
										(dboard:tabdat-max-row tabdat))) ;; track the max row used
					(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)))))
				      (let loop ((rownum 0)) ;;  new-run-start-row)) ;; (+ start-row 1)))
					(if (dashboard:row-collision rowhash rownum event-time end-time)
					    (loop (+ rownum 1))
					    (let* ((title   (if iterated item-path test-name))
						   (lly     (calc-y rownum)) ;; (- sizey (* rownum row-height)))
						   (uly     (+ lly row-height))
						   (use-end (if (< (- end-time event-time) 3)(+ event-time 3) end-time)) ;; if short grow it a little to give the user something to click on
						   (obj     (vg:make-rect-obj event-time lly use-end uly
									      fill-color: (vg:iup-color->number (car name-color))
									      text: title
									      font: "Helvetica -10")) 
						   (bar-end (+ 5 (max use-end (+ 3 event-time (* (string-length title) 10)))))) ;; 8 pixels per letter
					      ;; (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)))
					      (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum)
										      (dboard:tabdat-max-row tabdat))) ;; track the max row used
					      ;; bar-end has some margin for text - accounting for text in extents not yet working.
					      (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5))
					      (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)
					      (cons obj test-objs))))))
				;; (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")))
				;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				(let ((newdoneruns (cons rundat doneruns)))
				  (if (not (null? tidstal))
				  (if (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 iterated
					  (let* ((xtents (vg:get-extents-for-objs drawing new-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)
					    ;; This is the box around the tests of an iterated test
					    (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)))
											  line-color:  (vg:rgb->number  0 0 255 a: 128)
											  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
				  ))
				      (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)))))
			    ;; If it is an iterated test put box around it now.
			    (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))
			       (outln     (vg:make-rect-obj llx lly ulx uly 
							    text: run-full-name
							    line-color:  (vg:rgb->number  255 0 255 a: 128))))
			       ) ;;  (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))
			)
					;  (vg:components-get-extents d1 c1)))
			  ;; this is the box around the run
			  (mutex-lock! mtx)
			  (vg:add-obj-to-comp runcomp outln)
			  (mutex-unlock! mtx)
			  (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 2))
			  ;; (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))
				(begin
				  (print "Layout end: " (current-seconds))
				  (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns (current-seconds))))))))) ;;  new-run-start-row
	      )))
				  (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)))))))) ;;  new-run-start-row
	      )
	    (print "Layout end: " (current-milliseconds) " delta: " (- (current-milliseconds) layout-start))))
	(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)))
       (update-rundat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat)