Megatest

Check-in [02608b0f9d]
Login
Overview
Comment:using dot mostly workign
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | use-dot
Files: files | file ages | folders
SHA1: 02608b0f9dc0a728b243f06f427f95127837bd1c
User & Date: mrwellan on 2015-10-09 15:23:36
Other Links: branch diff | manifest | tags
Context
2015-10-09
15:25
using dot mostly workign check-in: 719147565e user: mrwellan tags: use-dot
15:23
using dot mostly workign check-in: 02608b0f9d user: mrwellan tags: use-dot
08:38
use dot for layout of tests check-in: f76c9546af user: matt tags: use-dot
Changes

Modified dashboard.scm from [ac75ce00c0] to [eaa2d9a7a5].

736
737
738
739
740
741
742
743

744
745
746
747
748
749
750
  (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
	       ((originx originy)             (canvas-origin cnv)))
      ;; (print "originx: " originx " originy: " originy)
      ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
      (if (hash-table-ref/default tests-draw-state 'first-time #t)
	  (begin
	    (hash-table-set! tests-draw-state 'first-time #f)
	    (hash-table-set! tests-draw-state 'scalef 8)

	    (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
	    (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
	    ;; set these 
	    (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
	    (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
	    (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
	  (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))







|
>







736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
  (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
	       ((originx originy)             (canvas-origin cnv)))
      ;; (print "originx: " originx " originy: " originy)
      ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
      (if (hash-table-ref/default tests-draw-state 'first-time #t)
	  (begin
	    (hash-table-set! tests-draw-state 'first-time #f)
	    (hash-table-set! tests-draw-state 'scalef 1)
	    (hash-table-set! tests-draw-state 'dotscale 60)
	    (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
	    (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
	    ;; set these 
	    (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
	    (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
	    (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
	  (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
773
774
775
776
777
778
779
780

781
782
783
784
785
786
787
					    (car (dashboard:update-target-selector key-listboxes)))))
			     (dboard:data-set-target! *data* targ)
			     (if updater-for-runs (updater-for-runs))
			     (dashboard:update-run-command))))
	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (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 '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     ;; The command line display/exectution control
     (iup:frame







|
>







774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
					    (car (dashboard:update-target-selector key-listboxes)))))
			     (dboard:data-set-target! *data* targ)
			     (if updater-for-runs (updater-for-runs))
			     (dashboard:update-run-command))))
	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    ;; (hash-table-set! tests-draw-state 'dotscale 60)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     ;; The command line display/exectution control
     (iup:frame
930
931
932
933
934
935
936


937
938




939
940

941
942
943
944
945
946
947
948
949
950
951
952
953
							    (set! last-xadj xadj)
							    (set! last-yadj yadj))))
					(updater xadj yadj)
					(set! the-cnv cnv)
					))
			    ;; Following doesn't work 
			    #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.


					 (let ((xadj last-xadj)
					       (yadj (+ last-yadj (if (> step 0)




								      -0.01
								      0.01))))

					   ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"")
					   ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir)
					   (if the-cnv
					       (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames test-records))
					   (set! last-xadj xadj)
					   (set! last-yadj yadj)
					   ))
			    ;; #:size "50x50"
			    #:expand "YES"
			    #:scrollbar "YES"
			    #:posx "0.5"
			    #:posy "0.5"
			    #:button-cb (lambda (obj btn pressed x y status)







>
>
|
|
>
>
>
>
|
|
>



|
|
|







932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
							    (set! last-xadj xadj)
							    (set! last-yadj yadj))))
					(updater xadj yadj)
					(set! the-cnv cnv)
					))
			    ;; Following doesn't work 
			    #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
					 (let ((scalef (hash-table-ref tests-draw-state 'scalef)))
					   ;; (debug:print 0 "step=" step ", dir=" dir ", scalef=" scalef ", x=" x ", y=" y)
					   ;; (let (;; (xadj last-xadj)
					   ;; (yadj (+ last-yadj (if (> step 0)
					   ;;		      -0.01
					   ;;			      0.01))))
					   (hash-table-set! tests-draw-state 'scalef (+ scalef
											(if (> step 0)
											    0.01
											    -0.01)))

					   ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"")
					   ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir)
					   (if the-cnv
					       (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
					   ;; (set! last-xadj xadj)
					   ;; (set! last-yadj yadj)
					   ))
			    ;; #:size "50x50"
			    #:expand "YES"
			    #:scrollbar "YES"
			    #:posx "0.5"
			    #:posy "0.5"
			    #:button-cb (lambda (obj btn pressed x y status)

Modified dcommon.scm from [d6f34ee6f6] to [085773683d].

577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
			   ;;  )					     
			   ))))

