;;;;
;;;; Scrollbars bindings and procs
;;;;
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-1993 12:35
;;;; Last file update: 3-Sep-1999 19:54 (eg)
;;;;
(select-module Tk)
(let ()
(define tk::init-pos "")
(define tk::init-values '())
;; Standard Motif bindings:
(define-binding "Scrollbar" "<Enter>" (|W| x y)
(when *tk-strict-motif*
(set! tk::active-bg (tk-get |W| :activebackground))
(tk-set! |W| :activebackground (tk-get |W| :background)))
(|W| 'activate (|W| 'identify x y)))
(define-binding "Scrollbar" "<Motion>" (|W| x y)
(|W| 'activate (|W| 'identify x y)))
(define-binding "Scrollbar" "<Leave>" (|W|)
(if *tk-strict-motif*
(tk-set! |W| :activebackground tk::active-bg))
(|W| 'activate ""))
(define-binding "Scrollbar" "<1>" (|W| x y)
(Tk:scroll-button-down |W| x y))
(define-binding "Scrollbar" "<B1-Motion>" (|W| x y)
(Tk:scroll-drag |W| x y))
(define-binding "Scrollbar" "<B1-B2-Motion>" (|W| x y)
(Tk:scroll-drag |W| x y))
(define-binding "Scrollbar" "<ButtonRelease-1>" (|W| x y)
(Tk:scroll-button-up |W| x y))
(define-binding "Scrollbar" "<B1-Leave>" ()
;; Prevents <Leave> binding from being invoked.
'nop)
(define-binding "Scrollbar" "<B1-Enter>" ()
;; Prevents <Enter> binding from being invoked.
'nop)
(define-binding "Scrollbar" "<2>" (|W| x y)
(Tk:scroll-button-2-down |W| x y))
(define-binding "Scrollbar" "<B1-2>" ()
; Do nothing, since button 1 is already down.
'nop)
(define-binding "Scrollbar" "<B2-1>" (|W| x y)
; Do nothing, since button 2 is already down.
'nop)
(define-binding "Scrollbar" "<B2-Motion>" (|W| x y)
(Tk:scroll-drag |W| x y))
(define-binding "Scrollbar" "<ButtonRelease-2>" (|W| x y)
(Tk:scroll-button-up |W| x y))
(define-binding "Scrollbar" "<B1-ButtonRelease-2>" ()
;Do nothing: B1 release will handle it.
'nop)
(define-binding "Scrollbar" "<B2-ButtonRelease-1>" ()
;Do nothing: B1 release will handle it.
'nop)
(define-binding "Scrollbar" "<B2-Leave>" ()
;; Prevents <Leave> binding from being invoked.
'nop)
(define-binding "Scrollbar" "<B2-Enter>" ()
;; Prevents <Enter> binding from being invoked.
'nop)
(define-binding "Scrollbar" "<Control-1>" (|W| x y)
(Tk:scroll-top-bottom |W| x y))
(define-binding "Scrollbar" "<Control-2>" (|W| x y)
(Tk:scroll-top-bottom |W| x y))
(define-binding "Scrollbar" "<Up>" (|W|) (Tk:scroll-by-units |W| 'v -1))
(define-binding "Scrollbar" "<Down>" (|W|) (Tk:scroll-by-units |W| 'v +1))
(define-binding "Scrollbar" "<Control-Up>" (|W|) (Tk:scroll-by-pages |W| 'v -1))
(define-binding "Scrollbar" "<Control-Down>" (|W|) (Tk:scroll-by-pages |W| 'v +1))
(define-binding "Scrollbar" "<Left>" (|W|) (Tk:scroll-by-units |W| 'h -1))
(define-binding "Scrollbar" "<Right>" (|W|) (Tk:scroll-by-units |W| 'h +1))
(define-binding "Scrollbar" "<Control-Left>" (|W|) (Tk:scroll-by-pages |W| 'h -1))
(define-binding "Scrollbar" "<Control-Right>" (|W|) (Tk:scroll-by-pages |W| 'hd +1))
(define-binding "Scrollbar" "<Prior>" (|W|) (Tk:scroll-by-pages |W| 'hv -1))
(define-binding "Scrollbar" "<Next>" (|W|) (Tk:scroll-by-pages |W| 'hv +1))
(define-binding "Scrollbar" "<Home>" (|W|)
(Tk:scroll-to-pos |W| 0))
(define-binding "Scrollbar" "<End>" (|W|)
(Tk:scroll-to-pos |W| 1))
;; Tk:scroll-button-down --
;; This procedure is invoked when a button is pressed in a scrollbar.
;; It changes the way the scrollbar is displayed and takes actions
;; depending on where the mouse is.
;;
;; w - The scrollbar widget.
;; x, y - Mouse coordinates.
(define (Tk:scroll-button-down w x y)
(let ((element (w 'identify x y)))
(set! tk::relief (tk-get w :activerelief))
(tk-set! w :activerelief "sunken")
(if (equal? element "slider")
(Tk:scroll-start-drag w x y)
(Tk:scroll-select w element "initial"))))
;; Tk:scroll-button-up --
;; This procedure is invoked when a button is released in a scrollbar.
;; It cancels scans and auto-repeats that were in progress, and restores
;; the way the active element is displayed.
;;
;; w - The scrollbar widget.
;; x, y - Mouse coordinates.
(define (Tk:scroll-button-up w x y)
(Tk:cancel-repeat)
(tk-set! w :activerelief tk::relief)
(Tk:scroll-end-drag w x y)
(w 'activate (w 'identify x y)))
;; Tk:scroll-select --
;; This procedure is invoked when a button is pressed over the scrollbar.
;; It invokes one of several scrolling actions depending on where in
;; the scrollbar the button was pressed.
;;
;; w - The scrollbar widget.
;; element - The element of the scrollbar that was selected, such
;; as "arrow1" or "trough2". Shouldn't be "slider".
;; repeat - Whether and how to auto-repeat the action: "noRepeat"
;; means don't auto-repeat, "initial" means this is the
;; first action in an auto-repeat sequence, and "again"
;; means this is the second repetition or later.
(define (Tk:scroll-select w element repeat)
(when (winfo 'exists w)
(let ((cont (lambda ()
(cond
((string=? repeat "again")
(set! tk::after-id
(after (tk-get w :repeatinterval)
(lambda ()
(Tk:scroll-select w
element
"again")))))
((string=? repeat "initial")
(let ((delay (tk-get w :repeatdelay)))
(if (> delay 0)
(set! tk::after-id
(after delay
(lambda ()
(Tk:scroll-select w
element
"again")))))))))))
(cond
((equal? element "arrow1") (Tk:scroll-by-units w 'hv -1) (cont))
((equal? element "trough1") (Tk:scroll-by-pages w 'hv -1) (cont))
((equal? element "trough2") (Tk:scroll-by-pages w 'hv +1) (cont))
((equal? element "arrow2") (Tk:scroll-by-units w 'hv +1) (cont))))))
;; Tk:scroll-start-drag --
;; This procedure is called to initiate a drag of the slider. It just
;; remembers the starting position of the mouse and slider.
;;
;; w - The scrollbar widget.
;; x, y - The mouse position at the start of the drag operation.
(define (Tk:scroll-start-drag w x y)
(unless (equal? (tk-get w :command) "")
(set! tk::press-x x)
(set! tk::press-y y)
(set! tk::init-values (w 'get))
(let ((iv0 (car tk::init-values)))
(if (= (length tk::init-values) 2)
(set! tk::init-pos iv0)
(if (= iv0 0)
(set! tk::init-pos 0.0)
(set! tk::init-pos (/ (caddr tk::init-values)
(car tk::init-values))))))))
;; Tk:scroll-drag --
;; This procedure is called for each mouse motion even when the slider
;; is being dragged. It notifies the associated widget if we're not
;; jump scrolling, and it just updates the scrollbar if we are jump
;; scrolling.
;;
;; w - The scrollbar widget.
;; x, y - The current mouse position.
(define (Tk:scroll-drag w x y)
(unless (equal? tk::init-pos "")
(let ((delta (w 'delta (- x tk::press-x) (- y tk::press-y))))
(if (tk-get w :jump)
(if (equal? (length tk::init-values) 2)
(w 'set (+ (car tk::init-values) delta)
(+ (cadr tk::init-values) delta))
(let ((delta (floor (* delta (car tk::init-values)))))
(w 'set (car tk::init-values)
(cadr tk::init-values)
(+ (caddr tk::init-values) delta)
(+ (cadddr tk::init-values) delta))))
(Tk:scroll-to-pos w (+ tk::init-pos delta))))))
;; Tk:scroll-end-drag --
;; This procedure is called to end an interactive drag of the slider.
;; It scrolls the window if we're in jump mode, otherwise it does nothing.
;;
;; w - The scrollbar widget.
;; x, y - The mouse position at the end of the drag operation.
(define (Tk:scroll-end-drag w x y)
(unless (equal? tk::init-pos "")
(if (tk-get w :jump)
(let ((delta (w 'delta (- x tk::press-x) (- y tk::press-y))))
(Tk:scroll-to-pos w (+ tk::init-pos delta))))
(set! Tk::init-pos "")))
;; Tk:scroll-by-units --
;; This procedure tells the scrollbar's associated widget to scroll up
;; or down by a given number of units. It notifies the associated widget
;; in different ways for old and new command syntaxes.
;;
;; w - The scrollbar widget.
;; orient - Which kinds of scrollbars this applies to: "h" for
;; horizontal, "v" for vertical, "hv" for both.
;; amount - How many units to scroll: typically 1 or -1.
(define (Tk:scroll-by-units w orient amount)
(let ((cmd (tk-get w :command))
(worient (tk-get w :orient)))
(unless (equal? cmd "")
(when (or (eq? orient 'hv)
(and (eq? orient 'h) (string=? worient "horizontal"))
(and (eq? orient 'v) (string=? worient "vertical")))
(let ((info (w 'get)))
(if (= (length info) 2)
(cmd 'scroll amount 'units)
(cmd (+ (caddr info) amount))))))))
;; Tk:scroll-by-pages --
;; This procedure tells the scrollbar's associated widget to scroll up
;; or down by a given number of screenfuls. It notifies the associated
;; widget in different ways for old and new command syntaxes.
;;
;; Arguments:
;; w - The scrollbar widget.
;; orient - Which kinds of scrollbars this applies to: "h" for
;; horizontal, "v" for vertical, "hv" for both.
;; amount - How many screens to scroll: typically 1 or -1.
(define (Tk:scroll-by-pages w orient amount)
(let ((cmd (tk-get w :command))
(worient (tk-get w :orient)))
(unless (equal? cmd "")
(when (or (eq? orient 'hv)
(and (eq? orient 'h) (string=? worient "horizontal"))
(and (eq? orient 'v) (string=? worient "vertical")))
(let ((info (w 'get)))
(if (= (length info) 2)
(cmd 'scroll amount 'pages)
(cmd (+ (caddr info) (* (cadr info) amount) -1))))))))
;; Tk:scroll-ToPos --
;; This procedure tells the scrollbar's associated widget to scroll to
;; a particular location, given by a fraction between 0 and 1. It notifies
;; the associated widget in different ways for old and new command syntaxes.
;;
;; Arguments:
;; w - The scrollbar widget.
;; pos - A fraction between 0 and 1 indicating a desired position
;; in the document.
(define (Tk:scroll-to-pos w pos)
(let ((cmd (tk-get w :command)))
(unless (equal? cmd "")
(let ((info (w 'get)))
(if (= (length info) 2)
(cmd 'moveto pos)
(cmd (floor (* (car info) pos))))))))
;; Tk:scroll-top-bottom
;; Scroll to the top or bottom of the document, depending on the mouse
;; position.
;;
;; w - The scrollbar widget.
;; x, y - Mouse coordinates within the widget.
(define (Tk:scroll-top-bottom w x y)
(let ((element (w 'identify x y)))
(cond
((member element '("arrow1" "trough1")) (Tk:scroll-to-pos w 0))
((member element '("arrow2" "trough2")) (Tk:scroll-to-pos w 1)))
;; Set tk::relief, since it's needed by Tk:scroll-button-up.
(set! tk::relief (tk-get w :activerelief))))
;; Tk:scroll-button-2-down
;; This procedure is invoked when button 2 is pressed over a scrollbar.
;; If the button is over the trough or slider, it sets the scrollbar to
;; the mouse position and starts a slider drag. Otherwise it just
;; behaves the same as button 1.
;;
;; Arguments:
;; w - The scrollbar widget.
;; x, y - Mouse coordinates within the widget.
(define (Tk:scroll-button-2-down w x y)
(let ((element (w 'identify x y)))
(if (or (equal? element "arrow1") (equal? element "arrow2"))
(Tk:scroll-button-down w x y)
(begin
(Tk:scroll-to-pos w (w 'fraction x y))
(set! tk::relief (tk-get w :activerelief))
; Need the "update idletasks" below so that the widget calls us
; back to reset the actual scrollbar position before we start the
; slider drag.
(update 'idletasks)
(tk-set! w :activerelief "sunken")
(w 'activate 'slider)
(Tk:scroll-start-drag w x y)))))
)