Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -738,11 +738,12 @@ ;; (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 '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))))))) @@ -775,11 +776,12 @@ (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) + ;; (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 @@ -932,20 +934,27 @@ (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)))) + (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 xadj yadj tests-draw-state sorted-testnames test-records)) - (set! last-xadj xadj) - (set! last-yadj yadj) + (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" Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -579,15 +579,15 @@ ;;====================================================================== ;; 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))) +(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) @@ -635,10 +635,29 @@ (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)) @@ -652,66 +671,105 @@ ;; (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* ((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 90) ;; default, overriden by length estimate below - (boxh 25) - (gapx 20) - (gapy 30) - (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) - (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))) - (llx xtorig) - (lly ytorig) - (urx (+ xtorig boxw)) - (ury (+ ytorig boxh))) + (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) + (dcommon:process-polyline + (map (lambda (instr) + (* dotscale (string->number instr))) ;; convert to number and scale + (let ((il (cddddr inlst))) + (take il (- (length il) 2)))) + (lambda (x y) + (list (+ x xtorig) + (+ y ytorig))) + #f #f)) ;; process polyline + 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 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)) - ;; leave a column of space to the right to list items - (let ((have-room - (if #t ;; put "auto" here where some form of auto rearanging can be done - (> (* 3 (+ boxw gapx)) (- urx xtorig)) - (< 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))))))) - (for-each - (lambda (testname) - (dcommon:draw-arrows cnv testname tests-hash test-records)) - sorted-testnames))) + (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/default tests-draw-state 'scalef 8)) + (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) 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 ))) + (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)))) @@ -718,22 +776,30 @@ (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 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)) + (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-arrows cnv testname tests-hash test-records)) - sorted-testnames))) + (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 ;;====================================================================== Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -404,10 +404,12 @@ ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? + ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic + ;; ezstep names need a full re-eval here. (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -839,23 +839,24 @@ (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 "\n"))) + (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 "dot -T" outtype " < " temp-path) + (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) (lambda () (let ((res (read-lines))) ;; (delete-file temp-path) res))))))