;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================

(define (dcommon:draw-test cnv x y w h name selected)
  (let* ((llx x)
	 (lly y)
	 (urx (+ x w))
	 (ury (+ y h)))
    (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")"))
    (canvas-rectangle! cnv llx urx lly ury)
    (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))))

(define (dcommon:draw-arrow cnv test-box-center waiton-center)
  (let* ((test-box-center-x (vector-ref test-box-center 0))
	 (test-box-center-y (vector-ref test-box-center 1))







|
|
|
|
|







577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
			   ;;  )					     
			   ))))

;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================

(define (dcommon:draw-test cnv scalef x y w h name selected)
  (let* ((llx (* scalef x))
	 (lly (* scalef y))
	 (urx (* scalef (+ x w)))
	 (ury (* scalef (+ y h))))
    (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")"))
    (canvas-rectangle! cnv llx urx lly ury)
    (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))))

(define (dcommon:draw-arrow cnv test-box-center waiton-center)
  (let* ((test-box-center-x (vector-ref test-box-center 0))
	 (test-box-center-y (vector-ref test-box-center 1))
633
634
635
636
637
638
639



















640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660

661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682











683
684
685
686


687
688



689
690
691
692
693
694
695
696
697
698




















699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719







720
721
722

723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
(define (dcommon:get-box-center box)
  (let* ((llx  (list-ref box 0))
	 (lly  (list-ref box 4))
	 (boxw (list-ref box 5))
	 (boxh (list-ref box 6)))
    (vector (+ llx (/ boxw 2))
	    (+ lly (/ boxh 2)))))




















(define (dcommon:draw-arrows cnv testname tests-hash test-records)
  (let* ((test-box-info   (hash-table-ref tests-hash testname))
	 (test-box-center (dcommon:get-box-center test-box-info))
	 (test-record     (hash-table-ref test-records testname))
	 (waitons         (vector-ref test-record 2)))
    (for-each
     (lambda (waiton)
       (let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f))
	      (waiton-center   (dcommon:get-box-center (or waiton-box-info test-box-info))))
	 (dcommon:draw-arrow cnv test-box-center waiton-center)))
     waitons)
    ;; (debug:print 0 "test-box-info=" test-box-info)
    ;; (debug:print 0 "test-record=" test-record)
    ))

(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((dot-data ;; (map cdr (filter
		   ;; 	  (lambda (x)(equal? "node" (car x)))
	  (map string-split (tests:easy-dot test-records "plain")))
	 (scalef (hash-table-ref/default tests-draw-state 'scalef 8))

	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-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   10)
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    (print "dot-data=" dot-data)
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (let ((longest-str   (if (null? sorted-testnames) "         " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
      (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
	(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
    ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((nodedat (filter (lambda (x)
				    (if (equal? (car x) "node")
					(equal? hed (cadr x))
					#f))
				  dot-data))











		 (llx  (* (string->number (list-ref nodedat 2)) scalef))
		 (lly  (* (string->number (list-ref nodedat 3)) scalef))
		 (boxw (* (string->number (list-ref nodedat 4)) scalef))
		 (boxh (* (string->number (list-ref nodedat 5)) scalef)))


					; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	  (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))



	  ;; data used by mouse click calc. keep the wacky order for now.
	  (hash-table-set! tests-hash hed  (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) 
	  ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
	  (if (not (null? tal))
	      (loop (car tal)
		    (cdr tal))))))
    (for-each
     (lambda (testname)
       (dcommon:draw-arrows cnv testname tests-hash test-records))
     sorted-testnames)))





















(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- xadj 0.5)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- 0.5 yadj))))
	 (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
	 (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((tvals (hash-table-ref tests-hash hed))
		 (llx   (+ xdelta (list-ref tvals 0)))
		 (lly   (+ ydelta (list-ref tvals 4)))
		 (boxw  (list-ref tvals 5))
		 (boxh  (list-ref tvals 6))







		 (urx   (+ llx boxw))
		 (ury   (+ lly boxh)))
	    (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))

	    (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh))
	    (if (not (null? tal))
		;; leave a column of space to the right to list items
		(loop (car tal)
		      (cdr tal))))))
    (for-each
     (lambda (testname)
       (dcommon:draw-arrows cnv testname tests-hash test-records))
     sorted-testnames)))

