;;;; ;;;; Scale bindings and procs ;;;; ;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; 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 dragging #f) (define init-value #f) (define delta-x 0) (define delta-y 0) ;;------------------------------------------------------------------------- ;; The code below creates the default class bindings for entries. ;;------------------------------------------------------------------------- ;; Standard Motif bindings: (define-binding "Scale" "" (|W| x y) (when *tk-strict-Motif* (set! Tk::active-bg (tk-get |W| :activebackground)) (tk-set! |W| :activebackground (tk-get |W| :background))) (Tk:scale-activate |W| x y)) (define-binding "Scale" "" (|W| x y) (Tk:scale-activate |W| x y)) (define-binding "Scale" "" (|W|) (if *tk-strict-Motif* (tk-set! |W| :activebackground Tk::active-bg)) (if (equal? (tk-get |W| :state) "active") (tk-set! |W| :state "normal"))) (define-binding "Scale" "<1>" (|W| x y) (Tk:scale-button-down |W| x y)) (define-binding "Scale" "" (|W| x y) (Tk:scale-drag |W| x y)) (define-binding "Scale" "" () "") (define-binding "Scale" "" () "") (define-binding "Scale" "" (|W| x y) (Tk:cancel-repeat) (Tk:scale-end-drag |W|) (Tk:scale-activate |W| x y)) (define-binding "Scale" "<2>" (|W| x y) (Tk:scale-button-2-down |W| x y)) (define-binding "Scale" "" (|W| x y) (Tk:scale-drag |W| x y)) (define-binding "Scale" "" () "") (define-binding "Scale" "" () "") (define-binding "Scale" "" (|W| x y) (Tk:cancel-repeat) (Tk:scale-end-drag |W|) (Tk:scale-activate |W| x y)) (define-binding "Scale" "" (|W| x y) (Tk:scale-control-press |W| x y)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'up 'little 'no-repeat)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'down 'little 'no-repeat)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'up 'little 'no-repeat)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'down 'little 'no-repeat)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'up 'big 'no-repeat)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'down 'big 'no-repeat)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'up 'big 'no-repeat)) (define-binding "Scale" "" (|W|) (Tk:scale-increment |W| 'down 'big 'no-repeat)) (define-binding "Scale" "" (|W|) (|W| 'set (tk-get |W| :from))) (define-binding "Scale" "" (|W|) (|W| 'set (tk-get |W| :to))) ;; Tk:scale-activate -- ;; This procedure is invoked to check a given x-y position in the ;; scale and activate the slider if the x-y position falls within ;; the slider. ;; ;; w - The scale widget. ;; x, y - Mouse coordinates. (define (Tk:scale-activate w x y) (unless (equal? (tk-get w :state) "disabled") (tk-set! w :state (if (equal? (w 'identify x y) "slider") "active" "normal")))) ;; Tk:scale-button-down -- ;; This procedure is invoked when a button is pressed in a scale. It ;; takes different actions depending on where the button was pressed. ;; ;; w - The scale widget. ;; x, y - Mouse coordinates of button press. (define (Tk:scale-button-down w x y) (let ((el (w 'identify x y))) (set! dragging #f) (cond ((string=? el "trough1") (Tk:scale-increment w 'up 'little 'initial)) ((string=? el "trough2") (Tk:scale-Increment w 'down 'little 'initial)) ((string=? el "slider") (set! dragging #t) (set! init-value (w 'get)) (let ((coords (w 'coords))) (set! delta-x (- x (car coords))) (set! delta-y (- y (cadr coords))) (w 'configure :sliderrelief "sunken")))))) ;; Tk:scale-drag -- ;; This procedure is called when the mouse is dragged with ;; mouse button 1 down. If the drag started inside the slider ;; (i.e. the scale is active) then the scale's value is adjusted ;; to reflect the mouse's position. ;; ;; w - The scale widget. ;; x, y - Mouse coordinates. (define (Tk:scale-drag w x y) (when dragging (w 'set (w 'get (- x delta-x) (- y delta-y))))) ;; Tk:scale-end-drag -- ;; This procedure is called to end an interactive drag of the ;; slider. It just marks the drag as over. (define (Tk:scale-end-drag w) (set! dragging #f) (w 'configure :sliderrelief "raised")) ;; Tk:scale-increment -- ;; This procedure is invoked to increment the value of a scale and ;; to set up auto-repeating of the action if that is desired. The ;; way the value is incremented depends on the "dir" and "big" ;; arguments. ;; ;; w - The scale widget. ;; dir - "up" means move value towards -from, "down" means ;; move towards -to. ;; size - Size of increments: "big" or "little". ;; repeat - Whether and how to auto-repeat the action: "no-repeat" ;; 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:scale-increment w dir size repeat) (when (winfo 'exists w) (let ((inc 0) (from (tk-get w :from)) (to (tk-get w :to))) (if (eqv? size 'big) (begin (set! inc (tk-get w :bigincrement)) (if (= inc 0) (set! inc (abs (/ (- to from) #i10)))) (set! inc (max (tk-get w :resolution) inc))) (set! inc (tk-get w :resolution))) (if (or (and (> from to) (eqv? dir 'down)) (and (<= from to) (eqv? dir 'up))) (set! inc (- inc))) (w 'set (+ (w 'get) inc)) (case repeat ((again) (set! tk::after-id (after (tk-get w :repeatinterval) (lambda () (Tk:scale-increment w dir size 'again))))) ((initial) (let ((delay (tk-get w :repeatdelay))) (if (> delay 0) (set! Tk::after-id (after delay (lambda () (Tk:scale-increment w dir size 'again))))))))))) ;; Tk:scale-control-press -- ;; This procedure handles button presses that are made with the Control ;; key down. Depending on the mouse position, it adjusts the scale ;; value to one end of the range or the other. ;; ;; Arguments: ;; w - The scale widget. ;; x, y - Mouse coordinates where the button was pressed. (define (Tk:scale-control-press w x y) (let ((el (w 'identify x y))) (cond ((string=? el "trough1") (w 'set (tk-get w :from))) ((string=? el "trough2") (w 'set (tk-get w :to)))))) ;; This procedure is invoked when button 2 is pressed over a scale. ;; It sets the value to correspond to the mouse position and starts ;; a slider drag. ;; ;; Arguments: ;; w - The scrollbar widget. ;; x, y - Mouse coordinates within the widget. (define (Tk:scale-button-2-down w x y) (unless (equal? (tk-get w :state) "disabled") (tk-set! w :state "active") (w 'set (w 'get x y)) (set! dragging #t) (set! init-value (w 'get)) (set! delta-x 0) (set! delta-y 0))) ;; enf of let )