;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Motif Vertical Scroll Bar
;;;
;;;  Features and operation of the vertical scroll bar:
;;;     1)  Drag the indicator with the left mouse button.
;;;     2)  Click the left mouse button in the scroll bar background to cause
;;;         the indicator to jump by :page-incr increments.
;;;     3)  Click the left mouse button in the trill boxes to move the
;;;         indicator by :scr-incr increments.
;;;     4)  The top level :value slot is the position of the indicator.
;;;         This slot may be set directly and formulae may depend on it.
;;;     5)  The function specified in :selection-function will be executed
;;;         when the :values slot changes.
;;;
;;;  Customizable slots:
;;;     1)  Left, top, width, height
;;;     2)  Scr-trill-p  --  Whether to arrow trill boxes that increment by
;;;                          :scr-incr.
;;;     3)  Val-1, Val-2  --  Range of values the indicator spans.
;;;                           Val-1 corresponds to the top of the scroll bar.
;;;     4)  Scr-Incr  --  Value to increment position by with the trill arrows.
;;;     5)  Page-Incr  --  Value to increment postion by when mouse is clicked
;;;                        in trough.
;;;     6)  Percent-Visible -- Percent of the trough that should be occupied
;;;                            by the indicator (from 0 to 1).
;;;     7)  Foreground-Color
;;;     8)  Value -- The current value chosen by the user.
;;;     9)  Scroll-p -- Whether to allow scrolling.
;;;    10)  Keyboard-selection-p -- Whether the keyboard interactor should
;;;            operate on the scroll bar.
;;;    11)  Selection-function -- Function executed whenever :value changes.
;;;
;;;  NOTE:  This module requires schemata defined in Motif-Parts.
;;;
;;;  Motif vertical scroll bar demo:
;;;     This module contains a function which creates a window and a scroll bar
;;;     in the window.  To run it, enter (GARNET-GADGETS:motif-v-scroll-go).
;;;     To stop, enter (GARNET-GADGETS:motif-v-scroll-stop).
;;;
;;;  Written by Andrew Mickish

;;;  CHANGE LOG:
;;;  12/15/92  Andrew Mickish - Added type and parameter declarations
;;;  06/24/92  Andrew Mickish - Changed :JUMP interactor to be MOTIF-JUMP
;;;  05/29/92  Brad Myers - changed for auto-repeat button interactor
;;;  02/11/92  Andrew Mickish - Added :maybe-constant list
;;;  03/01/91  Andrew Mickish - Created
;;;  

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

(export '(Motif-V-Scroll-Bar))
#+garnet-debug
(export '(Motif-V-Scroll-Go Motif-V-Scroll-Stop
	  Demo-Motif-V-Scroll-Bar Motif-V-Scroll-Win Motif-V-Scroll-Top-Agg))