;;======================================================================
;;  S T E P S
;;======================================================================

(define (dcommon:populate-steps teststeps steps-matrix)
  (let ((max-row 0))







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




















|
>


|
|



|









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

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


|


|
|
|
|
|
|










>
>
>
>
>
>
>


|
>
|



|
|
|
|
|







633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
(define (dcommon:get-box-center box)
  (let* ((llx  (list-ref box 0))
	 (lly  (list-ref box 4))
	 (boxw (list-ref box 5))
	 (boxh (list-ref box 6)))
    (vector (+ llx (/ boxw 2))
	    (+ lly (/ boxh 2)))))

(define-inline (num->int num)
  (inexact->exact (round num)))

(define (dcommon:draw-edges cnv scalef edges)
  (for-each
   (lambda (e)
     (let loop ((x1 (car e))
		(y1 (cadr e))
		(x2 #f)
		(y2 #f)
		(tal (cddr e)))
       (if (and x1 y1 x2 y2)
	   (canvas-line! cnv x1 y1 x2 y2)) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2)))
       (if (< (length tal) 2)
	   (canvas-mark! cnv x1 y1) ;; (num->int x1)(num->int y1))
	   (loop (car tal)(cadr tal) x1 y1 (cddr tal)))))
   (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges)))


(define (dcommon:draw-arrows cnv testname tests-hash test-records)
  (let* ((test-box-info   (hash-table-ref tests-hash testname))
	 (test-box-center (dcommon:get-box-center test-box-info))
	 (test-record     (hash-table-ref test-records testname))
	 (waitons         (vector-ref test-record 2)))
    (for-each
     (lambda (waiton)
       (let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f))
	      (waiton-center   (dcommon:get-box-center (or waiton-box-info test-box-info))))
	 (dcommon:draw-arrow cnv test-box-center waiton-center)))
     waitons)
    ;; (debug:print 0 "test-box-info=" test-box-info)
    ;; (debug:print 0 "test-record=" test-record)
    ))

