Megatest

Check-in [4d158f878f]
Login
Overview
Comment:more incremental draw
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 4d158f878fc0131cd44a0122fcf883e300cf66b1
User & Date: mrwellan on 2016-07-22 17:57:21
Other Links: branch diff | manifest | tags
Context
2016-07-23
00:46
Converted to named loops so can exit before all tests drawn check-in: dde8e637fa user: matt tags: v1.61
2016-07-22
17:57
more incremental draw check-in: 4d158f878f user: mrwellan tags: v1.61
16:34
Fixed fallout from refactoring check-in: 66a0b5821b user: mrwellan tags: v1.61
Changes

Modified dashboard.scm from [1d8470c8da] to [25798d6cb1].

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  allruns          ;; list of dboard:rundat records
  allruns-by-id    ;; hash of run-id -> dboard:rundat records
  done-run-ids     ;; list of run-ids already drawn
  not-done-run-ids ;; list of run-ids not yet drawn
  header           ;; header for decoding the run records
  keys             ;; keys for this run (i.e. target components)
  numruns
  tot-runs

  ;; Runs view
  buttondat 







|
|







159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  allruns          ;; list of dboard:rundat records
  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

  ;; Runs view
  buttondat 
249
250
251
252
253
254
255


256
257
258
259
260
261
262
	      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


	      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







>
>







249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
	      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
	      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
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
			 (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 ((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)
	      (for-each
	       (lambda (rundat)
		 (if rundat
		     (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"))
			    (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))
			    (test-num   0)
			    (tot-tests  (length testsdat)))
		       (set! run-num (+ run-num 1))
		       ;; (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))
		       (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)))))












	       allruns)
	      (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"))))








>
|
>






|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
|







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
			 (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 ((allruns (if (null? (dboard:tabdat-not-done-runs tabdat))
			     (dboard:tabdat-allruns tabdat)
			     (dboard:tabdat-not-done-runs 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))
			    (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"))
		       (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))
		       (test-num   0)
		       (tot-tests  (length testsdat)))
		  (set! run-num (+ run-num 1))
		  ;; (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))
		  (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"))))