Overview
Context
Changes
Modified dashboard.scm
from [eaa2d9a7a5]
to [cece23bcce].
| ︙ | | |
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
|
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
|
-
+
-
+
-
+
|
))
;; #:size "50x50"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
;; (print "obj: " obj)
(print "obj: " obj ", pressed " pressed ", status " status)
(let ((tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests)))
;; (print "x\ty\tllx\tlly\turx\tury")
;; (print "\tx\ty\tllx\tlly\turx\tury")
(for-each (lambda (test-name)
(let* ((rec-coords (hash-table-ref tests-info test-name))
(llx (list-ref rec-coords 0))
(urx (list-ref rec-coords 1))
(lly (list-ref rec-coords 2))
(ury (list-ref rec-coords 3)))
;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " "
;; (print "\t" x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " ")
(if (and (eq? pressed 1)
(> x llx)
(> y lly)
(< x urx)
(< y ury))
(let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
(let* ((selected (not (member test-name patterns)))
|
| ︙ | | |
Modified dcommon.scm
from [4f170e6a34]
to [5d1caffec5].
| ︙ | | |
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
|
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
|
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
|
;; (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")))
(map string-split (tests:lazy-dot test-records "plain"))) ;; (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)))
(let* ((nodedat (let ((tmpres (filter (lambda (x)
(if (and (not (null? x))
(equal? (car x) "node"))
(equal? hed (cadr x))
#f))
dot-data)))
(if (null? tmpres)
;; llx lly boxw boxh
(list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some junk
(car tmpres))))
(edgedat (let ((edges (filter (lambda (x) ;; filter for edge
(if (and (not (null? x))
(if (equal? (car x) "edge")
(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
|
| ︙ | | |
Modified tests.scm
from [74bec393f0]
to [e114fdcd33].
| ︙ | | |
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
+
|
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
| ︙ | | |
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
|
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
|
-
+
-
+
-
+
-
+
-
+
-
+
-
+
|
(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)
(debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
;; (debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
(cond
;; is
((member a b-waitons) ;; is b waiting on a?
(debug:print 0 "case1")
;; (debug:print 0 "case1")
#t)
((member b a-waitons) ;; is a waiting on b?
(debug:print 0 "case2")
;; (debug:print 0 "case2")
#f)
((and (not (null? a-waitons)) ;; both have waitons - do not disturb
(not (null? b-waitons)))
(debug:print 0 "case2.1")
;; (debug:print 0 "case2.1")
#t)
((and (null? a-waitons) ;; no waitons for a but b has waitons
(not (null? b-waitons)))
(debug:print 0 "case3")
;; (debug:print 0 "case3")
#f)
((and (not (null? a-waitons)) ;; a has waitons but b does not
(null? b-waitons))
(debug:print 0 "case4")
;; (debug:print 0 "case4")
#t)
((not (eq? a-priority b-priority)) ;; use
(> a-priority b-priority))
(else
(debug:print 0 "case5")
;; (debug:print 0 "case5")
(string>? a b))))))
(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)))))))
;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain")))
|
| ︙ | | |
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
|
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
|
+
+
-
+
+
+
-
-
-
+
+
+
+
-
-
-
+
-
-
-
-
-
+
+
+
+
-
-
-
-
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(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))
(with-output-to-file fname
(lambda ()
(map print (tests:tests->dot test-records))))
(map (lambda (waiton)
(conc " " waiton " -> " hed))
waitons))))
(map (lambda (waiton)
(conc " \"" waiton "\" -> \"" hed "\";"))
waitons)
))))
(if (null? tal)
(append newres (list "}"))
(loop (car tal)(cdr tal) newres)
))))))
;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")
(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats
(print "indat: ")
(map print indat)
(let-values (((inp oup pid)(process "dot" (list "-T" outtype))))
(let ((th1 (make-thread (lambda ()
(with-output-to-port oup
(lambda ()
(map print indat))))
"dot writer")))
(thread-start! th1)
(let ((res (with-input-from-port inp
(lambda ()
(read-lines)))))
(thread-join! th1)
(close-input-port inp)
(close-output-port oup)
;; (process-wait pid)
res))))
|
| ︙ | | |