(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((dot-data ;; (map cdr (filter
		   ;; 	  (lambda (x)(equal? "node" (car x)))
	  (map string-split (tests:easy-dot test-records "plain")))
	 (scalef (hash-table-ref   tests-draw-state 'scalef))
	 (dotscale (hash-table-ref tests-draw-state 'dotscale))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) 1 (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) 1 (- yadj 0.5))))
	 (boxw   10)
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    ;; (print "dot-data=" dot-data)
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (let ((longest-str   (if (null? sorted-testnames) "         " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
      (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
	(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
    ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((nodedat (car (filter (lambda (x)
					 (if (equal? (car x) "node")
					     (equal? hed (cadr x))
					     #f))
				       dot-data)))
		 (edgedat (let ((edges (filter (lambda (x)  ;; filter for edge
						 (if (equal? (car x) "edge")
						     (equal? hed (cadr x))
						     #f))
					       dot-data)))
			    (map (lambda (inlst)
				   (map (lambda (instr)
					  (* dotscale (string->number instr))) ;; convert to number and scale
					(let ((il (cddddr inlst)))
					  (take il (- (length il) 2)))))
				 edges)))
		 (llx  (* (string->number (list-ref nodedat 2)) dotscale))
		 (lly  (* (string->number (list-ref nodedat 3)) dotscale))
		 (boxw (* (string->number (list-ref nodedat 4)) dotscale))
		 (boxh (* (string->number (list-ref nodedat 5)) dotscale))
		 (urx  (+ llx boxw))
		 (ury  (+ lly boxh)))
					; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	    (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	    ;; (dcommon:draw-arrows cnv testname tests-hash test-records))
	    (dcommon:draw-edges cnv scalef edgedat)
	    
	    ;; data used by mouse click calc. keep the wacky order for now.
	    (hash-table-set! tests-hash hed  (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edgedat)) 
	    ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
	    (if (not (null? tal))
		(loop (car tal)
		      (cdr tal))))))
    ;; (for-each
    ;;  (lambda (testname)
    ;;    (dcommon:draw-arrows cnv testname tests-hash test-records))
    ;;  sorted-testnames))
    ))

;; per-point-proc required, remainder optional
;;
(define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc)
  (if (< (length line) 2)
      '()
      (let loop ((x1   (car  line))
		 (y1   (cadr line))
		 (x2   #f)
		 (y2   #f)
		 (tal  (cddr line))
		 (res  '()))
	(if (and x1 y1 x2 y2 per-segment-proc)
	    (per-segment-proc x1 y1 x2 y2))
	(if (< (length tal) 2)
	    (begin
	      (if last-segment-proc (last-segment-proc x1 y1 x2 y2))
	      (append res (per-point-proc x1 y1)))
	    (loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1)))))))

(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((scalef              (hash-table-ref tests-draw-state 'scalef))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig              (+ test-browse-xoffset (* (/ sizex 2) (- xadj 0.5)))) ;;  (- xadj 1))))
	 (ytorig              (+ test-browse-yoffset (* (/ sizey 2) (- 0.5 yadj))))
	 (xdelta              (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
	 (ydelta              (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
	 (tests-hash          (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests      (hash-table-ref tests-draw-state 'selected-tests )))
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((tvals (hash-table-ref tests-hash hed))
		 (llx   (+ xdelta (list-ref tvals 0)))
		 (lly   (+ ydelta (list-ref tvals 4)))
		 (boxw  (list-ref tvals 5))
		 (boxh  (list-ref tvals 6))
		 (edges (map (lambda (pline)
			       (dcommon:process-polyline pline
							 (lambda (x1 y1)
							   (list (+ x1 xdelta)
								 (+ y1 ydelta)))
							 #f #f))
			     (list-ref tvals 7)))
		 (urx   (+ llx boxw))
		 (ury   (+ lly boxh)))
	    (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	    (dcommon:draw-edges cnv scalef edges)
	    (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edges))
	    (if (not (null? tal))
		;; leave a column of space to the right to list items
		(loop (car tal)
		      (cdr tal))))))))
    ;; (for-each
    ;;  (lambda (testname)
    ;;    (dcommon:draw-edges cnv scalef edges)) ;; (dcommon:draw-arrows cnv testname tests-hash test-records))
    ;;  sorted-testnames)))

;;======================================================================
;;  S T E P S
;;======================================================================

(define (dcommon:populate-steps teststeps steps-matrix)
  (let ((max-row 0))

Modified tests.scm from [528a547e4b] to [e3bfdc8511].

835
836
837
838
839
840
841

842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861

(define (tests:easy-dot test-records outtype)
  (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
    (let ((all-testnames (hash-table-keys test-records))
	  (temp-port     (open-output-file* fd)))
      ;; (format temp-port "This file is ~A.~%" temp-path)
      (format temp-port "digraph tests {\n")

      (for-each
       (lambda (testname)
	 (let* ((testrec (hash-table-ref test-records testname))
		(waitons (or (tests:testqueue-get-waitons testrec) '())))
	   (for-each
	    (lambda (waiton)
	      (format temp-port (conc "   " waiton " -> " testname "\n")))
	    waitons)))
       all-testnames)
      (format temp-port "}\n")
      (close-output-port temp-port)
      (with-input-from-pipe
       (conc "dot -T" outtype " < " temp-path)
       (lambda ()
	 (let ((res (read-lines)))
	   ;; (delete-file temp-path)
	   res))))))

(define (tests:write-dot-file test-records fname)
  (if (file-write-access? (pathname-directory fname))







>






|





|







835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862

(define (tests:easy-dot test-records outtype)
  (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
    (let ((all-testnames (hash-table-keys test-records))
	  (temp-port     (open-output-file* fd)))
      ;; (format temp-port "This file is ~A.~%" temp-path)
      (format temp-port "digraph tests {\n")
      ;; (format temp-port "   splines=none\n")
      (for-each
       (lambda (testname)
	 (let* ((testrec (hash-table-ref test-records testname))
		(waitons (or (tests:testqueue-get-waitons testrec) '())))
	   (for-each
	    (lambda (waiton)
	      (format temp-port (conc "   " waiton " -> " testname " [splines=ortho]\n")))
	    waitons)))
       all-testnames)
      (format temp-port "}\n")
      (close-output-port temp-port)
      (with-input-from-pipe
       (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
       (lambda ()
	 (let ((res (read-lines)))
	   ;; (delete-file temp-path)
	   res))))))

(define (tests:write-dot-file test-records fname)
  (if (file-write-access? (pathname-directory fname))