;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: 
;;;                       Module: 
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/sliders.lisp
;;; File Creation Date: 02/11/91 12:44:43
;;; Last Modification Time: 07/24/92 16:59:43
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 02/11/1991 (Matthias) always *move-window-with-mouse-type* = :server
;;;                       new hooks: move-slider-knob-after (default:
;;;                                       move contact)
;;;                                  move-slider-knob-before (default: NOP)
;;;                                  move-slider-knob (default: move server
;;;                                       window)
;;; 02/13/1991 (Matthias) new: vanilla-layouter, beta-version                      
;;; 08/05/1991 (Matthias) integer-slider: slider-value -> compute-slider-value
;;; 07/21/1992 (Matthias) slider-knob: adjust-size? nil (new: display-width def)
;;;_____________________________________________________________________________

(in-package :xit)

;;;-----------------------------------------------------------------------------
;;;                     Vanilla layouter
;;;-----------------------------------------------------------------------------

(defclass vanilla-layouter (layouter)
  ((alignment :type (member :upper-left :upper-center :upper-right
			    :left-center :center :right-center
			    :lower-left :lower-center :lower-right)
	      :initform :upper-left
	      :accessor alignment :initarg :alignment)
   (constraint :type (member :none :x :y) :initform :none
	       :accessor constraint :initarg :constraint))
  
  (:documentation "layouter that positions its windows on top of each other
optionally leaving one coordinate untouched."))

(defmethod layout ((self vanilla-layouter) window)
  (with-slots ((parent window) alignment constraint) self
    (with-slots (x y width height border-width) window
      (let (;(parts (layouted-parts parent))
	    (origin (extent-origin parent))
	    (new-x x)
	    (new-y y))
	(unless (eq constraint :x)
	  (let* ((max-width (- (contact-width parent) (x-margins parent)))
		(total-width (contact-total-width window))
		(x-offset
	       (case alignment
		 ((:upper-left :left-center :lower-left) 0)
		 ((:upper-center :center :lower-center)
		  (floor (- max-width total-width) 2))
		 ((:upper-right :right-center :lower-right)
		  (- max-width total-width)))))
	    (setq new-x (+ (point-x origin) (x-margin parent) x-offset))))
	(unless (eq constraint :y)
	  (let* ((max-height (- (contact-height parent) (y-margins parent)))
	     (total-height (contact-total-height window))
	     (y-offset
	      (case alignment
		((:upper-left :upper-center :upper-right) 0)
		((:left-center :center :right-center)
		 (floor (- max-height total-height) 2))
		((:lower-left :lower-center :lower-right)
		 (- max-height total-height)))))
	    (setq new-y (+ (point-y origin) (y-margin parent) y-offset))))
	(values new-x new-y width height border-width)))))


(defcontact slider-knob (dispel)
  ((name :initform :knob)
   (move-immediate? :initform t :accessor move-immediate?
		    :initarg :move-immediate?)
   (adjust-size? :initform nil)
   (width :initform 50)
   (height :initform 20)
   (border-width :initform 2)
   (background :initform "white")
   (mouse-feedback :initform :none)
   (mouse-documentation :initform "Mouse-L: Move slider.")
   (reactivity :initform
	       '((:single-left-button "Move slider" 
				      (call :contact move-knob-with-mouse)
				      ;; (call :part-event)
				      )))))

(defmethod hot-spot ((self slider-knob))
  (point (floor (contact-total-width self) 2)
	 (floor (contact-total-height self) 2)))

(defmethod compute-knob-position ((self slider-knob) window-position)
  (let ((hot-spot (hot-spot self)))
    (point (+ (point-x window-position) (point-x hot-spot))
	(+ (point-y window-position) (point-y hot-spot)))))

(defmethod knob-position ((self slider-knob))
  (with-slots (x y) self
      (compute-knob-position self (point x y))))

