cgit.sxemacs.org Git - packages/blob - xemacs-packages/slider/slider.el

   1 ;;; sliders.el --- graphical sliders for XEmacs. (c) 1997
   2
   3 ;; Author:     Jens Lautenbacher <jens@tellux.de>
   4 ;; Keywords:   utilities
   5 ;; Version:    0.3
   6
   7 ;; This file is not (yet?) part of XEmacs.
   8
   9 ;; XEmacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; XEmacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with XEmacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;; Code:
  25 ;;
  26 ;;; Compatibility.
  27
  28 ;; There is a bug in XEmacs extents where the order of extent glyphs
  29 ;; can get messed up when you have zero-length extents.  SXEmacs has
  30 ;; this fixed, but because it is such a long-standing bug code like
  31 ;; this was written against the "buggy" extent api and so "breaks"
  32 ;; when used with non-buggy extents.  Hence this compatibility snippet
  33 ;; here.  --SY.
  34 (eval-and-compile
  35   (if (featurep 'sxemacs)
  36       (progn
  37         (fset #'slider-set-glyph #'set-extent-end-glyph)
  38         (fset #'slider-glyph #'extent-end-glyph))
  39     (fset #'slider-set-glyph #'set-extent-begin-glyph)
  40     (fset #'slider-glyph #'extent-begin-glyph)))
  41
  42 ;;; First of all we'll define the needed variables.
  43
  44
  45 (defconst slider-bar-elem-width 4)
  46
  47 (defvar slider-pixmap-dir (locate-data-directory "slider"))
  48
  49 (defvar slider-bar-keymap nil)
  50 (if slider-bar-keymap ()
  51   (setq slider-bar-keymap (make-keymap 'slider-bar-keymap))
  52   (suppress-keymap slider-bar-keymap)
  53   (define-key slider-bar-keymap "+" 'slider-one-right-this)
  54   (define-key slider-bar-keymap "-" 'slider-one-left-this)
  55   (define-key slider-bar-keymap 'button1 'slider-activate-arrow-or-bar))
  56
  57 (defvar slider-knob-keymap nil)
  58 (if slider-knob-keymap ()
  59   (setq slider-knob-keymap (make-keymap 'slider-knob-keymap))
  60   (suppress-keymap slider-knob-keymap)
  61   (define-key slider-knob-keymap 'button1 'slider-activate-knob))
  62
  63
  64 ;;; Add the correct path here!
  65 (defvar slider-left-up    (make-glyph (concat slider-pixmap-dir "left-up.xpm")))
  66 (defvar slider-left-down  (make-glyph (concat slider-pixmap-dir "left-down.xpm")))
  67 (defvar slider-right-up   (make-glyph (concat slider-pixmap-dir "right-up.xpm")))
  68 (defvar slider-right-down (make-glyph (concat slider-pixmap-dir "right-down.xpm")))
  69 (defvar slider-element    (make-glyph (concat slider-pixmap-dir "bar.xpm")))
  70 (defvar slider-knob       (make-glyph (concat slider-pixmap-dir "knob.xpm")))
  71
  72 (defun slider-new (visible-size min-val max-val stepsize
  73                                 &optional callback callback-data read-only)
  74   (let* ((number-of-bars (/ visible-size slider-bar-elem-width))
  75          (left-vector (make-vector (1+ number-of-bars) nil))
  76          (right-vector (make-vector (1+ number-of-bars) nil))
  77          knob slider tmp)
  78     ;; creating the extents....
  79     ;; the left part: left-vector[0] is the left arrow.
  80     (insert-string "  ")
  81     (goto-char (1- (point)))
  82
  83     (setq slider (make-extent (point) (point)))
  84     (set-extent-property slider 'keymap slider-bar-keymap)
  85     (set-extent-property slider 'read-only read-only)
  86     (set-extent-property slider 'start-open t)
  87     (set-extent-property slider 'slider t)
  88     (set-extent-property slider 'slider-stepsize stepsize)
  89     (set-extent-property slider 'slider-left left-vector)
  90     (set-extent-property slider 'slider-right right-vector)
  91     (set-extent-property slider 'slider-max max-val)
  92     (set-extent-property slider 'slider-min min-val)
  93     (set-extent-property slider 'slider-callback callback)
  94     (set-extent-property slider 'slider-data callback-data)
  95     (set-extent-property slider 'slider-value min-val)
  96     (set-extent-property slider 'slider-value-int 0)
  97     (set-extent-property slider 'slider-number-of-bars number-of-bars)
  98     (set-extent-face slider 'bold)
  99     (setq tmp (make-extent (point) (point)))
 100     (aset left-vector 0 tmp)
 101     (set-extent-keymap   tmp slider-bar-keymap)
 102     (set-extent-property tmp 'slider-action 'slider-one-left)
 103     (set-extent-property tmp 'slider-down slider-left-down)
 104     ;; from 1 to number-of-bars: the slider bar to the left.
 105     (let ((count 1))
 106       (while (<= count number-of-bars) ; <= to get length + 1 elements
 107         (setq tmp (make-extent (point) (point)))
 108         (aset left-vector count tmp)
 109         (set-extent-keymap tmp slider-bar-keymap)
 110         (set-extent-property tmp 'slider-action 'slider-left-action)
 111         (setq count (1+ count))))
 112     ;; now the sliders "knob"
 113     (setq knob (make-extent (point) (point)))
 114     (set-extent-property knob 'slider-this slider)
 115     ;; the right part:
 116     ;; from 0 to (1- number-of-bars): the slider bar to the right
 117     (let ((count 0))
 118       (while (< count number-of-bars) ; < to get length elements
 119         (setq tmp (make-extent (point) (point)))
 120         (aset right-vector count tmp)
 121         (set-extent-keymap tmp slider-bar-keymap)
 122         (set-extent-property tmp 'slider-action 'slider-right-action)
 123         (setq count (1+ count))))
 124     ;; the right arrow.
 125     (aset right-vector number-of-bars
 126           (setq tmp (make-extent (point) (point))))
 127     (set-extent-keymap   tmp slider-bar-keymap)
 128     (set-extent-property tmp 'slider-action 'slider-one-right)
 129     (set-extent-property tmp 'slider-down slider-right-down)
 130     ;; initializing the display:
 131     ;; left arrow glyph:
 132     (slider-set-glyph (aref left-vector 0) slider-left-up)
 133     ;; the left bar is invisible, so make the knob glyph:
 134     (slider-set-glyph knob slider-knob)
 135     ;; the right part of the bar is fully visible
 136     (let ((count 0))
 137       (while (< count number-of-bars)
 138         (slider-set-glyph (aref right-vector count) slider-element)
 139         (setq count (1+ count))))
 140     ;; the right arrow glyph
 141     (slider-set-glyph (aref right-vector number-of-bars) slider-right-up)
 142     ;; put some needed information into the knob's properties.
 143     (set-extent-property knob 'slider-action 'slider-drag-knob)
 144     (set-extent-keymap knob slider-knob-keymap)
 145     ;; loop oer the whole left and right side and fill in needed properties
 146     (let ((count 0))
 147       (while (<= count number-of-bars)
 148         (set-extent-property (setq tmp (aref right-vector count))
 149                              'slider-this slider)
 150         (set-extent-property tmp 'slider-bar-number (+ 1 count))
 151         (set-extent-property (setq tmp (aref left-vector count))
 152                              'slider-this slider)
 153         (set-extent-property tmp 'slider-bar-number count)
 154         (setq count (1+ count))))
 155     ;; return the knob.
 156     (goto-char (1+ (point)))
 157     slider))
 158
 159 (defun slider-set (slider abs-value)
 160   (let* ((max (extent-property slider 'slider-max))
 161          (min (extent-property slider 'slider-min))
 162          (func (extent-property slider 'slider-callback))
 163          (length (extent-property slider 'slider-number-of-bars))
 164          (step (floor (* (/ (float length) (float (- max min)))
 165                          (- abs-value min)))))
 166     (if (not (sliderp slider))
 167         (error "No slider: %s" slider))
 168     (if (or (< abs-value min) (> abs-value max))
 169         (error "Value %s not in allowed range [%s...%s]"
 170                abs-value min max)
 171       (let ((count 1))
 172         (while (<= count step)
 173           (slider-set-glyph
 174            (aref (extent-property slider 'slider-left)
 175                  count)
 176            slider-element)
 177           (setq count (1+ count)))
 178         (while (<= count length)
 179           (slider-set-glyph
 180            (aref (extent-property slider 'slider-left)
 181                  count)
 182            nil)
 183           (setq count (1+ count))))
 184       (let ((count 0))
 185         (while (< count step)
 186           (slider-set-glyph
 187            (aref (extent-property slider 'slider-right)
 188                  count)
 189            nil)
 190           (setq count (1+ count)))
 191         (while (< count length)
 192           (slider-set-glyph
 193            (aref (extent-property slider 'slider-right)
 194                  count)
 195            slider-element)
 196           (setq count (1+ count))))
 197       (set-extent-property slider 'slider-value abs-value)
 198       (set-extent-property slider 'slider-value-int step)
 199       (if func (funcall func slider (extent-property slider 'slider-data)))
 200       abs-value)))
 201
 202 (defun slider-set-data (slider data)
 203   (cond ((sliderp slider)
 204          (set-extent-property slider 'slider-data data))
 205         (t
 206          (error "No slider: %s" slider))))
 207
 208 (defun slider-get (slider)
 209   (cond ((sliderp slider)
 210          (extent-property slider 'slider-value))
 211         (t
 212          (error "No slider: %s" slider))))
 213
 214 (defun slider-destroy (slider)
 215   (let ((start (extent-start-position slider))
 216         (end   (extent-end-position slider)))
 217     (cond ((sliderp slider)
 218            (set-extent-property slider 'read-only nil)
 219            (delete-region start end))
 220           (t
 221            (error "No slider: %s" slider)))))
 222
 223
 224 ;;; Internal functions below...
 225
 226 (defun sliderp (obj)
 227   (if (extentp obj)
 228       (extent-property obj 'slider)))
 229
 230 (defun slider-one-right (slider)
 231   (let ((val (slider-get slider))
 232         (max (extent-property slider 'slider-max)))
 233     (if (< val max) (slider-set slider (1+ val)))))
 234
 235 (defun slider-one-left (slider)
 236   (let ((val (slider-get slider))
 237         (min (extent-property slider 'slider-min)))
 238     (if (> val min) (slider-set slider (1- val)))))
 239
 240 (defun slider-right-action (slider)
 241   (let ((val (slider-get slider))
 242         (stepsize (extent-property slider 'slider-stepsize))
 243         (max (extent-property slider 'slider-max)))
 244     (if (< val max) (slider-set slider (min max (+ stepsize val))))))
 245
 246 (defun slider-left-action (slider)
 247   (let ((val (slider-get slider))
 248         (stepsize (extent-property slider 'slider-stepsize))
 249         (min (extent-property slider 'slider-min)))
 250     (if (> val min) (slider-set slider (max min (- val stepsize))))))
 251
 252 (defun slider-one-right-this ()
 253   (interactive)
 254   (let ((slider (extent-at (point) (current-buffer) 'slider nil 'at)))
 255     (slider-one-right slider)
 256     (sit-for 0)))
 257
 258 (defun slider-one-left-this ()
 259   (interactive)
 260   (let ((slider (extent-at (point) (current-buffer) 'slider nil 'at)))
 261     (slider-one-left slider)
 262     (sit-for 0)))
 263
 264 (defun slider-activate-arrow-or-bar (event)
 265   (interactive "e")
 266   (let* ((extent (event-glyph-extent event))
 267          (mouse-down t)
 268          (action (extent-property extent 'slider-action))
 269          up-glyph down-glyph)
 270     ;; make the glyph look pressed
 271     (cond  ((setq down-glyph (extent-property extent 'slider-down))
 272             (setq up-glyph (slider-glyph extent))
 273             (slider-set-glyph extent down-glyph)))
 274     (while mouse-down
 275       (if (input-pending-p)
 276           (setq event (next-event event))
 277         (if action (funcall action (extent-property extent 'slider-this)))
 278         (sit-for 0))
 279       (if (button-release-event-p event)
 280           (setq mouse-down nil)))
 281     ;; make the glyph look released
 282     (if down-glyph (slider-set-glyph extent up-glyph))))
 283
 284 (defun slider-activate-knob (event)
 285   (interactive "e")
 286   (let* ((extent (event-glyph-extent event))
 287          (X (event-x-pixel event))
 288          (bar (extent-property (extent-property extent 'slider-this)
 289                                'slider-value-int))
 290          (max-bar (extent-property (extent-property extent 'slider-this)
 291                                'slider-number-of-bars))
 292          (mouse-down t)
 293          (action (extent-property extent 'slider-action))
 294          X-new X-diff new-bar)
 295     (while mouse-down
 296       (setq event (next-event event))
 297       (cond ((mouse-event-p event)
 298              (setq X-new (event-x-pixel event))
 299              (setq X-diff (- X-new X))
 300              (setq new-bar (max (min (+ bar (/ X-diff slider-bar-elem-width))
 301                                      (1+ max-bar)) 0))
 302              (cond ((not (= bar new-bar))
 303                     (funcall action (extent-property extent 'slider-this)
 304                              new-bar)
 305                     (setq X (+ X (* slider-bar-elem-width (- new-bar bar))))
 306                     (setq bar new-bar)))
 307              (if (button-release-event-p event)
 308                  (setq mouse-down nil)))))))
 309
 310 (defun slider-drag-knob (extent bar)
 311   (let* ((range (- (extent-property extent 'slider-max)
 312                    (extent-property extent 'slider-min)))
 313          (offset (extent-property extent 'slider-min))
 314          (slider-length (length (extent-property extent 'slider-left)))
 315          (value (floor (* bar (/ (float range) (float slider-length))))))
 316     (slider-set extent (+ offset value))))
 317
 318
 319 (provide 'slider)