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))
|