(defmethod (setf partial-knob-position) (value (self slider-knob))
  (with-slots (parent) self
    (with-slots (orientation) parent
      (case orientation
	((:up :down)
	 (change-geometry self :y
	      (- value (point-y (hot-spot self)))))
	((:left :right)
	 (change-geometry self :x
	      (- value (point-x (hot-spot self)))))))))

(defmethod move-knob-with-mouse ((self slider-knob))
  (with-slots (parent) self
    (with-slots (orientation) parent
      (let ((verticalp (member orientation '(:up :down)))
	    (hot-spot (hot-spot self)))
	(drag-knob-with-mouse-server self
				     :mouse-offset (hot-spot self)
				     :mouse-track (part (part-of self) :track)
				     :cursor (if verticalp
						 "sb-v-double-arrow-cursor"
					       "sb-h-double-arrow-cursor")
				     :verticalp verticalp)))))

(defmethod drag-knob-with-mouse-server ((self slider-knob)
					&rest move-args
					&key mouse-track
					(mouse-offset (point 0 0))
					(cursor "hand2") verticalp)
  ;; [Juergen  Tue Nov 27 14:15:38 1990]
  ;; mouse-x and mouse-y must be lying within self
  (declare (special *white-pixel* *black-pixel* *shading-mask*))
  (with-slots (display parent x y width height border-width) self
    (let* ((x-new x)			; new pos after motion-event
	   (y-new y)			; 11/15/1990 (Matthias)
	   (mouse-x (point-x mouse-offset))
	   (mouse-y (point-y mouse-offset)))
      (move-window-before self (point x y))
      (process-all-events display)
	
      (unwind-protect
	  (ignoring-errors
	   (when (eq :success
		     (grab-pointer parent
				   '(:button-release :pointer-motion) 
				   :owner-p T
				   :confine-to (or mouse-track parent)
				   :cursor (convert self
						    cursor 
						    'cursor)
				   :time nil))
	     (event-case
		 (display :discard-p T 
		  :force-output-p t)
	       (motion-notify (x y event-window)
		   (unless (discard-but-last-motion-event self `(:button-release))
		     (multiple-value-bind (parent-x parent-y)
			 (contact-translate event-window x y parent)
		       (if verticalp
			   (setq y-new (- parent-y mouse-y))
			 (setq x-new (- parent-x mouse-x))))
					;(format t "~&Position: ~d" y-new)
					;(setf (drawable-y self) y-new)
		     (notify-changed-position self (point x-new y-new))
					  
		     nil))
	       (button-release ()
		   t))))
	(ungrab-pointer display)
	(display-force-output display))
      ;(move-window self x-new y-new)
      (move-window-after self (point x-new y-new))
      (values x-new y-new))))

(defmethod move-window-before ((self slider-knob) point)
  (move-slider-knob-before (part-of self)
			   (compute-knob-position self point))
  (let ((hotspot (hot-spot self)))
    (warp-pointer self (point-x hotspot) (point-y hotspot))))

(defmethod move-window-after ((self slider-knob) point)
  (when (move-immediate? self)
    (move-window self (point-x point) (point-y point)))
  (move-slider-knob-after (part-of self)
			  (compute-knob-position self point)))

(defmethod notify-changed-position ((self slider-knob) window-position)
  (when (move-immediate? self)
    (setf (drawable-x self) (point-x window-position))
    (setf (drawable-y self) (point-y window-position)))
  (move-slider-knob (part-of self) (compute-knob-position self window-position)))
  


(defcontact slider-track (dispel)
  ((name :initform :track)
   (background :initform "black")
   (width :initform 1)
   (height :initform 1)
   (border-width :initform 2)))

(defmethod initialize-instance :after ((self slider-track) &rest init-list)
  (declare (ignore init-list))
  (with-slots (x y height  parent ) self
    ;CCC(setf x (floor (- (contact-width parent)
	;			(contact-total-width self)) 2))
    ;(setf y 20)
    ;(setf height (- (contact-height parent) 40))
	      ))

(defmethod partial-track-size ((self slider-track))
  (with-slots (y x parent) self
    (with-slots (orientation) parent
      (case orientation
	((:right :left)
	 (values x (1- (+ x (contact-total-width self)))))
	((:up :down)
	 (values y (1- (+ y (contact-total-height self))))
	  )))))

;;;-----------------------------------------------------------------------------
;;;                     Slider layouter
;;;-----------------------------------------------------------------------------

(defclass slider-layouter (layouter)
  ())

(defmethod layout ((self slider-layouter) (knob slider-knob))
  (with-slots ((parent window) alignment constraint) self
    (with-slots (orientation) parent
      (with-slots (x y width height border-width) knob
	(let ((verticalp (member orientation '(:up :down)))
	      (origin (extent-origin parent))
	      (new-x x)
	      (new-y y)
	      (new-width width)
	      (new-height height))
	  (cond (verticalp
		 (setq new-x (+ (point-x origin) (x-margin parent)))
		 (setq new-width (max 1 (- (contact-width parent) border-width border-width))
		 ))
		(t
		(setq new-y (+ (point-y origin) (y-margin parent)))
		(setq new-height (max 1 (- (contact-height parent) border-width border-width
		)))))
	  (values new-x new-y new-width new-height border-width))))))

(defmethod layout ((self slider-layouter) (track slider-track))
  (with-slots ((parent window) alignment constraint) self
    (with-slots (orientation) parent
      (with-slots (x y width height border-width) track
	(let* ((verticalp (member orientation '(:up :down)))
	       (knob (part parent :knob))
	      (origin (extent-origin parent))
	      (new-x x)
	      (new-y y)
	      (new-width width)
	      (new-height height)
	      (inside-border (+ 1 (if verticalp (point-y (hot-spot knob))
				   (point-x (hot-spot knob))))))
	  (cond (verticalp
		 (setq new-y (+ 1 (point-y (hot-spot knob))))
		 (setq new-height (max (- (contact-height parent)
					  (* 2 (+ inside-border
						   border-width))
					  1)
				       1))
		 (setq new-x (+ (point-x origin) (x-margin parent)
				(floor (- (- (contact-width parent)
					     (x-margins parent))
					  (contact-total-width track))
				       2)))
		 (setq new-width 1)
		 )
		(t
		 (setq new-x (+ 1 (point-x (hot-spot knob))))
		 (setq new-width (max (- (contact-width parent)
					  (* 2 (+ inside-border
						   border-width))
					  1)
				       1))
		 (setq new-y (+ (point-y origin) (y-margin parent)
				(floor (- (- (contact-height parent) (y-margins parent))
					  (contact-total-height track))
				       2)))
		 (setq new-height 1)
		 )
		)
	  (values new-x new-y new-width new-height border-width))))))

;;;__________________________________
;;;
;;; Slider
;;;_________________________________

(defcontact slider (intel)
  ((name :initform :slider)
   (layouter :initform '(slider-layouter))
   (adjust-size? :initform nil)
   (position :initarg :position :initform 1/2)
   (orientation :initform :up :type (member :up :right) :initarg :orientation)
   (move-action :initform nil :initarg :move-action)
   )
  (:resources
   (width :initform 60)
   (height :initform 160)
   (border-width :initform 0)
   (inside-border :initform 0)))

(defmethod initialize-instance :after ((self slider) &rest init-list
				       &key knob-part track-part)
  (declare (ignore init-list))
  (with-slots (position) self
    (apply #'add-part self
	       :class 'slider-track
	       (append track-part '(:border "black")))
    (apply #'add-part self
	       :class 'slider-knob
	       (append knob-part '(:cursor "hand2")))
    (setf (relative-slider-position self) position)))

(defmethod change-layout :around ((self slider) &optional newly-managed)
  (let ((last-position (relative-slider-position self)))
    (prog1 (call-next-method)
      (setf (relative-slider-position self) last-position))))

(defmethod compute-relative-slider-position ((self slider) knob-position)
  (with-slots (orientation) self
    (let ((verticalp (member orientation '(:up :down))))
      (multiple-value-bind (max-pix min-pix)
	    (partial-track-size (part self :track))
	   (let ((rational
		  (/ (- (if verticalp
			  (point-y knob-position)
			(point-x knob-position))
		      min-pix)
		   (- max-pix min-pix))))
	     (case orientation
	       ((:down :right) (- 1 rational))
	       (otherwise rational)))))))

(defmethod relative-slider-position ((self slider))
  (compute-relative-slider-position self (knob-position (part self :knob))))

(defmethod (setf relative-slider-position) (new-position (self slider))
  (with-slots (orientation position) self
    (maxf new-position 0)
    (minf new-position 1)
    (setf position new-position)
    (case orientation
      ((:down :right) (setq new-position (- 1 new-position)))) 
    (multiple-value-bind (max-pix min-pix )
	  (partial-track-size (part self :track))
	(setf (partial-knob-position (part self :knob))
	    (round (- min-pix
		      (* (- min-pix max-pix)
			 new-position)))))))
  
(defmethod compute-slider-value ((self slider) knob-position)
  (write-transform self (compute-relative-slider-position self knob-position)))

(defmethod identification ((self slider))
  (relative-slider-position self))

(defmethod (setf identification) (new-value (self slider))
  (setf (relative-slider-position self) new-value))


;; The following two methods are present only for compatibility to 
;; earlier version. Should be replaced by just value.
(defmethod slider-value ((self slider))
  (value self))

(defmethod (setf slider-value) (value (self slider))
  (setf (value self) value))

;;; Default behaviour of a slider, update application as soon as button
;;;   is released: 

(defmethod move-slider-knob-after ((self slider) point)
  (write-to-application  self))

(defmethod move-slider-knob-before ((self slider) point)
 (declare (ignore point)) nil)

(defmethod move-slider-knob ((self slider) knob-position)
  (with-slots (move-action) self
    (when (or move-action)
      (let ((value (compute-slider-value self knob-position)))
	(when move-action
	  (funcall move-action (view-of self)
		   value))))))

;;;---------------------------------------------------------------------
;;; Special sliders
;;;---------------------------------------------------------------------

(defcontact numerical-slider (slider)
  ((name :initform :numerical-slider)
   (min :type number :accessor slider-min :initarg :min :initform 0)
   (max :type number :accessor slider-max :initarg :max :initform 1)
   (transformer :initform '(linear-transformer :a-high 1 :a-low 0))
   (transformation :initform nil :initarg :transformation
		   :accessor transformation)))

(defmethod initialize-instance :after ((self numerical-slider)
				       &rest args 
				       &key min max transformation)
  (declare (ignore args))
  (with-slots (transformer) self
    (when transformation (update-transformation self transformation))
    (when min (setf (a-low transformer) min))
    (when max (setf (a-high transformer) max))))

(defmethod (setf slider-min) :after (value (self numerical-slider))
  (setf (a-low (transformer self)) value))

(defmethod (setf slider-max) :after (value (self numerical-slider))
  (setf (a-high (transformer self)) value))

(defmethod (setf transformation) :after (value (self numerical-slider))
  (update-transformation self value))

(defmethod update-transformation ((self numerical-slider) transformation)
  (setf (transformer self)
       (case transformation
      (:sine `(linear-mapped-transformer
	       :map-function sin
	       :inverse-function asin
	       :map-low ,(- (/ pi 2))
	       :map-high ,(/ pi 2)))
      (:inverse `(linear-mapped-transformer
		  :map-function (lambda (x) (/ 1 x))
		  :inverse-function (lambda (x) (/ 1 x))
		  :map-low .5 :map-high 2))
      (:linear '(linear-transformer))
      (:logarithmic '(logarithmic-transformer))
      (:quadratic '(linear-mapped-transformer
		    :map-function sqrt
		    :inverse-function (lambda (x) (* x x))))))
  (setf (a-high (transformer self)) (slider-max self))
  (setf (a-low (transformer self)) (slider-min self)))

;; integer-slider becoming obsolete

(defcontact integer-slider (numerical-slider)
   ((name :initform :integer-slider)))

(defmethod write-transform ((self integer-slider) value)
  (round (call-next-method)))

;;;--------------------------------------------------------------------------
;;; basic-labelled-slider: serves as superclass for more specific
;;;                        labelled-sliders
;;;                        provides the initargs :high-label-part :low-label-part
;;;                        :slider-part
;;;--------------------------------------------------------------------------

(defcontact basic-labelled-slider (intel)
  ((layouter :initform '(aligning-distance-layouter
			:alignment :center :distance 5))
   (label-defaults :allocation :class :initform nil)
   (slider-defaults :allocation :class :initform '(:class numerical-slider))))

(defun delete-but-first-class (plist)
  (do ((result nil)
       (rest plist (cddr rest))
       (first-class? t))
      ((null rest) (nreverse result))
    (cond ((eq (car rest) :class)
		(when first-class?
		    (setq result (cons (cadr rest) (cons (car rest) result)))
		    (setq first-class? nil)))
	  (t (setq result (cons (cadr rest) (cons (car rest) result)))))))


(defmethod initialize-instance :after ((self basic-labelled-slider)
				       &rest init-list
				       &key high-label-part low-label-part
				       slider-part (orientation :up))
  (declare (ignore init-list))
   (setf (orientation (layouter self))
       (case orientation
	     ((:up :down) :down)
	     ((:left :right) :right)))
    (with-slots (label-defaults slider-defaults) self
      (let ((high-label-inits (delete-but-first-class
			     (append high-label-part
				label-defaults)))
	  (low-label-inits (delete-but-first-class
			    (append low-label-part
			       label-defaults))))
      (macrolet ((add-high-label-part ()
		   '(when high-label-inits
		     (apply #'add-part self
		      :name :high-label
		      high-label-inits)))
		 (add-low-label-part ()
		   '(when low-label-inits
		     (apply #'add-part self
		      :name :low-label
		      low-label-inits))))
	(if (member orientation '(:up :left))
	    (add-high-label-part) (add-low-label-part))
	(apply #'add-part self
	       :name :slider
	       (delete-but-first-class (append slider-part
					       (list :orientation orientation)
					       slider-defaults)))
	(if (member orientation '(:up :left))
	    (add-low-label-part) (add-high-label-part))))))

(defcontact text-labelled-slider (basic-labelled-slider)
  ((label-defaults :allocation :class :initform '(:class text-dispel))))

(defcontact captioned-slider (intel)
  ((layouter :initform '(aligning-distance-layouter
			:alignment :center :distance 10))
   (caption-defaults :allocation :class :initform '(:class text-dispel))
   (labelled-slider-defaults :allocation :class
			     :initform '(:class text-labelled-slider))))

(defmethod initialize-instance :after ((self captioned-slider)
				       &rest init-list
				       &key caption-part
				       labelled-slider-part)
  (declare (ignore init-list))
  (with-slots (caption-defaults labelled-slider-defaults) self
    (let ((caption-inits (delete-but-first-class
			  (append caption-part
			     caption-defaults))))
      (apply #'add-part self
	     :name :labelled-slider
	     (delete-but-first-class
	      (append labelled-slider-part labelled-slider-defaults)))
      (when caption-inits
	(apply #'add-part self
	       :name :caption
	      caption-inits)))))


#||
Test:
(defcontact active-slider (numerical-slider)
  ())

(defmethod move-slider-knob ((self slider) knob-position)
  (format t "~&Slider Value: ~d~%" (float (compute-slider-value self knob-position))))
||#