144 lines
5.0 KiB
Plaintext
144 lines
5.0 KiB
Plaintext
;;;;
|
|
;;;; 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))
|
|
(begin
|
|
(set! cy (+ ruler-top 2))
|
|
(ruler-set-style! ruler-item 'active)
|
|
)
|
|
(begin
|
|
(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))
|
|
(begin
|
|
(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"))))
|