;;; sliders.el --- graphical sliders for XEmacs. (c) 1997

;; Author:     Jens Lautenbacher <jens@tellux.de>
;; Keywords:   utilities
;; Version:    0.3

;; This file is not (yet?) part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;; Code:
;;
;;; Compatibility.

;; There is a bug in XEmacs extents where the order of extent glyphs
;; can get messed up when you have zero-length extents.  SXEmacs has
;; this fixed, but because it is such a long-standing bug code like
;; this was written against the "buggy" extent api and so "breaks"
;; when used with non-buggy extents.  Hence this compatibility snippet
;; here.  --SY.
(eval-and-compile
  (if (featurep 'sxemacs)
      (progn
	(fset #'slider-set-glyph #'set-extent-end-glyph)
	(fset #'slider-glyph #'extent-end-glyph))
    (fset #'slider-set-glyph #'set-extent-begin-glyph)
    (fset #'slider-glyph #'extent-begin-glyph)))

;;; First of all we'll define the needed variables.


(defconst slider-bar-elem-width 4)

(defvar slider-pixmap-dir (locate-data-directory "slider"))

(defvar slider-bar-keymap nil) 
(if slider-bar-keymap ()
  (setq slider-bar-keymap (make-keymap 'slider-bar-keymap))
  (suppress-keymap slider-bar-keymap)
  (define-key slider-bar-keymap "+" 'slider-one-right-this)
  (define-key slider-bar-keymap "-" 'slider-one-left-this)
  (define-key slider-bar-keymap 'button1 'slider-activate-arrow-or-bar))

(defvar slider-knob-keymap nil) 
(if slider-knob-keymap ()
  (setq slider-knob-keymap (make-keymap 'slider-knob-keymap))
  (suppress-keymap slider-knob-keymap)
  (define-key slider-knob-keymap 'button1 'slider-activate-knob))


;;; Add the correct path here!
(defvar slider-left-up    (make-glyph (concat slider-pixmap-dir "left-up.xpm")))
(defvar slider-left-down  (make-glyph (concat slider-pixmap-dir "left-down.xpm")))
(defvar slider-right-up   (make-glyph (concat slider-pixmap-dir "right-up.xpm")))
(defvar slider-right-down (make-glyph (concat slider-pixmap-dir "right-down.xpm")))
(defvar slider-element    (make-glyph (concat slider-pixmap-dir "bar.xpm")))
(defvar slider-knob       (make-glyph (concat slider-pixmap-dir "knob.xpm")))

(defun slider-new (visible-size min-val max-val	stepsize
				&optional callback callback-data read-only)
  (let* ((number-of-bars (/ visible-size slider-bar-elem-width))
	 (left-vector (make-vector (1+ number-of-bars) nil))
	 (right-vector (make-vector (1+ number-of-bars) nil))
	 knob slider tmp)
    ;; creating the extents....
    ;; the left part: left-vector[0] is the left arrow.
    (insert-string "  ")
    (goto-char (1- (point)))

    (setq slider (make-extent (point) (point)))
    (set-extent-property slider 'keymap slider-bar-keymap)
    (set-extent-property slider 'read-only read-only)
    (set-extent-property slider 'start-open t)
    (set-extent-property slider 'slider t)
    (set-extent-property slider	'slider-stepsize stepsize)
    (set-extent-property slider	'slider-left left-vector)
    (set-extent-property slider	'slider-right right-vector)
    (set-extent-property slider	'slider-max max-val)
    (set-extent-property slider	'slider-min min-val)
    (set-extent-property slider	'slider-callback callback)
    (set-extent-property slider 'slider-data callback-data)
    (set-extent-property slider	'slider-value min-val)
    (set-extent-property slider	'slider-value-int 0)
    (set-extent-property slider	'slider-number-of-bars number-of-bars)
    (set-extent-face slider 'bold)
    (setq tmp (make-extent (point) (point)))
    (aset left-vector 0 tmp)
    (set-extent-keymap   tmp slider-bar-keymap)
    (set-extent-property tmp 'slider-action 'slider-one-left)
    (set-extent-property tmp 'slider-down slider-left-down)
    ;; from 1 to number-of-bars: the slider bar to the left.
    (let ((count 1))
      (while (<= count number-of-bars) ; <= to get length + 1 elements
	(setq tmp (make-extent (point) (point)))
	(aset left-vector count tmp)
	(set-extent-keymap tmp slider-bar-keymap)
	(set-extent-property tmp 'slider-action 'slider-left-action)
	(setq count (1+ count))))
    ;; now the sliders "knob"
    (setq knob (make-extent (point) (point)))
    (set-extent-property knob 'slider-this slider)
    ;; the right part:
    ;; from 0 to (1- number-of-bars): the slider bar to the right
    (let ((count 0))
      (while (< count number-of-bars) ; < to get length elements
	(setq tmp (make-extent (point) (point)))
	(aset right-vector count tmp)
	(set-extent-keymap tmp slider-bar-keymap)
	(set-extent-property tmp 'slider-action 'slider-right-action)
	(setq count (1+ count))))
    ;; the right arrow.
    (aset right-vector number-of-bars
	  (setq tmp (make-extent (point) (point))))
    (set-extent-keymap   tmp slider-bar-keymap)
    (set-extent-property tmp 'slider-action 'slider-one-right)
    (set-extent-property tmp 'slider-down slider-right-down)
    ;; initializing the display:
    ;; left arrow glyph:
    (slider-set-glyph (aref left-vector 0) slider-left-up)
    ;; the left bar is invisible, so make the knob glyph:
    (slider-set-glyph knob slider-knob)
    ;; the right part of the bar is fully visible
    (let ((count 0))
      (while (< count number-of-bars)
	(slider-set-glyph (aref right-vector count) slider-element)
	(setq count (1+ count))))
    ;; the right arrow glyph
    (slider-set-glyph (aref right-vector number-of-bars) slider-right-up)
    ;; put some needed information into the knob's properties.
    (set-extent-property knob 'slider-action 'slider-drag-knob)
    (set-extent-keymap knob slider-knob-keymap)
    ;; loop oer the whole left and right side and fill in needed properties
    (let ((count 0))
      (while (<= count number-of-bars)
	(set-extent-property (setq tmp (aref right-vector count))
			     'slider-this slider)
	(set-extent-property tmp 'slider-bar-number (+ 1 count))
	(set-extent-property (setq tmp (aref left-vector count))
			     'slider-this slider)
	(set-extent-property tmp 'slider-bar-number count)
	(setq count (1+ count))))
    ;; return the knob.
    (goto-char (1+ (point)))
    slider))

(defun slider-set (slider abs-value)
  (let* ((max (extent-property slider 'slider-max))
	 (min (extent-property slider 'slider-min))
	 (func (extent-property slider 'slider-callback))
	 (length (extent-property slider 'slider-number-of-bars))
	 (step (floor (* (/ (float length) (float (- max min)))
			 (- abs-value min)))))
    (if (not (sliderp slider))
	(error "No slider: %s" slider))
    (if (or (< abs-value min) (> abs-value max))
	(error "Value %s not in allowed range [%s...%s]"
	       abs-value min max)
      (let ((count 1))
	(while (<= count step)
	  (slider-set-glyph
	   (aref (extent-property slider 'slider-left)
		 count) 
	   slider-element)
	  (setq count (1+ count)))
	(while (<= count length)
	  (slider-set-glyph
	   (aref (extent-property slider 'slider-left)
		 count)
	   nil)
	  (setq count (1+ count))))
      (let ((count 0))
	(while (< count step)
	  (slider-set-glyph
	   (aref (extent-property slider 'slider-right)
		 count) 
	   nil)
	  (setq count (1+ count)))
	(while (< count length)
	  (slider-set-glyph
	   (aref (extent-property slider 'slider-right)
		 count) 
	   slider-element)
	  (setq count (1+ count))))
      (set-extent-property slider 'slider-value abs-value)
      (set-extent-property slider 'slider-value-int step)
      (if func (funcall func slider (extent-property slider 'slider-data)))
      abs-value)))

(defun slider-set-data (slider data)
  (cond ((sliderp slider)
	 (set-extent-property slider 'slider-data data))
	(t
	 (error "No slider: %s" slider))))

(defun slider-get (slider)
  (cond ((sliderp slider)
	 (extent-property slider 'slider-value))
	(t
	 (error "No slider: %s" slider))))

(defun slider-destroy (slider)
  (let ((start (extent-start-position slider))
	(end   (extent-end-position slider)))
    (cond ((sliderp slider)
	   (set-extent-property slider 'read-only nil)
	   (delete-region start end))
	  (t
	   (error "No slider: %s" slider)))))


;;; Internal functions below...

(defun sliderp (obj)
  (if (extentp obj)
      (extent-property obj 'slider)))

(defun slider-one-right (slider)
  (let ((val (slider-get slider))
	(max (extent-property slider 'slider-max)))
    (if (< val max) (slider-set slider (1+ val)))))

(defun slider-one-left (slider)
  (let ((val (slider-get slider))
	(min (extent-property slider 'slider-min)))
    (if (> val min) (slider-set slider (1- val)))))

(defun slider-right-action (slider)
  (let ((val (slider-get slider))
	(stepsize (extent-property slider 'slider-stepsize))
	(max (extent-property slider 'slider-max)))
    (if (< val max) (slider-set slider (min max (+ stepsize val))))))
  
(defun slider-left-action (slider)
  (let ((val (slider-get slider))
	(stepsize (extent-property slider 'slider-stepsize))
	(min (extent-property slider 'slider-min)))
    (if (> val min) (slider-set slider (max min (- val stepsize))))))

(defun slider-one-right-this ()
  (interactive)
  (let ((slider (extent-at (point) (current-buffer) 'slider nil 'at))) 
    (slider-one-right slider)
    (sit-for 0)))

(defun slider-one-left-this ()
  (interactive)
  (let ((slider (extent-at (point) (current-buffer) 'slider nil 'at))) 
    (slider-one-left slider)
    (sit-for 0)))

(defun slider-activate-arrow-or-bar (event)
  (interactive "e")
  (let* ((extent (event-glyph-extent event))
	 (mouse-down t)
	 (action (extent-property extent 'slider-action))
	 up-glyph down-glyph)
    ;; make the glyph look pressed
    (cond  ((setq down-glyph (extent-property extent 'slider-down))
	    (setq up-glyph (slider-glyph extent))
	    (slider-set-glyph extent down-glyph)))
    (while mouse-down
      (if (input-pending-p)
	  (setq event (next-event event))
	(if action (funcall action (extent-property extent 'slider-this)))
	(sit-for 0))
      (if (button-release-event-p event)
	  (setq mouse-down nil)))
    ;; make the glyph look released
    (if down-glyph (slider-set-glyph extent up-glyph))))

(defun slider-activate-knob (event)
  (interactive "e")
  (let* ((extent (event-glyph-extent event))
	 (X (event-x-pixel event))
	 (bar (extent-property (extent-property extent 'slider-this)
			       'slider-value-int))
	 (max-bar (extent-property (extent-property extent 'slider-this)
			       'slider-number-of-bars))
	 (mouse-down t)
	 (action (extent-property extent 'slider-action))
	 X-new X-diff new-bar)
    (while mouse-down
      (setq event (next-event event))
      (cond ((mouse-event-p event)
	     (setq X-new (event-x-pixel event))
	     (setq X-diff (- X-new X))
	     (setq new-bar (max (min (+ bar (/ X-diff slider-bar-elem-width))
				     (1+ max-bar)) 0))
	     (cond ((not (= bar new-bar))
		    (funcall action (extent-property extent 'slider-this)
			     new-bar)
		    (setq X (+ X (* slider-bar-elem-width (- new-bar bar))))
		    (setq bar new-bar)))
	     (if (button-release-event-p event)
		 (setq mouse-down nil)))))))

(defun slider-drag-knob (extent bar)
  (let* ((range (- (extent-property extent 'slider-max)
		   (extent-property extent 'slider-min)))
	 (offset (extent-property extent 'slider-min))
	 (slider-length (length (extent-property extent 'slider-left)))
	 (value (floor (* bar (/ (float range) (float slider-length))))))
    (slider-set extent (+ offset value))))


(provide 'slider)