;;;;
;;;; C h o i c e b o x . s t k 	  --  Choice Box 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:  5-Aug-1994 12:05


(require "Lentry")
(require "Menu")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Choice-box> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-class <Choice-box> (<Tk-composite-widget> <Labeled-Entry>)
  ((lentry 	 :accessor   lentry-of)
   (menu	 :accessor   menu-of)
   (menubutton   :accessor   menubutton-of)
   ;; Non allocated slots
   (background   :accessor     background
		 :init-keyword :background
		 :allocation   :propagated
		 :propagate-to (frame lentry menu menubutton))
   (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))))

;;;;
;;;; <Choice-box> methods
;;;;

(define-method initialize-composite-widget ((self <Choice-box>) initargs parent)
  (let* ((l  (make <Labeled-entry> :parent parent))
	 (mb (make <Menu-button>   :parent parent 
		   		   :relief "raised"
		   		   :bitmap (& "@" tk_library 
					      "/bitmaps/down_arrow_8.bm")))
	 (m  (make <Menu>          :parent mb)))

    (pack l  :side "left"  :fill "x" :expand #t )
    (pack mb :side "right" :padx 5)
    
    ;; Initialize true slots
    (slot-set! self 'Id	    (Id l))
    (slot-set! self 'lentry l)
    (slot-set! self 'menu   m)
    (slot-set! self 'menubutton mb)

    ;; Initialize inherited slots
    (slot-set! self 'label  (label-of l))
    (slot-set! self 'entry  (entry-of l))

    ;; Attach menu m to menu button mb
    (set! (menu-of mb) m)))

;;
;; add-choice permits to add a new choice (a string) in the associated 
;; Choice-box menu
;;

(define-method add-choice ((self <Choice-box>) mess)
  (let ((entry (Id (entry-of (lentry-of self)))))
    (menu-add (Menu-of self) 'command 
	      		     :label mess 
			     :command `(set! (value (Id->instance ,entry)) ,mess))))

(provide "Choicebox")