Overview
Comment: | Added some primitive arrows to dashboard tests display, played with different options on sort by waiton/priority but it seems to not be respected ... |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.60 |
Files: | files | file ages | folders |
SHA1: |
01ebfc1ba9a9f42df9ddbccf649cd918 |
User & Date: | matt on 2015-10-06 23:59:15 |
Other Links: | branch diff | manifest | tags |
Context
2015-10-08
| ||
08:47 | Fixed divide by zero problem check-in: cfdbfe1a43 user: mrwellan tags: v1.60 | |
2015-10-06
| ||
23:59 | Added some primitive arrows to dashboard tests display, played with different options on sort by waiton/priority but it seems to not be respected ... check-in: 01ebfc1ba9 user: matt tags: v1.60 | |
00:24 | Fixed couple issues with testconfig caching and fixed sorting on dashboard for -event_time case check-in: 00fe09dc6c user: matt tags: v1.60 | |
Changes
Modified dashboard.scm from [cf1ba76b54] to [ac75ce00c0].
︙ | ︙ | |||
726 727 728 729 730 731 732 | statuses-str ))) (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 ;; | | | | | 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 | statuses-str ))) (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 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) ;; (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)) )) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; ;; A gui for launching tests |
︙ | ︙ | |||
922 923 924 925 926 927 928 | (the-cnv #f) (canvas-obj (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) | | | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 | (the-cnv #f) (canvas-obj (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 test-records) (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" |
︙ | ︙ |
Modified dcommon.scm from [207685ba58] to [626e737efc].
︙ | ︙ | |||
586 587 588 589 590 591 592 | (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))))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 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 | (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)) (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)))) (boxw 90) ;; default, overriden by length estimate below (boxh 25) |
︙ | ︙ | |||
627 628 629 630 631 632 633 | (> (* 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)) | | > > > > | | | | 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 | (> (* 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))) (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)) |
︙ | ︙ | |||
656 657 658 659 660 661 662 | (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) | | > > > > | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 | (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)) |
︙ | ︙ |
Modified tests.scm from [2e87ac7108] to [ed3dfc9807].
︙ | ︙ | |||
760 761 762 763 764 765 766 | (debug:print-info 1 "Caching testconfig for " test-name " in " tpath) (configf:write-alist tcfg tpath))) 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) | | | | | | | < | | | | | | | | | | | < < < < < < < < < < < | | < < | < > > > | | | > > > > > > > | 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 803 804 805 806 | (debug:print-info 1 "Caching testconfig for " test-name " in " tpath) (configf:write-alist tcfg tpath))) 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-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 '())) (for-each (lambda (testkeyname) |
︙ | ︙ |