;;;;
;;;; S c r o l l b a r . s t k 	  --  Scrollbar class definition
;;;;
;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works.  Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.  
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; $Id: Scrollbar.stklos 1.2 Sat, 24 Jan 1998 14:12:00 +0000 eg $
;;;;
;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;;    Creation date:  5-Mar-1994 17:19
;;;; Last file update: 24-Jan-1998 13:57

(require "Basics")
(select-module STklos+Tk)
(export activate scrollbar-delta scrollbar-fraction scrollbar-identify
	scrollbar-get scrollbar-set!)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Scrollbar> class
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-class <Scrollbar> (<Tk-simple-widget>)
  ((active-background    :accessor     active-background
			 :init-keyword :active-background
			 :tk-name      activebackground
			 :allocation   :tk-virtual)
   (active-relief        :accessor     active-relief
			 :init-keyword :active-relief
			 :tk-name      activerelief
			 :allocation   :tk-virtual)
   (command 	         :accessor     command
			 :init-keyword :command
			 :allocation   :tk-virtual)  
   (element-border-width :accessor     element-border-width
			 :init-keyword :element-border-width
			 :tk-name      elementborderwidth
			 :allocation   :tk-virtual)
   (jump 	         :accessor     jump
			 :init-keyword :jump
			 :allocation   :tk-virtual)
   (orientation          :accessor     orientation
			 :init-keyword :orientation
			 :tk-name      orient
			 :allocation   :tk-virtual)
   (repeat-delay         :accessor     repeat-delay
			 :init-keyword :repeat-delay
			 :tk-name       repeatdelay
			 :allocation   :tk-virtual)
   (repeat-interval      :accessor     repeat-interval
			 :init-keyword :repeat-interval
			 :tk-name      repeatinterval
			 :allocation   :tk-virtual)
   (trough-color         :accessor     trough-color
			 :init-keyword :trough-color
			 :tk-name      troughcolor
			 :allocation   :tk-virtual)
   (width 	         :accessor     width
			 :init-keyword :width
			 :allocation   :tk-virtual)
   ;; Fictive slot 
   (value	         :accessor     value
			 :init-keyword :value
			 :allocation   :virtual
			 :slot-ref     (lambda (o)  
					 ((slot-ref o 'Id) 'get))
			 :slot-set!    (lambda (o v) 
					 (apply (slot-ref o 'Id) 'set v)))))

(define-method tk-constructor ((self <Scrollbar>))
  Tk:scrollbar)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Scrollbar Methods
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-method initialize ((self <Scrollbar>) args)
  (next-method)
  (let ((val (get-keyword :value args #f)))
    ;; If a value is specified at init-time init, set it.
    (when val 
	  (set! (value self) val))))

;;;
;;; Activate
;;;
(define-method  activate ((self <Scrollbar>))
  ((slot-ref self 'Id) 'activate))

(define-method  activate ((self <Scrollbar>) element)
  ((slot-ref self 'Id) 'activate element))

;;;
;;; Scrollbar-delta
;;;
(define-method scrollbar-delta ((self <Scrollbar>) delta-x delta-y)
  ((slot-ref self 'Id) 'delta delta-x delta-y))

;;;
;;; Scrollbar-fraction
;;;
(define-method scrollbar-fraction ((self <Scrollbar>) x y)
  ((slot-ref self 'Id) 'fraction x y))

;;;
;;; Scrollbar-identify
;;;
(define-method scrollbar-identify ((self <Scrollbar>) x y)
  ((slot-ref self 'Id) 'identify x y))

;;;
;;; Scrollbar-get
;;;
(define-method scrollbar-get ((self <Scrollbar>))
  ((slot-ref self 'Id) 'get))

;;;
;;; Scrollbar-set!
;;;
(define-method scrollbar-set! ((self <Scrollbar>) x y z w) ; old syntax
  ((slot-ref self 'Id) 'set x y z w))

(define-method scrollbar-set! ((self <Scrollbar>) x y) ; new syntax
  ((slot-ref self 'Id) 'set x y))

;=============================================================================
;
; Function used by composite widgets with scrollbars
;
;=============================================================================
(define (STk:h-scroll-side hs)
  (let ((info (grid 'info hs)))
    (if (null? info)
	#f
	(case (get-keyword :row info)
	  ((0) "top")
	  ((2) "bottom")))))

(define (STk:h-scroll-side-set! hs v)
  (cond 
   ((equal? v "bottom")  (grid hs :row 2 :column 1))
   ((equal? v "top")     (grid hs :row 0 :column 1))
   ((not v)	         (grid 'remove hs))))

(define (STk:v-scroll-side vs)
  (let ((info (grid 'info vs)))
    (if (null? info)
	#f
	(case (get-keyword :column info)
	  ((0) "left")
	  ((2) "right")))))

(define (STk:v-scroll-side-set! vs v)
  (cond
   ((equal? v "left")  (grid vs :row 1 :column 0))
   ((equal? v "right") (grid vs :row 1 :column 2))
   ((not v)	       (grid 'remove vs))))

(provide "Scrollbar")