home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / listbox.stk < prev    next >
Encoding:
Text File  |  1996-07-02  |  12.5 KB  |  377 lines
  1. ;;;;
  2. ;;;; Listboxes bindings and procs
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;; This software is a derivative work of other copyrighted softwares; the
  15. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  16. ;;;;
  17. ;;;;
  18. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  19. ;;;;    Creation date: 17-May-1993 12:35
  20. ;;;; Last file update:  2-Jul-1996 14:00
  21. ;;;;
  22.  
  23. (let ()
  24. ;;
  25. ;; Global variables used in this file
  26. ;; 
  27. (define tk::listbox-selection  '())
  28. (define tk::listbox-prev       0)
  29.  
  30. ;; ----------------------------------------------------------------------
  31. ;; Class bindings for listbox widgets.
  32. ;; ----------------------------------------------------------------------
  33.  
  34. (define-binding "Listbox" "<1>" (|W| x y)
  35.   ; Note: the check for existence of %W below is because this binding
  36.   ; is sometimes invoked after a window has been deleted (e.g. because
  37.   ; there is a double-click binding on the widget that deletes it).  Users
  38.   ; can put "break"s in their bindings to avoid the error, but this check
  39.   ; makes that unnecessary.
  40.   (when (winfo 'exists |W|)
  41.     (Tk:listbox-begin-select |W| (|W| 'index (format #f "@~A,~A" x y)))))
  42.  
  43. (define-binding "Listbox" "<2>" 
  44.   ;; Ignore double clicks so that users can define their own behaviors.
  45.   ;; Among other things, this prevents errors if the user deletes the
  46.   ;; listbox on a double click.
  47.   (lambda () #f))
  48.  
  49. (define-binding "Listbox" "<B1-Motion>" (|W| x y)
  50.   (set! tk::x x)
  51.   (set! tk::y y)
  52.   (Tk:listbox-motion |W| (|W| 'index (format #f "@~A,~A" x  y))))
  53.  
  54. (define-binding "Listbox" "<ButtonRelease-1>" (|W| x y)
  55.   (Tk:cancel-repeat)
  56.   (|W| 'activate (format #f "@~A,~A" x  y)))
  57.  
  58. (define-binding "Listbox" "<Shift-1>" (|W| x y)
  59.   (Tk:listbox-begin-extend |W| (|W| 'index (format #f "@~A,~A" x  y))))
  60.  
  61. (define-binding "Listbox" "<Control-1>" (|W| x y)
  62.   (Tk:listbox-begin-toggle |W| (|W| 'index (format #f "@~A,~A" x  y))))
  63.  
  64. (define-binding "Listbox" "<B1-Leave>" (|W| x y)
  65.   (set! tk::x x)
  66.   (set! tk::y y)
  67.   (Tk:listbox-auto-scan |W|))
  68.  
  69. (define-binding "Listbox" "<B1-Enter>" ()
  70.   (Tk:cancel-repeat))
  71.  
  72. (define-binding "Listbox" "<Up>" (|W|)
  73.   (Tk:listbox-up-down |W| -1))
  74.  
  75. (define-binding "Listbox" "<Shift-Up>" (|W|)
  76.   (Tk:listbox-extend-up-down |W| -1))
  77.  
  78. (define-binding "Listbox" "<Down>" (|W|)
  79.   (Tk:listbox-up-down |W| 1))
  80.  
  81. (define-binding "Listbox" "<Shift-Down>" (|W|)
  82.   (Tk:listbox-extend-up-down |W| 1))
  83.  
  84. (define-binding "Listbox" "<Left>"         (|W|) (|W| 'xview 'scroll -1 'units))
  85. (define-binding "Listbox" "<Control-Left>"  (|W|) (|W| 'xview 'scroll -1 'pages))
  86. (define-binding "Listbox" "<Right>"         (|W|) (|W| 'xview 'scroll  1 'units))
  87. (define-binding "Listbox" "<Control-Right>" (|W|) (|W| 'xview 'scroll  1 'pages))
  88. (define-binding "Listbox" "<Prior>"         (|W|) (|W| 'yview 'scroll -1 'pages))
  89. (define-binding "Listbox" "<Next>"         (|W|) (|W| 'yview 'scroll  1 'pages))
  90. (define-binding "Listbox" "<Control-Prior>" (|W|) (|W| 'xview 'scroll -1 'pages))
  91. (define-binding "Listbox" "<Control-Next>"  (|W|) (|W| 'xview 'scroll  1 'pages))
  92.  
  93. (define-binding "Listbox" "<Home>" (|W|)
  94.   (|W| 'xview 'moveto 0))
  95.  
  96. (define-binding "Listbox" "<End>" (|W|)
  97.   (|W| 'xview 'moveto 1))
  98.  
  99. (define-binding "Listbox" "<Control-Home>" (|W|)
  100.   (|W| 'activate 0)
  101.   (|W| 'see 0)
  102.   (|W| 'selection 'clear 0 'end)
  103.   (|W| 'selection 'set   0))
  104.  
  105. (define-binding "Listbox" "<Shift-Control-Home>" (|W|)
  106.   (Tk:listbox-data-extend |W| 0))
  107.  
  108. (define-binding "Listbox" "<Control-End>" (|W|)
  109.   (|W| 'activate 'end)
  110.   (|W| 'see 'end)
  111.   (|W| 'selection 'clear 0 'end)
  112.   (|W| 'selection 'set 'end))
  113.  
  114. (define-binding "Listbox" "<Shift-Control-End>" (|W|)
  115.   (Tk:listbox-data-extend |W| 'end))
  116.  
  117. (define-binding "Listbox" "<F16>" (|W|)
  118.   (when (equal? (selection 'own :displayof |W|) |W|)
  119.     (clipboard 'clear :displayof |W|)
  120.     (clipboard 'append :displayof |W| (selection 'get :displayof |W|))))
  121.  
  122. (define-binding "Listbox" "<space>" (|W|)
  123.   (Tk:listbox-begin-select |W| (|W| 'index 'active)))
  124.  
  125. (define-binding "Listbox" "<Select>" (|W|)
  126.   (Tk:listbox-begin-select |W| (|W| 'index 'active)))
  127.  
  128. (define-binding "Listbox" "<Control-Shift-space>" (|W|)
  129.   (Tk:listbox-begin-extend |W| (|W| 'index 'active)))
  130.  
  131. (define-binding "Listbox" "<Shift-Select>" (|W|)
  132.   (Tk:listbox-begin-extend |W| (|W| 'index 'active)))
  133.  
  134. (define-binding "Listbox" "<Escape>" (|W|)
  135.   (Tk:listbox-cancel |W|))
  136.  
  137. (define-binding "Listbox" "<Control-slash>" (|W|)
  138.   (Tk:listbox-select-all |W|))
  139.  
  140. (define-binding "Listbox" "<Control-backslash>" (|W|)
  141.   (unless (equal? (tk-get |W| :selectmode != "browse"))
  142.      (|W| 'selection 'clear 0 'end)))
  143.  
  144. ;; Additional Tk bindings that aren't part of the Motif look and feel:
  145.  
  146. (define-binding "Listbox" "<Shift-2>" (|W| x y)
  147.   (|W| 'scan 'mark x y))
  148.  
  149. (define-binding "Listbox" "<B2-Motion>" (|W| x y)
  150.   (|W| 'scan 'dragto x y))
  151.  
  152.  
  153. ;; Tk:listbox-begin-select --
  154. ;;
  155. ;; This procedure is typically invoked on button-1 presses.  It begins
  156. ;; the process of making a selection in the listbox.  Its exact behavior
  157. ;; depends on the selection mode currently in effect for the listbox;
  158. ;; see the Motif documentation for details.
  159. ;;
  160. ;; w -        The listbox widget.
  161. ;; el -        The element for the selection operation (typically the
  162. ;;        one under the pointer).  Must be in numerical form.
  163.  
  164. (define (Tk:listbox-begin-select w el)
  165.   (if (equal? (tk-get w :selectmode) "multiple")
  166.       (if (w 'selection 'includes el)
  167.       (w 'selection 'clear el)
  168.       (w 'selection 'set el))
  169.       (begin
  170.     (w 'selection 'clear 0 'end)
  171.     (w 'selection 'set el)
  172.     (w 'selection 'anchor el)
  173.     (set! tk::listbox-selection '())
  174.     (set! tk::listbox-prev el))))
  175.  
  176.  
  177. ;; Tk:listbox-Motion --
  178. ;;
  179. ;; This procedure is called to process mouse motion events while
  180. ;; button 1 is down.  It may move or extend the selection, depending
  181. ;; on the listbox's selection mode.
  182. ;;
  183. ;; w -        The listbox widget.
  184. ;; el -        The element under the pointer (must be a number).
  185.  
  186. (define (Tk:listbox-Motion w el)
  187.   (unless (= el tk::listbox-prev)
  188.     (let ((anchor (w 'index 'anchor))
  189.       (mode   (tk-get w :selectmode)))
  190.       (cond
  191.          ((string=? mode "browse")
  192.             (w 'selection 'clear 0 'end)
  193.         (w 'selection 'set el)
  194.         (set! tk::listbox-prev el))
  195.      
  196.     ((string=? mode "extended")
  197.          (let ((i tk::listbox-prev))
  198.           (if (w 'selection 'includes 'anchor)
  199.               (begin
  200.             (w 'selection 'clear i el)
  201.             (w 'selection 'set 'anchor el))
  202.               (begin
  203.             (w 'selection 'clear i el)
  204.             (w 'selection 'clear 'anchor el)))
  205.           (while (and (< i el) (< i anchor))
  206.              (if (member i tk::listbox-selection)
  207.              (w 'selection 'set i))
  208.              (set! i (+ i 1)))
  209.           (while (and (> i el) (> i anchor))
  210.              (if (member i tk::listbox-selection)
  211.              (w 'selection 'set i))
  212.              (set! i (- i 1)))
  213.           (set! tk::listbox-prev el)))))))
  214.  
  215. ;; Tk:listbox-BeginExtend --
  216. ;;
  217. ;; This procedure is typically invoked on shift-button-1 presses.  It
  218. ;; begins the process of extending a selection in the listbox.  Its
  219. ;; exact behavior depends on the selection mode currently in effect
  220. ;; for the listbox;  see the Motif documentation for details.
  221. ;;
  222. ;; w -        The listbox widget.
  223. ;; el -        The element for the selection operation (typically the
  224. ;;        one under the pointer).  Must be in numerical form.
  225.  
  226. (define (Tk:listbox-begin-extend w el)
  227.   (when (and (equal? (tk-get w :selectmode) "extended")
  228.          (w 'selection 'includes 'anchor))
  229.     (Tk:listbox-motion w el)))
  230.  
  231.  
  232. ;; Tk:listbox-begin-toggle --
  233. ;;
  234. ;; This procedure is typically invoked on control-button-1 presses.  It
  235. ;; begins the process of toggling a selection in the listbox.  Its
  236. ;; exact behavior depends on the selection mode currently in effect
  237. ;; for the listbox;  see the Motif documentation for details.
  238. ;;
  239. ;; w -        The listbox widget.
  240. ;; el -        The element for the selection operation (typically the
  241. ;;        one under the pointer).  Must be in numerical form.
  242.  
  243. (define (Tk:listbox-begin-toggle w el)
  244.   (when (equal? (tk-get w :selectmode) "extended")
  245.      (set! tk::listbox-selection (w 'curselection))
  246.      (set! tk::listbox-prev      el)
  247.      (w 'selection 'anchor el)
  248.      (if (w 'selection 'includes el)
  249.      (w 'selection 'clear el)
  250.      (w 'selection 'set   el))))
  251.  
  252.  
  253. ;; Tk:listbox-auto-scan --
  254. ;; This procedure is invoked when the mouse leaves an entry window
  255. ;; with button 1 down.  It scrolls the window up, down, left, or
  256. ;; right, depending on where the mouse left the window, and reschedules
  257. ;; itself as an "after" command so that the window continues to 'scroll until
  258. ;; the mouse moves back into the window or the mouse button is released.
  259. ;;
  260. ;; Arguments:
  261. ;; w -        The entry window.
  262.  
  263. (define (Tk:listbox-auto-scan w)
  264.   (when (winfo 'exists w)
  265.     (let* ((x    tk::x)
  266.        (y    tk::y)
  267.        (scan (lambda ()
  268.            (Tk:listbox-motion w (w 'index (format #f "@~A,~A" x y)))
  269.            (set! tk::after-id (after 50 (lambda ()
  270.                           (Tk:listbox-auto-scan w)))))))
  271.       (cond
  272.        ((>= y (winfo 'height w)) (w 'yview 'scroll +1 'units) (scan))
  273.        ((< y 0)             (w 'yview 'scroll -1 'units) (scan))
  274.        ((>= x (winfo 'width w))  (w 'xview 'scroll +2 'units) (scan))
  275.        ((< x 0)             (w 'xview 'scroll -2 'units) (scan))))))
  276.  
  277.  
  278. ;; Tk:listbox-up-down --
  279. ;;
  280. ;; Moves the location cursor (active element) up or down by one element,
  281. ;; and changes the selection if we're in browse or extended selection
  282. ;; mode.
  283. ;;
  284. ;; w -        The listbox widget.
  285. ;; amount -    +1 to move down one item, -1 to move back one item.
  286.  
  287. (define (Tk:listbox-up-down w amount)
  288.   (let ((mode (tk-get w :selectmode)))
  289.     (w 'activate (+ (w 'index 'active) amount))
  290.     (w 'see 'active)
  291.     (cond 
  292.       ((string=? mode "browse") 
  293.                  (w 'selection 'clear 0 'end)
  294.          (w 'selection 'set 'active))
  295.       ((string=? mode "extended") (w 'selection 'clear 0 'end)
  296.                   (w 'selection 'set 'active)
  297.                   (w 'selection 'anchor 'active)
  298.                   (set! tk::listbox-prev      (w 'index 'active))
  299.                   (set! tk::listbox-selection '())))))
  300.  
  301. ;; Tk:listbox-extend-up-down --
  302. ;;
  303. ;; Does nothing unless we're in extended selection mode;  in this
  304. ;; case it moves the location cursor (active element) up or down by
  305. ;; one element, and extends the selection to that point.
  306. ;;
  307. ;; w -        The listbox widget.
  308. ;; amount -    +1 to move down one item, -1 to move back one item.
  309.  
  310. (define (Tk:listbox-extend-up-down w amount)
  311.   (when  (equal? (tk-get w :selectmode) "extended")
  312.      (w 'activate (+ (w 'index 'active) amount))
  313.      (w 'see 'active)
  314.      (Tk:listbox-motion w (w 'index 'active))))
  315.  
  316.  
  317. ;; Tk:listbox-data-extend
  318. ;;
  319. ;; This procedure is called for key-presses such as Shift-KEndData.
  320. ;; If the selection mode isn't multiple or extend then it does nothing.
  321. ;; Otherwise it moves the active element to el and, if we're in
  322. ;; extended mode, extends the selection to that point.
  323. ;;
  324. ;; w -        The listbox widget.
  325. ;; el -        An integer element number.
  326.  
  327. (define (Tk:listbox-data-extend w el)
  328.   (let ((mode (tk-get w :selectmode)))
  329.     (cond 
  330.        ((string=? mode "extended")    (w 'activate el)
  331.                     (w 'see el)
  332.                     (if (w 'selection 'includes 'anchor)
  333.                         (Tk:listbox-motion w el)))
  334.        ((string=? mode "multiple")    (w 'activate $el)
  335.                     (w 'see el)))))
  336.  
  337. ;; Tk:listbox-cancel
  338. ;;
  339. ;; This procedure is invoked to cancel an extended selection in
  340. ;; progress.  If there is an extended selection in progress, it
  341. ;; restores all of the items between the active one and the anchor
  342. ;; to their previous selection state.
  343. ;;
  344. ;; w -        The listbox widget.
  345.  
  346. (define (Tk:listbox-cancel w)
  347.   (when (equal? (tk-get w :selectmode) "extended")
  348.      (let ((first (w 'index 'anchor))
  349.        (last  tk::listbox-prev))
  350.        (when (> first last)
  351.       (let ((tmp first))
  352.         (set! first last)
  353.         (set! last tmp)))
  354.        (w 'selection 'clear first last)
  355.        (while (<= first last)
  356.       (if (member first tk::listbox-selection)
  357.           (w 'selection 'set first))
  358.       (set! first (+ first 1))))))
  359.  
  360. ;; Tk:listbox-select-all
  361. ;;
  362. ;; This procedure is invoked to handle the "select all" operation.
  363. ;; For single and browse mode, it just selects the active element.
  364. ;; Otherwise it selects everything in the widget.
  365. ;;
  366. ;; w -        The listbox widget.
  367.  
  368. (define (Tk:listbox-select-all w)
  369.   (let ((mode (tk-get w :selectmode)))
  370.     (if (or (equal? mode "single") (equal? mode "browse"))
  371.     (begin
  372.       (w 'selection 'clear 0 'end)
  373.       (w 'selection 'set 'active))
  374.     (w 'selection 'set 0 'end))))
  375.  
  376. )
  377.