Megatest

Check-in [bbfb2fb767]
Login
Overview
Comment:Cleaned up display of itemized tests in temporal view
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: bbfb2fb7679b57bfc1d5cf827e787153474208a5
User & Date: matt on 2016-07-19 23:34:59
Other Links: branch diff | manifest | tags
Context
2016-07-20
00:01
Try to calc text size for extents. Not getting the data in time to be able to use it check-in: a6fb3c351e user: matt tags: v1.61
2016-07-19
23:34
Cleaned up display of itemized tests in temporal view check-in: bbfb2fb767 user: matt tags: v1.61
18:33
Process tests in bundles check-in: 3340b7c0bd user: mrwellan tags: v1.61
Changes

Modified dashboard.scm from [123feb2512] to [359372d57b].

2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213



2214
2215
2216
2217
2218
2219
2220
2221
2222
2223



2224
2225
2226

2227


2228


2229
2230
2231
2232
2233
2234
2235

;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
  (and (< lx1 px)(> lx2 px)))

;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing 
;; bars?
;;
(define (dashboard:row-collision rowhash rownum x1 x2)
  (let ((rowdat    (hash-table-ref/default rowhash rownum '()))
	(collision #f))



    (for-each
     (lambda (bar)
       (let ((bx1 (car bar))
	     (bx2 (cdr bar)))
	 (cond
	  ;; newbar x1 inside bar
	  ((dashboard:px-between x1 bx1 bx2)(set! collision #t))
	  ((dashboard:px-between x2 bx1 bx2)(set! collision #t))
	  ((and (<= x1 bx1)(>= x2 bx2))(set! collision #t)))))
     rowdat)



    collision))

(define-inline (dashboard:add-bar rowhash rownum x1 x2)

  (hash-table-set! rowhash rownum (cons (cons x1 x2) 


					(hash-table-ref/default rowhash rownum '()))))



;; get min or max, use > for max and < for min, this works around the limits on apply
;;
(define (dboard:min-max comp lst)
  (if (null? lst)
      #f ;; better than an exception for my needs
      (fold (lambda (a b)







|

|
<
|
>
>
>
|
|
|
|
|
|
|
|
|
|
>
>
>


|
>
|
>
>
|
>
>







2202
2203
2204
2205
2206
2207
2208
2209
2210
2211

2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245

;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
  (and (< lx1 px)(> lx2 px)))

;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing 
;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
;;
(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))

  (let ((collision #f)
	(lastrow   (if num-rows (+ rownum num-rows) rownum)))
    (let loop ((i      0)
	       (rowdat (hash-table-ref/default rowhash rownum '())))
      (for-each
       (lambda (bar)
	 (let ((bx1 (car bar))
	       (bx2 (cdr bar)))
	   (cond
	    ;; newbar x1 inside bar
	    ((dashboard:px-between x1 bx1 bx2)(set! collision #t))
	    ((dashboard:px-between x2 bx1 bx2)(set! collision #t))
	    ((and (<= x1 bx1)(>= x2 bx2))(set! collision #t)))))
       rowdat)
      (if (< i lastrow)
	  (loop (+ i 1)
		(hash-table-ref/default rowhash (+ rownum i) '()))))
    collision))

(define (dashboard:add-bar rowhash rownum x1 x2 #!key (num-rows 0))
  (let loop ((i 0))
    (hash-table-set! rowhash 
		     (+ i rownum)
		     (cons (cons x1 x2) 
			   (hash-table-ref/default rowhash (+ i rownum) '())))
    (if (< i num-rows)
	(loop (+ i 1)))))

;; get min or max, use > for max and < for min, this works around the limits on apply
;;
(define (dboard:min-max comp lst)
  (if (null? lst)
      #f ;; better than an exception for my needs
      (fold (lambda (a b)
2243
2244
2245
2246
2247
2248
2249


2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264




2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
	  (< (db:test-get-event_time a)
	     (db:test-get-event_time b)))))

;; first group items into lists, then sort by time
;; finally sort by first item time
;;
(define (dboard:tests-sort-by-time-group-by-item testsdat)


  (let* ((tests (let ((ht (make-hash-table)))
		  (for-each
		   (lambda (tdat)
		     (let ((testname (db:test-get-testname tdat)))
		       (hash-table-set! 
			ht 
			testname
			(cons tdat (hash-table-ref/default ht testname '())))))
		   testsdat)
		   ht)))
    ;; remove toplevel tests from iterated tests, sort tests in the list by event time
    (for-each 
     (lambda (testname)
       (let ((testslst (hash-table-ref tests testname)))
	 (if (> (length testslst) 1) ;; must be iterated




	     (hash-table-set! tests 
			      testname 
			      (dboard:sort-testsdat-by-event-time 
			       (filter (lambda (tdat)
					 (equal? (db:test-get-item-path tdat) ""))
				       testslst)))
	     )))
     (hash-table-keys tests))
    (sort (hash-table-values tests)
	  (lambda (a b)
	    (< (db:test-get-event_time (car a))
	       (db:test-get-event_time (car b)))))))

(define (dashboard:run-times-tab-updater commondat tab-num)
  ;; each test is an object in the run component
  ;; each run is a component
  ;; all runs stored in runslib library
  (let* ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num))
	 (canvas-margin 10)







>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
|
|
<
<
<
<
|
|
|
|
|







2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283




2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
	  (< (db:test-get-event_time a)
	     (db:test-get-event_time b)))))

;; first group items into lists, then sort by time
;; finally sort by first item time
;;
(define (dboard:tests-sort-by-time-group-by-item testsdat)
  (if (null? testsdat)
      testsdat
      (let* ((tests (let ((ht (make-hash-table)))
		      (for-each
		       (lambda (tdat)
			 (let ((testname (db:test-get-testname tdat)))
			   (hash-table-set! 
			    ht 
			    testname
			    (cons tdat (hash-table-ref/default ht testname '())))))
		       testsdat)
		      ht)))
	;; remove toplevel tests from iterated tests, sort tests in the list by event time
	(for-each 
	 (lambda (testname)
	   (let ((testslst (hash-table-ref tests testname)))
	     (if (> (length testslst) 1) ;; must be iterated
		 (let ((item-tests (filter (lambda (tdat) ;; filter out toplevel tests
					     (not (equal? (db:test-get-item-path tdat) "")))
					   testslst)))
		   (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition
		       (hash-table-set! tests 
					testname 
					(dboard:sort-testsdat-by-event-time item-tests)))))))




	 (hash-table-keys tests))
	(sort (hash-table-values tests)
	      (lambda (a b)
		(< (db:test-get-event_time (car a))
		   (db:test-get-event_time (car b))))))))

(define (dashboard:run-times-tab-updater commondat tab-num)
  ;; each test is an object in the run component
  ;; each run is a component
  ;; all runs stored in runslib library
  (let* ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num))
	 (canvas-margin 10)
2380
2381
2382
2383
2384
2385
2386




2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413


2414
2415


2416
2417
2418
2419











2420
2421
2422
2423
2424
2425
2426
		;; 	     (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 (testdats)




			  (for-each 
			   (lambda (testdat)
			     (let* ((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)
			       (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)))
				       (dashboard:add-bar rowhash rownum event-time end-time)
				       (vg:add-objs-to-comp runcomp
							    (vg:make-rect event-time lly end-time uly
									  fill-color: (vg:iup-color->number (car name-color))
									  text: (conc test-name "/" item-path)
									  font: "Helvetica -10")
							    ;; (vg:make-text (+ event-time 2)
							    ;;               (+ lly 2)


							    ;;               (conc test-name "/" item-path)
							    ;;               font: "Helvetica -10")


							    ))))
			       ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
			       ))
			   testdats))











			hierdat)
		       ;; placeholder box
		       (set! max-row (+ max-row 1))
		       (let ((y   (- sizey (* max-row row-height))))
			 (vg:add-objs-to-comp runcomp (vg:make-rect 0 y 0 y)))
		       ;; instantiate the component 
		       (let* ((extents   (vg:components-get-extents drawing runcomp))







>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
>
>
|
|
>
>
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>







2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
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
		;; 	     (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 (testdats)
			  (let ((test-objs   '())
				(iterated     (> (length testdats) 1))
				(first-rownum #f)
				(num-items    (length testdats)))
			    (for-each 
			     (lambda (testdat)
			       (let* ((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)
				 (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 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-objs-to-comp runcomp obj)
					 (set! test-objs (cons obj test-objs)))))
				 ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				 ))
			   testdats)
			    ;; 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-objs-to-comp runcomp (vg:make-rect llx lly ulx uly
									     text:  (db:test-get-testname (car testdats))
									     font: "Helvetica -10"))))))
			hierdat)
		       ;; placeholder box
		       (set! max-row (+ max-row 1))
		       (let ((y   (- sizey (* max-row row-height))))
			 (vg:add-objs-to-comp runcomp (vg:make-rect 0 y 0 y)))
		       ;; instantiate the component 
		       (let* ((extents   (vg:components-get-extents drawing runcomp))

Modified vg-test.scm from [f9d534031a] to [3919a2488e].

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 vg:grow-rect
 vg:components-get-extents)

(define d1 (vg:drawing-new))
(define l1 (vg:lib-new))
(define c1 (vg:comp-new))
(define c2 (vg:comp-new))
(let ((r1 (vg:make-rect 20 20 40 40 text: "r1" font: "Helvetica, -20"))
      (r2 (vg:make-rect 40 40 80 80 text: "r2" font: "Helvetica, -10"))
      (t1 (vg:make-text 40 40 "The middle" font: "Helvetica, -10")))
  (vg:add-objs-to-comp c1 r1 r2 t1))

;; add the c1 component to lib l1 with name firstcomp
(vg:add-comp-to-lib l1 "firstcomp" c1)
(vg:add-comp-to-lib l1 "secondcomp" c2)

;; add the l1 lib to drawing with name firstlib







|
|
|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 vg:grow-rect
 vg:components-get-extents)

(define d1 (vg:drawing-new))
(define l1 (vg:lib-new))
(define c1 (vg:comp-new))
(define c2 (vg:comp-new))
(let ((r1 (vg:make-rect 20 20 30 30 text: "r1" font: "Helvetica, -20"))
      (r2 (vg:make-rect 30 30 60 60 text: "r2" font: "Helvetica, -10"))
      (t1 (vg:make-text 60 60 "The middle" font: "Helvetica, -10")))
  (vg:add-objs-to-comp c1 r1 r2 t1))

;; add the c1 component to lib l1 with name firstcomp
(vg:add-comp-to-lib l1 "firstcomp" c1)
(vg:add-comp-to-lib l1 "secondcomp" c2)

;; add the l1 lib to drawing with name firstlib

Modified vg.scm from [a343609fb9] to [350c9e115f].

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






181














182
183
184
185
186
187
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202
    (hash-table-set! (vg:drawing-insts drawing) instname inst)))

;; get component from drawing (look in apropriate lib) given libname and compname
(define (vg:get-component drawing libname compname)
  (let* ((lib  (hash-table-ref (vg:drawing-libs drawing) libname))
	 (inst (hash-table-ref (vg:lib-comps lib) compname)))
    inst))

(define (vg:components-get-extents drawing . comps)
  (let ((llx #f)
	(lly #f)
	(ulx #f)
	(uly #f))
    (for-each
     (lambda (comp)






       (let ((objs (vg:comp-objs comp)))














	 (for-each
	  (lambda (obj)
	    (let* ((extents (vg:obj-get-extents drawing obj))
		   (ollx    (list-ref extents 0))
		   (olly    (list-ref extents 1))
		   (oulx    (list-ref extents 2))
		   (ouly    (list-ref extents 3)))
	      (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))))
	  objs)))
     comps)
    (list llx lly ulx uly)))


;;======================================================================
;; libraries
;;======================================================================

;; register lib with drawing









|
|
<
<
<

|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
<
<
<
<
<
|

<
>







166
167
168
169
170
171
172
173
174
175



176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204





205
206

207
208
209
210
211
212
213
214
    (hash-table-set! (vg:drawing-insts drawing) instname inst)))

;; get component from drawing (look in apropriate lib) given libname and compname
(define (vg:get-component drawing libname compname)
  (let* ((lib  (hash-table-ref (vg:drawing-libs drawing) libname))
	 (inst (hash-table-ref (vg:lib-comps lib) compname)))
    inst))

(define (vg:get-extents-for-objs drawing objs)
  (let ((extents #f))



    (for-each
     (lambda (obj)
       (set! extents
	 (vg:get-extents-for-two-rects
	  extents
	  (vg:obj-get-extents drawing obj))))
     objs)
    extents))

;; given rectangles r1 and r2, return the box that bounds both
;;
(define (vg:get-extents-for-two-rects r1 r2)
  (if (not r1)
      r2
      (if (not r2)
	  #f ;; no extents from #f #f
	  (list (min (car r1)(car r2))           ;; llx
		(min (cadr r1)(cadr r2))         ;; lly
		(max (caddr r1)(caddr r2))       ;; ulx
		(max (cadddr r1)(cadddr r2)))))) ;; uly

(define (vg:components-get-extents drawing . comps)
  (let ((extents #f))
    (for-each
     (lambda (comp)
       (let* ((objs  (vg:comp-objs comp)))
	 (set! extents 
	   (vg:get-extents-for-two-rects
	    extents





	    (vg:get-extents-for-objs drawing objs)))))
     comps)

    extents))

;;======================================================================
;; libraries
;;======================================================================

;; register lib with drawing

336
337
338
339
340
341
342







343
344
345
346
347
348
349
350
	  (canvas-foreground-set! cnv prev-foreground-color)
	  (if text 
	      (let* ((prev-font    (canvas-font cnv))
		     (font-changed (and font (not (equal? font prev-font)))))
		(if font-changed (canvas-font-set! cnv font))
		(canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
		(if font-changed (canvas-font-set! cnv prev-font))))))







    pts)) ;; return extents 

;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-text drawing obj #!key (draw #t))
  (let* ((cnv        (vg:drawing-cnv drawing))
	 (pts        (vg:drawing-apply-scale drawing (vg:obj-pts obj)))







>
>
>
>
>
>
>
|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
	  (canvas-foreground-set! cnv prev-foreground-color)
	  (if text 
	      (let* ((prev-font    (canvas-font cnv))
		     (font-changed (and font (not (equal? font prev-font)))))
		(if font-changed (canvas-font-set! cnv font))
		(canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
		(if font-changed (canvas-font-set! cnv prev-font))))))
    (if (not text)
	pts
	(if cnv
	    (let-values (((xmax ymax)(canvas-text-size cnv text)))
	      (list llx lly
		    (max ulx (+ llx xmax))
		    (max uly (+ lly ymax))))
	    pts)))) ;; return extents 

;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-text drawing obj #!key (draw #t))
  (let* ((cnv        (vg:drawing-cnv drawing))
	 (pts        (vg:drawing-apply-scale drawing (vg:obj-pts obj)))