(create-instance 'MOTIF-V-SCROLL-BAR-UP-ARROW opal:aggregadget
   (:left (o-formula (+ 1 (gv (kr-path 0 :parent) :bound-left))))
   (:top (o-formula (gv (kr-path 0 :parent) :up-arrow-top)))
   (:width (o-formula (- (gv (kr-path 0 :parent) :bound-width) 1)))
   (:height (o-formula (gvl :width)))
   (:center-x (o-formula (+ (gvl :left) (floor (- (gvl :width) 1) 2))))
   (:right (o-formula (+ (gvl :left) (- (gvl :width) 1))))
   (:bottom (o-formula (+ (gvl :top) (- (gvl :height) 1))))
   (:inc-by (o-formula (gv (kr-path 0 :parent) :scr-incr)))
   (:interim-selected NIL)
   (:visible (o-formula (and (gv (kr-path 0 :parent) :scr-trill-p)
			      (gv (kr-path 0 :parent) :visible))))
   (:parts
    `((:right-line ,opal:polyline
       ;; :left, :top, :width, & :height formulas obviate looking at
       ;; the :line-style slot, which frequently changes.
       (: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)))
       (:point-list ,(o-formula (let* ((p (kr-path 0 :parent))
				       (bottom (gv p :bottom)))
				  (list (gv p :center-x) (gv p :top)
					(- (gv p :right) 1) bottom
					(gv p :left) bottom))))
       (:line-style ,(o-formula
		      (let ((p (kr-path 0 :parent :parent)))
			(if (gv (kr-path 1 :parent) :interim-selected)
			    (gv p :highlight-line-style)
			    (gv p :shadow-line-style)))))
       (:filling-style ,(o-formula
			 (let* ((p (kr-path 0 :parent :parent)))
			   (if (gv (kr-path 1 :parent) :interim-selected)
			       (gv p :background-fill)
			       (gv p :foreground-fill))))))
      (:left-line ,opal:line
       (:x1 ,(o-formula (gv (kr-path 0 :parent) :center-x)))
       (:y1 ,(o-formula (gv (kr-path 0 :parent) :top)))
       (:x2 ,(o-formula (gv (kr-path 0 :parent) :left)))
       (:y2 ,(o-formula (gv (kr-path 0 :parent) :bottom)))
       ;; :left, :top, :width, & :height formulas obviate looking at
       ;; the :line-style slot, which frequently changes.
       (:left ,(o-formula (gvl :x2)))
       (:top ,(o-formula (gvl :y1)))
       (:width ,(o-formula (gv (kr-path 0 :parent) :width)))
       (:height ,(o-formula (gv (kr-path 0 :parent) :height)))
       (:line-style ,(o-formula
		      (let ((p (kr-path 0 :parent :parent)))
			(if (gv (kr-path 1 :parent) :interim-selected)
			    (gv p :shadow-line-style)
			    (gv p :highlight-line-style))))))))
   (:interactors
    `((:trill ,MOTIF-TRILL))))

