543
544
545
546
547
548
549
550
|
;; (show message-window
;; #:modal? #t
;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
;; ;; #:x 'mouse
;; ;; #:y 'mouse
;; )
))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
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
|
;; (show message-window
;; #:modal? #t
;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
;; ;; #:x 'mouse
;; ;; #:y 'mouse
;; )
))))
;;======================================================================
;; 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:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
(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 (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)
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames)))
(llx xtorig)
(lly ytorig)
(urx (+ xtorig boxw))
(ury (+ ytorig 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))))))))
(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
(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))))
(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)
(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)))))))
|