stk/Lib/listbox.stk

;;;;
;;;; Listboxes bindings and procs
;;;;
;;;; Copyright <20> 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))))