(create-instance 'MOTIF-V-SCROLL-BAR-DOWN-ARROW opal:aggregadget
   (:left (o-formula (gv (kr-path 0 :parent) :bound-left)))
   (:top (o-formula (gv (kr-path 0 :parent) :down-arrow-top)))
   (:width (o-formula (gv (kr-path 0 :parent) :bound-width)))
   (:height (o-formula (gvl :width)))
   (:center-x (o-formula (+ (gvl :left) (floor (gvl :width) 2))))
   (:right (o-formula (+ (gvl :left) (- (gvl :width) 1))))
   (:bottom (o-formula (+ (gvl :top) (- (gvl :height) 1))))
   (:inc-by (o-formula (gv (kr-path 0 :parent) :scr-incr)))
   (:interim-selected NIL)
   (:visible (o-formula (and (gv (kr-path 0 :parent) :scr-trill-p)
			     (gv (kr-path 0 :parent) :visible))))
   (:parts
    `((:left-line ,opal:polyline
       ;; :left, :top, :width, & :height formulas obviate looking at
       ;; the :line-style slot, which frequently changes.
       (: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)))
       (:point-list ,(o-formula (let* ((p (kr-path 0 :parent))
				       (top (+ (gv p :top) 1)))
				  (list (gv p :center-x) (gv p :bottom)
					(+ 1 (gv p :left)) top
					(gv p :right) top))))
       (:line-style ,(o-formula
		      (let ((p (kr-path 0 :parent :parent)))
			(if (gv (kr-path 1 :parent) :interim-selected)
			    (gv p :shadow-line-style)
			    (gv p :highlight-line-style)))))
       (:filling-style ,(o-formula
			 (let* ((p (kr-path 0 :parent :parent)))
			   (if (gv (kr-path 1 :parent) :interim-selected)
			       (gv p :background-fill)
			       (gv p :foreground-fill))))))
      (:right-line ,opal:line
       (:x1 ,(o-formula (gv (kr-path 0 :parent) :right)))
       (:y1 ,(o-formula (+ 1 (gv (kr-path 0 :parent) :top))))
       (:x2 ,(o-formula (gv (kr-path 0 :parent) :center-x)))
       (:y2 ,(o-formula (gv (kr-path 0 :parent) :bottom)))
       ;; :left, :top, :width, & :height formulas obviate looking at
       ;; the :line-style slot, which frequently changes.
       (:left ,(o-formula (gvl :x2)))
       (:top ,(o-formula (gvl :y1)))
       (:width ,(o-formula (gv (kr-path 0 :parent) :width)))
       (:height ,(o-formula (gv (kr-path 0 :parent) :height)))
       (:line-style ,(o-formula
		      (let ((p (kr-path 0 :parent :parent)))
			(if (gv (kr-path 1 :parent) :interim-selected)
			    (gv p :highlight-line-style)
			    (gv p :shadow-line-style))))))))
   (:interactors
    `((:trill ,MOTIF-TRILL
       (:extra-function ,#'val-2-fn)))))



(create-instance 'MOTIF-V-SCROLL-BAR MOTIF-GADGET-PROTOTYPE
  :declare ((:parameters :left :top :width :height :val-1 :val-2
			 :scr-incr :page-incr :scr-trill-p :percent-visible
			 :scroll-p :keyboard-selection-p :foreground-color
			 :value :active-p :selection-function :visible)
	    (:type (number :val-1 :val-2 :scr-incr :page-incr :value)
		   (kr-boolean :scr-trill-p :scroll-p :keyboard-selection-p
		    :active-p)
		   #+(or lucid allegro-V3.1) (number :percent-visible)
		   #-(or lucid allegro-V3.1) ((real 0 1) :percent-visible)
		   ((is-a-p opal:color) :foreground-color)
		   ((or null function symbol) :selection-function))
	    (:maybe-constant :left :top :width :height :val-1 :val-2 :scr-incr
			     :page-incr :scr-trill-p :percent-visible :scroll-p
			     :foreground-color :visible))
   (:left 0)(:top 0)(:width 20)(:height 200)
   (:val-1 0) (:val-2 100)
   (:scr-incr 1) (:page-incr 5)
   (:scr-trill-p T)
   (:percent-visible .5)
   (:scroll-p T)
   (:keyboard-selection-p NIL)
   (:foreground-color opal:MOTIF-GRAY)
   (:value (o-formula (inter:Clip-and-Map (second (gvl :indicator :box))
					  (gvl :bound-top)
					  (- (gvl :bound-bottom)
					     (gvl :indicator :height) 2)
					  (gvl :val-1) (gvl :val-2))))
   
   (:bottom (o-formula (+ (gvl :top) (gvl :height))))
   (:up-arrow-top (o-formula (+ 5 (gvl :top))))
   (:down-arrow-top (o-formula (- (gvl :bottom) (gvl :bound-width) 6)))

   (:bound-left (o-formula (+ 4 (gvl :left))))
   (:bound-top (o-formula (+ 5 (gvl :top) (if (gvl :scr-trill-p)
					      (gvl :bound-width) 0))))
   (:bound-width (o-formula (- (gvl :width) 8)))
   (:bound-height (o-formula (- (gvl :bound-bottom) (gvl :bound-top))))
   (:bound-bottom (o-formula (- (gvl :bottom) (if (gvl :scr-trill-p)
						  (gvl :width) 5))))
   (:active-p T)

   ;;; All auxiliary color slots are defined in MOTIF-GADGET-PROTOTYPE
   
   (:parts
    `((:BORDER ,MOTIF-BOX
            (:constant (:depressed-p))
	    (:left ,(o-formula (+ 2 (gv (kr-path 0 :parent) :left))))
	    (:top ,(o-formula (+ 2 (gv (kr-path 0 :parent) :top))))
	    (:width ,(o-formula (- (gv (kr-path 0 :parent) :width) 4)))
	    (:height ,(o-formula (- (gv (kr-path 0 :parent) :height) 4)))
	    (:depressed-p T))

      (:BOUNDING-AREA ,BOUND-BOX
	    (:hit-threshold 0) (:line-style NIL) (:filling-style NIL))

      (:INDICATOR ,MOTIF-BOX
            (:constant (:depressed-p))
	    (:box (0 0 0 0))
	    (:left ,(o-formula (gv (kr-path 0 :parent) :bound-left)))
	    (:top ,(o-formula (let* ((p (kr-path 0 :parent))
				     (val-1 (gv p :val-1))
				     (val-2 (gv p :val-2))
				     (bound-top (gv p :bound-top)))
				(if (/= val-1 val-2)
				    (inter:Clip-and-Map 
				     (gv p :value)
				     val-1 val-2
				     bound-top (- (gv p :bound-bottom)
						  (gvl :height)))
				    (opal:gv-center-y-is-center-of (gv p))))))
	    (:width ,(o-formula (gv (kr-path 0 :parent) :bound-width)))
	    (:height ,(o-formula (MAX 6 (let ((p (kr-path 0 :parent)))
					  (round (* (gv p :bound-height)
						    (MIN 1 (gv p :percent-visible)))))))))
      (:UP-ARROW ,MOTIF-V-SCROLL-BAR-UP-ARROW)
      (:DOWN-ARROW ,MOTIF-V-SCROLL-BAR-DOWN-ARROW)
      (:SEL-BOX ,MOTIF-SELECTION-BOX
                (:obj-over ,(o-formula (gvl :parent))))))

   (:interactors
    `((:SLIDE ,SLIDE-INTER
              (:active ,(o-formula (let ((p (gvl :operates-on)))
				     (and (gvl :window)
					  (gv p :scroll-p) (gv p :active-p)))))
              (:running-where T))
      (:JUMP ,MOTIF-JUMP
       (:final-function
	,#'(lambda (interactor obj)
	     (MOTIF-JUMP-FN interactor (inter:event-y inter:*current-event*)
			    (g-value interactor :operates-on :indicator :top))
	     (SLIDE-FINAL-FN interactor obj))))

      (:KEY ,inter:button-interactor
       (:active ,(o-formula (let ((p (gvl :operates-on)))
			      (and (gvl :window) 
				   (gv p :scroll-p) (gv p :active-p)
				   (gv p :keyboard-selection-p)))))
       (:window ,(o-formula (gv-local :self :operates-on :window)))
       (:continuous NIL)
       (:start-where T)
       (:start-event (:uparrow :downarrow))
       (:final-function MOTIF-KEY-TRILL-FN)))))
			 

;;;
;;;  DEMO FUNCTION
;;;

#+garnet-debug
(defun MOTIF-V-SCROLL-GO (&key dont-enter-main-event-loop
			       not-double-buffered-p)
  (create-instance 'MOTIF-V-SCROLL-WIN inter:interactor-window
     (:double-buffered-p (not not-double-buffered-p))
     (:title "Motif Vertical Scroll Bar")
     (:left 800)(:top 10)(:width 200)(:height 240))
  (s-value MOTIF-V-SCROLL-WIN
	   :aggregate
	   (create-instance 'MOTIF-V-SCROLL-TOP-AGG opal:aggregate))
  (create-instance 'DEMO-MOTIF-V-SCROLL-BAR MOTIF-V-SCROLL-BAR
     (:left 90)(:top 20)
     (:keyboard-selection-p T))
  (opal:add-components MOTIF-V-SCROLL-TOP-AGG
		       (create-instance NIL MOTIF-BACKGROUND)
		       DEMO-MOTIF-V-SCROLL-BAR)
  (opal:update MOTIF-V-SCROLL-WIN)
  (unless dont-enter-main-event-loop #-cmu (inter:main-event-loop)))
  
#+garnet-debug
(defun MOTIF-V-SCROLL-STOP ()
  (opal:destroy MOTIF-V-SCROLL-WIN))
