;;;;
;;;; S c r o l l b o x . s t k 	  --  Scroll Listbox composite widget
;;;;
;;;; Copyright (C) 1993,1994,1995 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.
;;;;
;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;;    Creation date: 22-Mar-1994 13:05
;;;; Last file update: 11-Jul-1995 21:15


(require "Frame")
(require "Listbox")
(require "Scrollbar")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Scroll-listbox> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-class <Scroll-listbox> (<Tk-composite-widget> <Listbox>)
  ((listbox 	  :accessor     listbox-of)
   (h-scrollbar	  :accessor     h-scrollbar-of)
   (v-scrollbar	  :accessor     v-scrollbar-of)
   (h-scroll-side :accessor     h-scroll-side
		  :allocation   :virtual
		  :init-keyword :h-scroll-side
		  :slot-ref     (lambda (o)
				  (let ((hs (h-scrollbar-of o)))
				    (if (= (winfo 'ismapped hs) 1)
					(cadr (member '-side 
						      (pack 'newinfo hs)))
					#f)))
		  :slot-set!    (lambda (o v)
				  (unless (memv v '(top bottom #f))
				    (error "bad scroll side specification: ~S" v))
				  (let ((hs (h-scrollbar-of o)))
				    (if v
					(pack hs :fill 'x :side v 
					         :before (listbox-of o))
					(pack 'forget hs)))))
   (v-scroll-side :accessor     v-scroll-side
		  :allocation   :virtual
		  :init-keyword :v-scroll-side
		  :slot-ref     (lambda (o)
				  (let ((vs (v-scrollbar-of o)))
				    (if (= (winfo 'ismapped vs) 1)
					(cadr (member '-side 
						      (pack 'newinfo vs)))
					#f)))
		  :slot-set!    (lambda (o v)
				  (unless (memv v '(left right #f))
				     (error "bad scroll side specification: ~S" v))
				  (let ((vs (v-scrollbar-of o)))
				    (if v 
					(pack vs :fill 'y :side v 
					         :before (listbox-of o))
					(pack 'forget vs)))))
   ;; Non allocated slots
   (background   :accessor     background
		 :init-keyword :background
		 :allocation   :propagated
		 :propagate-to (frame listbox h-scrollbar v-scrollbar))
   (border-width :accessor     border-width 
		 :allocation   :propagated
		 :init-keyword :border-width
		 :propagate-to (frame))
   (relief	 :accessor     relief
		 :init-keyword :relief
		 :allocation   :propagated
		 :propagate-to (frame))))

;;;;
;;;;  <Scroll-listbox> methods
;;;;

(define-method initialize-composite-widget ((self <Scroll-listbox>) initargs parent)
  (let* ((hs (make <Scrollbar> :parent parent :border-width 2 
		   	       :relief "groove" :orientation "horizontal"))
	 (vs (make <Scrollbar> :parent parent :border-width 2 
		   	       :relief "groove" :orientation "vertical"))
	 (l  (make <Listbox>   :parent parent :border-width 2 
		   	       :relief "groove")))

    ;; Set internal true slots 
    (slot-set! self 'Id	          (Id l))
    (slot-set! self 'listbox       l)
    (slot-set! self 'h-scrollbar  hs)
    (slot-set! self 'v-scrollbar  vs)

    ;; Pack internal widgets (Warning: Order is dependant !!!!)
    (pack vs :fill 'y :side 'right)
    (pack l  :expand #t :fill "both" :side 'bottom :after vs)

    ;; Attach command to scrollbar and listbox
    (set! (x-scroll-command l) (format #f "~S 'set "(address-of (Id hs))))
    (set! (y-scroll-command l) (format #f "~S 'set "(address-of (Id vs))))
    (set! (command hs) (format #f "~S 'xview "(address-of (Id l))))
    (set! (command vs) (format #f "~S 'yview "(address-of (Id l))))
))

(provide "Scrollbox")