;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: GARNET-GADGETS; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  GAD-scroll-parts
;;;
;;;  This module is a collection of schema definitions required by the trill
;;;  device and all scroll bars and sliders.
;;;
;;;  Written by Andrew Mickish

;;;  CHANGE LOG
;;;  06/24/92  Andrew Mickish - Points is now optional for SLIDE-FINAL-FN
;;;  05/29/92  Brad Myers - made to work with new auto-repeat button inter
;;;  01/18/90  Andrew Mickish - Changed the following formulas to consider the
;;;            :scroll-p slot of the top level gadget:
;;;                1) :active of TRILL-INTER      3) :active of SLIDE-INTER
;;;                2) :visible of INDICATOR-TEXT  4) :active of JUMP-INTER
;;;  03/11/90  Andrew Mickish - Simplified VAL-1-FN and VAL-2-FN by calling
;;;            S-VALUE instead of INCF and DECF.
;;;  07/01/90  Andrew Mickish - Considered :window slot in :active formulas
;;;            of all interactors
;;;  11/30/90  Pavan Reddy - used "format" instead of "prin1-to-string" in
;;;            INDICATOR-TEXT to allow use of floats.
;;;

(in-package "GARNET-GADGETS" :use '("LISP" "KR"))

;;;
;;;  TRILL INTERACTOR AND INCREMENTOR FUNCTIONS
;;;

;;;  Used to increment (or decrement) the value closer to VAL-1
;;;
(defun VAL-1-FN (interactor final-obj-over)
  (declare (ignore final-obj-over))
  (let* ((parent (g-value interactor :operates-on :parent))
	 (val-1 (g-value parent :val-1))
	 (val-2 (g-value parent :val-2))
	 (value (g-value parent :value))
	 (inc-by (g-value interactor :operates-on :inc-by)))

    (cond 

     ;; there is a max and a min
     ((and val-1 val-2)
      (if (< val-1 val-2)
	  (let ((thresh-val (+ val-1 inc-by)))
	    (if (> value thresh-val)
		(s-value parent :value (- value inc-by))
		(s-value parent :value val-1)))
	  (let ((thresh-val (- val-1 inc-by)))
	    (if (< value thresh-val)
		(s-value parent :value (+ value inc-by))
		(s-value parent :value val-1)))))

     ;; there is no max
     ((and val-1 (not val-2))
      (let ((thresh-val (+ val-1 inc-by)))
	(if (> value thresh-val)
	    (s-value parent :value (- value inc-by))
	    (s-value parent :value val-1))))

     ;; there is no min
     (t (s-value parent :value (- value inc-by))))))

;;;  Used to increment (or decrement) the value closer to VAL-2
;;;	   
(defun VAL-2-FN (interactor final-obj-over)
  (declare (ignore final-obj-over))
  (let* ((parent (g-value interactor :operates-on :parent))
	 (val-1 (g-value parent :val-1))
	 (val-2 (g-value parent :val-2))
	 (value (g-value parent :value))
	 (inc-by (g-value interactor :operates-on :inc-by)))

    (cond

     ; there is a max and a min
     ((and val-1 val-2)
      (if (< val-1 val-2)
	  (let ((thresh-val (- val-2 inc-by)))
	    (if (< value thresh-val)
		(s-value parent :value (+ value inc-by))
		(s-value parent :value val-2)))
	  (let ((thresh-val (+ val-2 inc-by)))
	    (if (> value thresh-val)
		(s-value parent :value (- value inc-by))
		(s-value parent :value val-2)))))

     ; there is no min
     ((and (not val-1) val-2)
      (let ((thresh-val (- val-2 inc-by)))
	(if (< value thresh-val)
	    (s-value parent :value (+ value inc-by))
	    (s-value parent :value val-2))))

     ; there is no max
     (t (s-value parent :value (+ value inc-by))))))


(create-instance 'TRILL-INTER inter:Button-Interactor
   (:active (o-formula (and (gvl :operates-on :visible)
			    (gvl :window)
			    (gvl :operates-on :parent :scroll-p))))
   (:window (o-formula (gv-local :self :operates-on :window)))
   (:timer-repeat-p T)
   (:start-event :leftdown)
   (:start-where (o-formula (list :in-box (gvl :operates-on :frame))))
   (:extra-function #'VAL-1-FN)
   (:final-function #'(lambda (interactor obj)
			(kr-send interactor :extra-function
				 interactor obj)
			(kr-send (g-value interactor :operates-on :parent)
				 :selection-function
				 (g-value interactor :operates-on :parent)
				 (g-value interactor :operates-on :parent
					  :value)))))


;;;
;;;  FRAME FOR TRILL BOXES
;;;


(create-instance 'TRILL-FRAME opal:rectangle
   (:left (o-formula (gv (kr-path 0 :parent) :left)))
   (:top (o-formula (gv (kr-path 0 :parent) :top)))
   (:width (o-formula (gv (kr-path 0 :parent) :width)))
   (:height (o-formula (gv (kr-path 0 :parent) :height)))
   (:visible (o-formula (gv (kr-path 0 :parent) :visible))))


;;;
;;;  BACKGROUND INDICATOR MOVES IN
;;;

(create-instance 'BOUND-BOX opal:rectangle
   (:left (o-formula (gv (kr-path 0 :parent) :bound-left)))
   (:top (o-formula (gv (kr-path 0 :parent) :bound-top)))
   (:width (o-formula (gv (kr-path 0 :parent) :bound-width)))
   (:height (o-formula (gv (kr-path 0 :parent) :bound-height))))


;;;
;;;  INCDICATOR TEXT
;;;

(create-instance 'INDICATOR-TEXT opal:text
   (:left (o-formula (- (+ (gv (kr-path 0 :parent :indicator) :left)
			   (floor (gv (kr-path 0 :parent :indicator) :width) 2))
			(floor (gvl :width) 2))))
   (:top (o-formula (- (+ (gv (kr-path 0 :parent :indicator) :top)
			  (floor (gv (kr-path 0 :parent :indicator) :height) 2))
		       (floor (gvl :height) 2))))
   (:string (o-formula (format NIL (gv (kr-path 0 :parent) :format-string)
			       (gv (kr-path 0 :parent) :value))))
   (:font (o-formula (gv (kr-path 0 :parent) :indicator-font)))
   (:visible (o-formula (and (gv (kr-path 0 :parent) :indicator-text-p)
			     (gv (kr-path 0 :parent) :scroll-p)))))

;;;
;;; INTERACTORS TO MOVE INDICATOR WITH MOUSE
;;;

(defun SLIDE-SEL-FN (interactor obj points)
  (call-prototype-method interactor obj points)
  (when (not (g-value interactor :operates-on :int-feedback-p))
    (slide-final-fn interactor obj points)))

(defun SLIDE-FINAL-FN (interactor obj &optional points)
  ;; Must keep points as an optional parameter because this function is used
  ;; as the final-function in several interactors.
  (declare (ignore obj points))
  (kr-send (g-value interactor :operates-on)
	   :selection-function
	   (g-value interactor :operates-on)
	   (g-value interactor :operates-on :value)))


(create-instance 'SLIDE-INTER inter:Move-Grow-Interactor
   (:window (o-formula (gv-local :self :operates-on :window)))
   (:active (o-formula (and (gvl :window) (gvl :operates-on :scroll-p))))
   (:start-where (o-formula (list :in-box (gvl :operates-on :indicator))))
   (:running-where (o-formula (list :in-box (gvl :operates-on :bounding-area))))
   (:outside NIL)
   (:obj-to-be-moved (o-formula (gvl :operates-on :indicator)))
   (:feedback-obj (o-formula (if (gvl :operates-on :int-feedback-p)
				(gvl :operates-on :int-feedback)
				(gvl :operates-on :indicator))))
   (:waiting-priority inter:high-priority-level)
   (:grow-p NIL)
   (:start-action #'SLIDE-SEL-FN)
   (:running-action #'SLIDE-SEL-FN)
   (:final-function #'SLIDE-FINAL-FN))


(create-instance 'JUMP-INTER inter:Move-Grow-Interactor
   (:window (o-formula (gv-local :self :operates-on :window)))
   (:active (o-formula (and (gvl :window) (gvl :operates-on :scroll-p))))
   (:start-event :leftdown)
   (:start-where (o-formula (list :in-box (gvl :operates-on :bounding-area))))
   (:running-where (o-formula (list :in-box (gvl :operates-on :bounding-area))))
   (:outside NIL)
   (:obj-to-be-moved (o-formula (gvl :operates-on :indicator)))
   (:feedback-obj (o-formula (gvl :operates-on :indicator)))
   (:attach-point :n)
   (:grow-p NIL)
   (:final-function #'SLIDE-FINAL-FN))


;;  Tell the world that GAD-scroll-parts has been loaded
;;
(setf (get :garnet-modules :GAD-scroll-parts) T)

;;  All other dependent "parts" modules must be reloaded
;;
(setf (get :garnet-modules :GAD-slider-parts) NIL)
(setf (get :garnet-modules :GAD-h-boxes) NIL)
(setf (get :garnet-modules :GAD-v-boxes) NIL)
