144 lines
5.0 KiB

;;;; STk adaptation of the Tk widget demo.
;;;; This demonstration script creates a canvas widget that displays a ruler
;;;; with tab stops that can be set, moved, and deleted.
(require "Tk-classes")
(define ruler-x 0)
(define ruler-y 0)
(define ruler-grid '.25c)
(define ruler-left 0)
(define ruler-right 0)
(define ruler-top 0)
(define ruler-bottom 0)
(define ruler-size 0)
(define ruler-item #f)
(define (demo-ruler)
(define w (make-demo-toplevel "ruler"
"Ruler Demonstration"
"This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button."))
(define c (make <Canvas> :parent w :width '14.8c :height '2.5c))
(define (make-coords fmt . args)
(read-from-string (apply format #f (string-append "(" fmt ")") args)))
(pack c :fill "x")
(make <Line> :parent c :coords '(1c 0.5c 1c 1c 13c 1c 13c 0.5c) :width 1)
(dotimes (i 12)
(let ((x (+ i 1)))
(make <Line> :parent c :coords (make-coords "~Ac 1c ~Ac 0.6c" x x))
(make <Line> :parent c :coords (make-coords "~A.25c 1c ~A.25c 0.8c" x x))
(make <Line> :parent c :coords (make-coords "~A.5c 1c ~A.5c 0.7c" x x))
(make <Line> :parent c :coords (make-coords "~A.75c 1c ~A.75c 0.8c" x x))
(make <Text-item> :parent c :coords (make-coords "~A.15c .75c" x)
:text i :anchor 'sw)))
(let ((r (make <Rectangle> :parent c :coords '(13.2c 1c 13.8c 0.5c)
:outline "black" :fill (background c)))
(tab (make-ruler-tab c (winfo 'pixels c '13.5c) (winfo 'pixels c '.65c))))
(add-tag r "weel")
(add-tag tab "weel")
(bind c "weel" "<1>" (lambda (x y) (ruler-new-tab c x y)))
(bind c "tab" "<1>" (lambda (x y) (ruler-select-tab c x y)))
(bind c "<B1-Motion>" (lambda (x y) (ruler-move-tab c x y)))
(bind c "<Any-ButtonRelease-1>" (lambda () (ruler-release-tab c))))
(set! ruler-left (winfo 'fpixels c '1c))
(set! ruler-right (winfo 'fpixels c '13c))
(set! ruler-top (winfo 'fpixels c '1c))
(set! ruler-bottom (winfo 'fpixels c '1.5c))
(set! ruler-size (winfo 'fpixels c '.2c)))
;;;; make-ruler-tab --
;;;; This procedure creates a new triangular polygon in a canvas to
;;;; represent a tab stop.
(define (make-ruler-tab c x y)
(let ((size [winfo 'pixels c '.2c]))
(make <Polygon> :parent c :fill 'black
:coords (list x y (+ x size) (+ y size) (- x size) (+ y size)))))
;;;; ruler-new-tab --
;;;; Does all the work of creating a tab stop, including creating the
;;;; triangle object and adding tags to it to give it tab behavior.
(define (ruler-new-tab c x y)
(let ((tab (make-ruler-tab c x y)))
(add-tag tab "active")
(add-tag tab "tab")
(set! ruler-x x)
(set! ruler-y y)
(set! ruler-item tab)
(ruler-move-tab c x y)))
;;;; ruler-select-tab --
;;;; This procedure is invoked when mouse button 1 is pressed over
;;;; a tab. It remembers information about the tab so that it can
;;;; be dragged interactively.
(define (ruler-select-tab c x y)
(add-tag c "active" 'withtag 'current)
(raise c "active")
(set! ruler-x (canvas-x c x ruler-grid))
(set! ruler-y (+ ruler-top 2))
(set! ruler-item (car (find-items c 'withtag "active")))
(ruler-set-style! ruler-item 'active)
;;;; ruler-move-tab --
;;;; This procedure is invoked during mouse motion events to drag a tab.
;;;; It adjusts the position of the tab, and changes its appearance if
;;;; it is about to be dragged out of the ruler.
(define (ruler-move-tab c x y)
(let ((active (find-items c 'withtag "active")))
(unless (null? active)
(let ((cx (canvas-x c x ruler-grid))
(cy (canvas-y c y)))
(if (< cx ruler-left) (set! cx ruler-left))
(if (> cx ruler-right) (set! cx ruler-right))
(if (and (>= cy ruler-top) (<= cy ruler-bottom))
(set! cy (+ ruler-top 2))
(ruler-set-style! ruler-item 'active)
(set! cy (- cy ruler-size 2))
(ruler-set-style! ruler-item 'delete)
(move (car active) (- cx ruler-x) (- cy ruler-y))
(set! ruler-x cx)
(set! ruler-y cy)))))
;;;; ruler-release-tab --
;;;; This procedure is invoked during button release events that end
;;;; a tab drag operation. It deselects the tab and deletes the tab if
;;;; it was dragged out of the ruler.
(define (ruler-release-tab c)
(let ((active (find-items c 'withtag "active")))
(unless (null? active)
(if (= ruler-y (+ ruler-top 2))
(ruler-set-style! ruler-item 'normal)
(delete-tag c "active"))
(canvas-delete c "active")))))
;;;; ruler-set-style!
;;;; Set the style of the tab
(define (ruler-set-style! tab style)
(case style
((active) (when (> (winfo 'depth (parent tab)) 1) (slot-set! tab 'fill "red"))
(slot-set! tab 'stipple ""))
((delete) (slot-set! tab 'stipple 'gray25))
((normal) (slot-set! tab 'fill "black"))))