Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -728,11 +728,11 @@ (else (set! full-cmd " no valid command "))) (iup:attribute-set! cmd-tb "VALUE" full-cmd))) ;; Display the tests as rows of boxes on the test/task pane ;; -(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) (canvas-clear! cnv) (canvas-font-set! cnv "Helvetica, -10") (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) ;; (print "originx: " originx " originy: " originy) @@ -744,12 +744,12 @@ (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)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) + (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)) )) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== @@ -924,11 +924,11 @@ (iup:canvas #:action (make-canvas-action (lambda (cnv xadj yadj) (if (not updater) (set! updater (lambda (xadj yadj) ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) - (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) (set! last-xadj xadj) (set! last-yadj yadj)))) (updater xadj yadj) (set! the-cnv cnv) )) @@ -939,11 +939,11 @@ -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)) + (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" Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -588,11 +588,68 @@ (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:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) +(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)) + (waiton-center-x (vector-ref waiton-center 0)) + (waiton-center-y (vector-ref waiton-center 1)) + (delta-y (- waiton-center-y test-box-center-y)) + (delta-x (- waiton-center-x test-box-center-x)) + (use-delta-x (> (abs delta-x)(abs delta-y))) ;; use the larger one + (delta-ratio (if use-delta-x + (/ (abs delta-y)(abs delta-x)) + (/ (abs delta-x)(abs delta-y)))) + (x-adj (if use-delta-x + 8 + (* delta-ratio 8))) + (y-adj (if use-delta-x + (* x-adj delta-ratio) + 8)) + (new-waiton-x (inexact->exact + (round (if (> delta-x 0) ;; have positive x + (- waiton-center-x x-adj) + (+ waiton-center-x x-adj))))) + (new-waiton-y (inexact->exact + (round (if (> delta-y 0) + (- waiton-center-y y-adj) + (+ waiton-center-y y-adj)))))) + ;; (canvas-line-width-set! cnv 5) + (canvas-line! cnv + test-box-center-x + test-box-center-y + new-waiton-x + new-waiton-y + ) + (canvas-mark! cnv new-waiton-x new-waiton-y))) + +(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* ((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)))) @@ -629,18 +686,22 @@ (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))))))))) + (if have-room ury (+ ury boxh gapy))))))) + (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) +(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 (- 0.5 xadj)))) ;; (- xadj 1)))) - (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (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) @@ -658,11 +719,15 @@ (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)))))))) + (cdr tal)))))) + (for-each + (lambda (testname) + (dcommon:draw-arrows cnv testname tests-hash test-records)) + sorted-testnames))) ;;====================================================================== ;; S T E P S ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -762,48 +762,43 @@ tcfg)) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) - (let ((mungepriority (lambda (priority) - (if priority - (let ((tmp (any->number priority))) - (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) - 0)))) - (sort - (hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table - (lambda (a b) - (let* ((a-record (hash-table-ref test-records a)) - (b-record (hash-table-ref test-records b)) - (a-waitons (tests:testqueue-get-waitons a-record)) - (b-waitons (tests:testqueue-get-waitons b-record)) - (a-config (tests:testqueue-get-testconfig a-record)) - (b-config (tests:testqueue-get-testconfig b-record)) - (a-raw-pri (config-lookup a-config "requirements" "priority")) - (b-raw-pri (config-lookup b-config "requirements" "priority")) - (a-priority (mungepriority a-raw-pri)) - (b-priority (mungepriority b-raw-pri))) - ;; (debug:print 5 "sort-by-priority-and-waiton, a: " a " b: " b - ;; "\n a-record: " a-record - ;; "\n b-record: " b-record - ;; "\n a-waitons: " a-waitons - ;; "\n b-waitons: " b-waitons - ;; "\n a-config: " (hash-table->alist a-config) - ;; "\n b-config: " (hash-table->alist b-config) - ;; "\n a-raw-pri: " a-raw-pri - ;; "\n b-raw-pri: " b-raw-pri - ;; "\n a-priority: " a-priority - ;; "\n b-priority: " b-priority) - (tests:testqueue-set-priority! a-record a-priority) - (tests:testqueue-set-priority! b-record b-priority) - (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons)) - #f ;; cannot have a which is waiting on b happening before b - (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) - #t ;; this is the correct order, b is waiting on a and b is before a - (if (> a-priority b-priority) - #t ;; if a is a higher priority than b then we are good to go - (string-compare3 a b))))))))) + (let* ((mungepriority (lambda (priority) + (if priority + (let ((tmp (any->number priority))) + (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) + 0))) + (sort-fn1 + (lambda (a b) + (let* ((a-record (hash-table-ref test-records a)) + (b-record (hash-table-ref test-records b)) + (a-waitons (tests:testqueue-get-waitons a-record)) + (b-waitons (tests:testqueue-get-waitons b-record)) + (a-config (tests:testqueue-get-testconfig a-record)) + (b-config (tests:testqueue-get-testconfig b-record)) + (a-raw-pri (config-lookup a-config "requirements" "priority")) + (b-raw-pri (config-lookup b-config "requirements" "priority")) + (a-priority (mungepriority a-raw-pri)) + (b-priority (mungepriority b-raw-pri))) + (tests:testqueue-set-priority! a-record a-priority) + (tests:testqueue-set-priority! b-record b-priority) + (or (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) + (not b-waitons))))) + (sort-fn2 + (lambda (a b) + (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) + (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b))))))) + (sort + (sort + (sort + (sort (hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table + sort-fn1) ;; first once by waiton + sort-fn2) ;; second by priority + sort-fn1) + sort-fn1))) ;; third by waiton again ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '()))