360 lines
12 KiB
Plaintext
360 lines
12 KiB
Plaintext
;;;;
|
|
;;;; 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)))))
|
|
|
|
)
|