Megatest

Check-in [e26711edf5]
Login
Overview
Comment:Improved scaling and mapping for displaying tests on canvas
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | runcontrol
Files: files | file ages | folders
SHA1: e26711edf536b1e5e0580f51e648067097a2413f
User & Date: mrwellan on 2013-04-22 11:10:01
Other Links: branch diff | manifest | tags
Context
2013-04-22
19:47
Merged dev into runcontrol check-in: df98c96bb1 user: matt tags: runcontrol
11:10
Improved scaling and mapping for displaying tests on canvas check-in: e26711edf5 user: mrwellan tags: runcontrol
01:25
Draw test/task boxes in rows to keep compact interface check-in: df77e9f1bd user: matt tags: runcontrol
Changes

Modified dashboard.scm from [0c39bd9508] to [f334b951f8].

508
509
510
511
512
513
514
515







































516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532

533
534
535
536
537
538
539
			 listboxes)))
	    (loop (car remkeys)
		  (cdr remkeys)
		  (append refvals (list selected-value))
		  (+ indx 1)
		  (append lbs (list lb))))))))

;(define (dashboard:display-tests cnv x y)








































(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (runconf-targs (common:get-runconfig-targets))
	 (test-records  (make-hash-table))
	 (test-names    (tests:get-valid-tests *toppath* '()))
	 (sorted-testnames #f)
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (update-keyvals (lambda (obj b c d)
			   ;; (print "obj: " obj ", b " b ", c " c ", d " d)
			   (dashboard:update-target-selector key-listboxes)))
	 (test-browse-xoffset 0)
	 (test-browse-yoffset 0)
	 (first-time    #t))

    (tests:get-full-data test-names test-records '())
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     (iup:hbox
       ;; Target and action







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













|
|
|
|
>







508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
			 listboxes)))
	    (loop (car remkeys)
		  (cdr remkeys)
		  (append refvals (list selected-value))
		  (+ indx 1)
		  (append lbs (list lb))))))))

(define (dashboard:draw-tests cnv xadj yadj test-draw-state sorted-testnames)
  (canvas-clear! cnv)
  (canvas-font-set! cnv "Courier New, -8")
  (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
	       ((originx originy)             (canvas-origin cnv)))
      (if (hash-table-ref/default test-draw-state 'first-time #t)
	  (begin
	    (hash-table-set! test-draw-state 'first-time #f)
	    (hash-table-set! test-draw-state 'scalef 8)
	    ;; set these 
	    (hash-table-set! test-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
	    (hash-table-set! test-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
      (let* ((scalef (hash-table-ref/default test-draw-state 'scalef 8))
	     (test-browse-xoffset (hash-table-ref test-draw-state 'test-browse-xoffset))
	     (test-browse-yoffset (hash-table-ref test-draw-state 'test-browse-yoffset))
	     (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	     (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	     (boxw   80)
	     (boxh   30)
	     (gapx   20)
	     (gapy   30))
	(print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames)))
		   (llx xtorig)
		   (lly ytorig)
		   (urx (+ xtorig boxw))
		   (ury (+ ytorig boxh)))
	  ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	  (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")"))
	  (canvas-rectangle! cnv llx urx lly ury)
	  (if (not (null? tal))
	      ;; leave a column of space to the right to list items
	      (let ((have-room (< urx (- sizex boxw gapx boxw))))  ;; is there room for another column?
		(loop (car tal)
		      (cdr tal)
		      (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
		      (if have-room lly (+ lly boxh gapy))
		      (if have-room (+ urx boxw gapx) (+ xtorig boxw))
		      (if have-room ury (+ ury boxh gapy)))))))))

(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (runconf-targs (common:get-runconfig-targets))
	 (test-records  (make-hash-table))
	 (test-names    (tests:get-valid-tests *toppath* '()))
	 (sorted-testnames #f)
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (update-keyvals (lambda (obj b c d)
			   ;; (print "obj: " obj ", b " b ", c " c ", d " d)
			   (dashboard:update-target-selector key-listboxes)
			   ))
	 (tests-draw-state (make-hash-table))) ;; use for keeping state of the test canvas
    (hash-table-set! tests-draw-state 'first-time #t)
    (hash-table-set! tests-draw-state 'scalef 8)
    (tests:get-full-data test-names test-records '())
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     (iup:hbox
       ;; Target and action
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
		 combos))))
      (iup:frame
       #:title "Tests and Tasks"
       (iup:vbox
	(iup:canvas #:action (make-canvas-action
			      (lambda (cnv xadj yadj)
				;; (print "cnv: " cnv " x: " x " y: " y)
				(canvas-clear! cnv)
				(canvas-font-set! cnv "Courier New, -8")
				(let-values (((sizex   sizey sizexmm sizeymm) (canvas-size cnv)))
	                           (if first-time
				       (begin
					 (set! first-time #f)
					 (set! test-browse-xoffset (- 20 (* (/ sizex 2) (* 8 xadj))))
					 (set! test-browse-yoffset (- 20 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
			           (let* ((xtorig (+ test-browse-xoffset (* (/ sizex 2) (* 8 xadj)))) ;;  (- xadj 1))))
					  (ytorig (+ test-browse-yoffset (* (/ sizey 2) (* 8 (- 1 yadj)))))
					  (boxw   80)
					  (boxh   30)
					  (gapx   20)
					  (gapy   30))
				     (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv))
				     (let loop ((hed (car (reverse sorted-testnames)))
						(tal (cdr (reverse sorted-testnames)))
						(llx xtorig)
						(lly ytorig)
						(urx (+ xtorig boxw))
						(ury (+ ytorig boxh)))
				       (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")"))
				       (canvas-rectangle! cnv llx urx lly ury)
				       (if (not (null? tal))
					   ;; leave a column of space to the right to list items
					   (let ((have-room (< urx (- sizex boxw gapx boxw))))  ;; is there room for another column?
					     (loop (car tal)
						   (cdr tal)
						   (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
						   (if have-room lly (+ lly boxh gapy))
						   (if have-room (+ urx boxw gapx) (+ xtorig boxw))
						   (if have-room ury (+ ury boxh gapy))))))))))
		    #:size "150x200"
		    #:scrollbar "YES"
		    #:posx "0.5"
		    #:posy "0.5")))))))


(trace dashboard:populate-target-dropdown







|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







589
590
591
592
593
594
595
596































597
598
599
600
601
602
603
		 combos))))
      (iup:frame
       #:title "Tests and Tasks"
       (iup:vbox
	(iup:canvas #:action (make-canvas-action
			      (lambda (cnv xadj yadj)
				;; (print "cnv: " cnv " x: " x " y: " y)
				(dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)))































		    #:size "150x200"
		    #:scrollbar "YES"
		    #:posx "0.5"
		    #:posy "0.5")))))))


(trace dashboard:populate-target-dropdown