379 lines
13 KiB
Plaintext
379 lines
13 KiB
Plaintext
;;;;
|
|
;;;; Listboxes 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:52 (eg)
|
|
;;;;
|
|
|
|
(select-module Tk)
|
|
|
|
;;
|
|
;; Global variables used in this file
|
|
;;
|
|
(define tk::listbox-selection '())
|
|
(define tk::listbox-prev 0)
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Class bindings for listbox widgets.
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define-binding "Listbox" "<1>" (|W| x y)
|
|
; Note: the check for existence of %W below is because this binding
|
|
; is sometimes invoked after a window has been deleted (e.g. because
|
|
; there is a double-click binding on the widget that deletes it). Users
|
|
; can put "break"s in their bindings to avoid the error, but this check
|
|
; makes that unnecessary.
|
|
(when (winfo 'exists |W|)
|
|
(Tk:listbox-begin-select |W| (|W| 'index (format #f "@~A,~A" x y)))))
|
|
|
|
(define-binding "Listbox" "<Double-1>"
|
|
;; Ignore double clicks so that users can define their own behaviors.
|
|
;; Among other things, this prevents errors if the user deletes the
|
|
;; listbox on a double click.
|
|
(lambda () #f))
|
|
|
|
(define-binding "Listbox" "<B1-Motion>" (|W| x y)
|
|
(set! tk::x x)
|
|
(set! tk::y y)
|
|
(Tk:listbox-motion |W| (|W| 'index (format #f "@~A,~A" x y))))
|
|
|
|
(define-binding "Listbox" "<ButtonRelease-1>" (|W| x y)
|
|
(Tk:cancel-repeat)
|
|
(|W| 'activate (format #f "@~A,~A" x y)))
|
|
|
|
(define-binding "Listbox" "<Shift-1>" (|W| x y)
|
|
(Tk:listbox-begin-extend |W| (|W| 'index (format #f "@~A,~A" x y))))
|
|
|
|
(define-binding "Listbox" "<Control-1>" (|W| x y)
|
|
(Tk:listbox-begin-toggle |W| (|W| 'index (format #f "@~A,~A" x y))))
|
|
|
|
(define-binding "Listbox" "<B1-Leave>" (|W| x y)
|
|
(set! tk::x x)
|
|
(set! tk::y y)
|
|
(Tk:listbox-auto-scan |W|))
|
|
|
|
(define-binding "Listbox" "<B1-Enter>" ()
|
|
(Tk:cancel-repeat))
|
|
|
|
(define-binding "Listbox" "<Up>" (|W|)
|
|
(Tk:listbox-up-down |W| -1))
|
|
|
|
(define-binding "Listbox" "<Shift-Up>" (|W|)
|
|
(Tk:listbox-extend-up-down |W| -1))
|
|
|
|
(define-binding "Listbox" "<Down>" (|W|)
|
|
(Tk:listbox-up-down |W| 1))
|
|
|
|
(define-binding "Listbox" "<Shift-Down>" (|W|)
|
|
(Tk:listbox-extend-up-down |W| 1))
|
|
|
|
(define-binding "Listbox" "<Left>" (|W|) (|W| 'xview 'scroll -1 'units))
|
|
(define-binding "Listbox" "<Control-Left>" (|W|) (|W| 'xview 'scroll -1 'pages))
|
|
(define-binding "Listbox" "<Right>" (|W|) (|W| 'xview 'scroll 1 'units))
|
|
(define-binding "Listbox" "<Control-Right>" (|W|) (|W| 'xview 'scroll 1 'pages))
|
|
(define-binding "Listbox" "<Prior>" (|W|) (|W| 'yview 'scroll -1 'pages))
|
|
(define-binding "Listbox" "<Next>" (|W|) (|W| 'yview 'scroll 1 'pages))
|
|
(define-binding "Listbox" "<Control-Prior>" (|W|) (|W| 'xview 'scroll -1 'pages))
|
|
(define-binding "Listbox" "<Control-Next>" (|W|) (|W| 'xview 'scroll 1 'pages))
|
|
|
|
(define-binding "Listbox" "<Home>" (|W|)
|
|
(|W| 'xview 'moveto 0))
|
|
|
|
(define-binding "Listbox" "<End>" (|W|)
|
|
(|W| 'xview 'moveto 1))
|
|
|
|
(define-binding "Listbox" "<Control-Home>" (|W|)
|
|
(|W| 'activate 0)
|
|
(|W| 'see 0)
|
|
(|W| 'selection 'clear 0 'end)
|
|
(|W| 'selection 'set 0))
|
|
|
|
(define-binding "Listbox" "<Shift-Control-Home>" (|W|)
|
|
(Tk:listbox-data-extend |W| 0))
|
|
|
|
(define-binding "Listbox" "<Control-End>" (|W|)
|
|
(|W| 'activate 'end)
|
|
(|W| 'see 'end)
|
|
(|W| 'selection 'clear 0 'end)
|
|
(|W| 'selection 'set 'end))
|
|
|
|
(define-binding "Listbox" "<Shift-Control-End>" (|W|)
|
|
(Tk:listbox-data-extend |W| (|W| 'index 'end)))
|
|
|
|
(define-binding "Listbox" "<<Copy>>" (|W|)
|
|
(when (equal? (selection 'own :displayof |W|) |W|)
|
|
(clipboard 'clear :displayof |W|)
|
|
(clipboard 'append :displayof |W| (selection 'get :displayof |W|))))
|
|
|
|
(define-binding "Listbox" "<space>" (|W|)
|
|
(Tk:listbox-begin-select |W| (|W| 'index 'active)))
|
|
|
|
(define-binding "Listbox" "<Select>" (|W|)
|
|
(Tk:listbox-begin-select |W| (|W| 'index 'active)))
|
|
|
|
(define-binding "Listbox" "<Control-Shift-space>" (|W|)
|
|
(Tk:listbox-begin-extend |W| (|W| 'index 'active)))
|
|
|
|
(define-binding "Listbox" "<Shift-Select>" (|W|)
|
|
(Tk:listbox-begin-extend |W| (|W| 'index 'active)))
|
|
|
|
(define-binding "Listbox" "<Escape>" (|W|)
|
|
(Tk:listbox-cancel |W|))
|
|
|
|
(define-binding "Listbox" "<Control-slash>" (|W|)
|
|
(Tk:listbox-select-all |W|))
|
|
|
|
(define-binding "Listbox" "<Control-backslash>" (|W|)
|
|
(unless (equal? (tk-get |W| :selectmode) "browse"))
|
|
(|W| 'selection 'clear 0 'end))
|
|
|
|
;; Additional Tk bindings that aren't part of the Motif look and feel:
|
|
|
|
(define-binding "Listbox" "<Shift-2>" (|W| x y)
|
|
(|W| 'scan 'mark x y))
|
|
|
|
(define-binding "Listbox" "<B2-Motion>" (|W| x y)
|
|
(|W| 'scan 'dragto x y))
|
|
|
|
|
|
;; Tk:listbox-begin-select --
|
|
;;
|
|
;; This procedure is typically invoked on button-1 presses. It begins
|
|
;; the process of making a selection in the listbox. Its exact behavior
|
|
;; depends on the selection mode currently in effect for the listbox;
|
|
;; see the Motif documentation for details.
|
|
;;
|
|
;; w - The listbox widget.
|
|
;; el - The element for the selection operation (typically the
|
|
;; one under the pointer). Must be in numerical form.
|
|
|
|
(define (Tk:listbox-begin-select w el)
|
|
(if (equal? (tk-get w :selectmode) "multiple")
|
|
(if (w 'selection 'includes el)
|
|
(w 'selection 'clear el)
|
|
(w 'selection 'set el))
|
|
(begin
|
|
(w 'selection 'clear 0 'end)
|
|
(w 'selection 'set el)
|
|
(w 'selection 'anchor el)
|
|
(set! tk::listbox-selection '())
|
|
(set! tk::listbox-prev el))))
|
|
|
|
|
|
;; Tk:listbox-Motion --
|
|
;;
|
|
;; This procedure is called to process mouse motion events while
|
|
;; button 1 is down. It may move or extend the selection, depending
|
|
;; on the listbox's selection mode.
|
|
;;
|
|
;; w - The listbox widget.
|
|
;; el - The element under the pointer (must be a number).
|
|
|
|
(define (Tk:listbox-Motion w el)
|
|
(unless (= el tk::listbox-prev)
|
|
(let ((anchor (w 'index 'anchor))
|
|
(mode (tk-get w :selectmode)))
|
|
(cond
|
|
((string=? mode "browse")
|
|
(w 'selection 'clear 0 'end)
|
|
(w 'selection 'set el)
|
|
(set! tk::listbox-prev el))
|
|
|
|
((string=? mode "extended")
|
|
(let ((i tk::listbox-prev))
|
|
(if (w 'selection 'includes 'anchor)
|
|
(begin
|
|
(w 'selection 'clear i el)
|
|
(w 'selection 'set 'anchor el))
|
|
(begin
|
|
(w 'selection 'clear i el)
|
|
(w 'selection 'clear 'anchor el)))
|
|
(while (and (< i el) (< i anchor))
|
|
(if (member i tk::listbox-selection)
|
|
(w 'selection 'set i))
|
|
(set! i (+ i 1)))
|
|
(while (and (> i el) (> i anchor))
|
|
(if (member i tk::listbox-selection)
|
|
(w 'selection 'set i))
|
|
(set! i (- i 1)))
|
|
(set! tk::listbox-prev el)))))))
|
|
|
|
;; Tk:listbox-BeginExtend --
|
|
;;
|
|
;; This procedure is typically invoked on shift-button-1 presses. It
|
|
;; begins the process of extending a selection in the listbox. Its
|
|
;; exact behavior depends on the selection mode currently in effect
|
|
;; for the listbox; see the Motif documentation for details.
|
|
;;
|
|
;; w - The listbox widget.
|
|
;; el - The element for the selection operation (typically the
|
|
;; one under the pointer). Must be in numerical form.
|
|
|
|
(define (Tk:listbox-begin-extend w el)
|
|
(when (equal? (tk-get w :selectmode) "extended")
|
|
(if (w 'selection 'includes 'anchor)
|
|
(Tk:listbox-motion w el)
|
|
;; No selection yet; simulate the begin-select operation
|
|
(Tk:listbox-begin-select w el))))
|
|
|
|
|
|
;; Tk:listbox-begin-toggle --
|
|
;;
|
|
;; This procedure is typically invoked on control-button-1 presses. It
|
|
;; begins the process of toggling a selection in the listbox. Its
|
|
;; exact behavior depends on the selection mode currently in effect
|
|
;; for the listbox; see the Motif documentation for details.
|
|
;;
|
|
;; w - The listbox widget.
|
|
;; el - The element for the selection operation (typically the
|
|
;; one under the pointer). Must be in numerical form.
|
|
|
|
(define (Tk:listbox-begin-toggle w el)
|
|
(when (equal? (tk-get w :selectmode) "extended")
|
|
(set! tk::listbox-selection (w 'curselection))
|
|
(set! tk::listbox-prev el)
|
|
(w 'selection 'anchor el)
|
|
(if (w 'selection 'includes el)
|
|
(w 'selection 'clear el)
|
|
(w 'selection 'set el))))
|
|
|
|
|
|
;; Tk:listbox-auto-scan --
|
|
;; This procedure is invoked when the mouse leaves an entry window
|
|
;; with button 1 down. It scrolls the window up, down, left, or
|
|
;; right, depending on where the mouse left the window, and reschedules
|
|
;; itself as an "after" command so that the window continues to 'scroll until
|
|
;; the mouse moves back into the window or the mouse button is released.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The entry window.
|
|
|
|
(define (Tk:listbox-auto-scan w)
|
|
(when (winfo 'exists w)
|
|
(let* ((x tk::x)
|
|
(y tk::y)
|
|
(scan (lambda ()
|
|
(Tk:listbox-motion w (w 'index (format #f "@~A,~A" x y)))
|
|
(set! tk::after-id (after 50 (lambda ()
|
|
(Tk:listbox-auto-scan w)))))))
|
|
(cond
|
|
((>= y (winfo 'height w)) (w 'yview 'scroll +1 'units) (scan))
|
|
((< y 0) (w 'yview 'scroll -1 'units) (scan))
|
|
((>= x (winfo 'width w)) (w 'xview 'scroll +2 'units) (scan))
|
|
((< x 0) (w 'xview 'scroll -2 'units) (scan))))))
|
|
|
|
|
|
;; Tk:listbox-up-down --
|
|
;;
|
|
;; Moves the location cursor (active element) up or down by one element,
|
|
;; and changes the selection if we're in browse or extended selection
|
|
;; mode.
|
|
;;
|
|
;; w - The listbox widget.
|
|
;; amount - +1 to move down one item, -1 to move back one item.
|
|
|
|
(define (Tk:listbox-up-down w amount)
|
|
(let ((mode (tk-get w :selectmode)))
|
|
(w 'activate (+ (w 'index 'active) amount))
|
|
(w 'see 'active)
|
|
(cond
|
|
((string=? mode "browse")
|
|
(w 'selection 'clear 0 'end)
|
|
(w 'selection 'set 'active))
|
|
((string=? mode "extended") (w 'selection 'clear 0 'end)
|
|
(w 'selection 'set 'active)
|
|
(w 'selection 'anchor 'active)
|
|
(set! tk::listbox-prev (w 'index 'active))
|
|
(set! tk::listbox-selection '())))))
|
|
|
|
;; Tk:listbox-extend-up-down --
|
|
;;
|
|
;; Does nothing unless we're in extended selection mode; in this
|
|
;; case it moves the location cursor (active element) up or down by
|
|
;; one element, and extends the selection to that point.
|
|
;;
|
|
;; w - The listbox widget.
|
|
;; amount - +1 to move down one item, -1 to move back one item.
|
|
|
|
(define (Tk:listbox-extend-up-down w amount)
|
|
(when (equal? (tk-get w :selectmode) "extended")
|
|
(w 'activate (+ (w 'index 'active) amount))
|
|
(w 'see 'active)
|
|
(Tk:listbox-motion w (w 'index 'active))))
|
|
|
|
|
|
;; Tk:listbox-data-extend
|
|
;;
|
|
;; This procedure is called for key-presses such as Shift-KEndData.
|
|
;; If the selection mode isn't multiple or extend then it does nothing.
|
|
;; Otherwise it moves the active element to el and, if we're in
|
|
;; extended mode, extends the selection to that point.
|
|
;;
|
|
;; w - The listbox widget.
|
|
;; el - An integer element number.
|
|
|
|
(define (Tk:listbox-data-extend w el)
|
|
(let ((mode (tk-get w :selectmode)))
|
|
(cond
|
|
((string=? mode "extended") (w 'activate el)
|
|
(w 'see el)
|
|
(if (w 'selection 'includes 'anchor)
|
|
(Tk:listbox-motion w el)))
|
|
((string=? mode "multiple") (w 'activate el)
|
|
(w 'see el)))))
|
|
|
|
;; Tk:listbox-cancel
|
|
;;
|
|
;; This procedure is invoked to cancel an extended selection in
|
|
;; progress. If there is an extended selection in progress, it
|
|
;; restores all of the items between the active one and the anchor
|
|
;; to their previous selection state.
|
|
;;
|
|
;; w - The listbox widget.
|
|
|
|
(define (Tk:listbox-cancel w)
|
|
(when (equal? (tk-get w :selectmode) "extended")
|
|
(let ((first (w 'index 'anchor))
|
|
(last tk::listbox-prev))
|
|
(when (> first last)
|
|
(let ((tmp first))
|
|
(set! first last)
|
|
(set! last tmp)))
|
|
(w 'selection 'clear first last)
|
|
(while (<= first last)
|
|
(if (member first tk::listbox-selection)
|
|
(w 'selection 'set first))
|
|
(set! first (+ first 1))))))
|
|
|
|
;; Tk:listbox-select-all
|
|
;;
|
|
;; This procedure is invoked to handle the "select all" operation.
|
|
;; For single and browse mode, it just selects the active element.
|
|
;; Otherwise it selects everything in the widget.
|
|
;;
|
|
;; w - The listbox widget.
|
|
|
|
(define (Tk:listbox-select-all w)
|
|
(let ((mode (tk-get w :selectmode)))
|
|
(if (or (equal? mode "single") (equal? mode "browse"))
|
|
(begin
|
|
(w 'selection 'clear 0 'end)
|
|
(w 'selection 'set 'active))
|
|
(w 'selection 'set 0 'end))))
|