stk/STklos/Tk/Composite/Choicebox.stklos

;;;;
;;;; C h o i c e b o x . s t k 	  --  Choice Box composite widget
;;;;
;;;; Copyright <20> 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: Choicebox.stklos 1.4 Mon, 27 Apr 1998 15:39:00 +0200 eg $
;;;;
;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;;    Creation date: 22-Mar-1994 13:05
;;;; Last file update: 27-Apr-1998 12:11

(require "Basics")

(select-module STklos+Tk)

(export add-choice)

;=============================================================================
;
; 			      < C h o i c e - b o x >
;
;=============================================================================
;;
;; Resources
;;
(option 'add "*ChoiceBox*Entry*Background"  "white" "widgetDefault")
(option 'add "*ChoiceBox*Entry*Relief"      "ridge" "widgetDefault")
(option 'add "*ChoiceBox*Menu*TearOff"      "false" "widgetDefault")

;;
;; Utilities for accesing the set of choices as a whole (slot 'choices)
;;

(define (get-choices cb)
  ;; This is a little bit compilated because the type of the element of the 
  ;; list depends of the :string-value option
  (letrec ((menu     (menu-of cb))
	   (last     (menu-index menu 'last))
	   (get-item (lambda (i res)
		       (if (< i 0)
			   res
			   (let ((item ((Id menu) 'entrycget i :label)))
			     (get-item (- i 1)
				       (cons (if (string-value cb)
						 item
						 (read-from-string item))
					     res)))))))
    (if (equal? last "none")
	'()
	(get-item last '()))))

(define (set-choices! cb v)
  (let ((menu (menu-of cb)))
    ;; Delete the current choices
    (delete menu 0 (menu-index menu 'last))
    ;; Add the current value by suuceesive calls to add-choice
    (for-each (lambda (x) (add-choice cb x)) v)))

;;
;; Class definition
;;
(define-class <Choice-box> (<Tk-composite-widget> <Labeled-Entry>)
  ((lentry 	 :accessor     lentry-of)
   (menu	 :accessor     menu-of)
   (menubutton   :accessor     menubutton-of)
   (class 	 :init-keyword :class
		 :init-form    "ChoiceBox")

   ;; 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))
   (choices	 :accessor     choices
		 :init-keyword :choices
		 :allocation   :virtual
		 :slot-ref     get-choices
		 :slot-set!    set-choices!)
   (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 #f)
	 (mb (make <Menu-button>   :parent parent :text "" :relief "flat"
				   :borderwidth 0 :highlight-thickness 0
		   		   :indicator-on #t))
	 (m  (make <Menu>          :parent mb)))
    (next-method)

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

    ;; 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)
  (menu-add (Menu-of self) 
	    'command 
	    :label   mess 
	    :command (lambda () 
		       (let ((s (state self)))
			 (set! (state self) "normal")
			 (set! (value self) mess)
			 (set! (state self) s)))))

(provide "Choicebox")

#|

  Examples:
	(define c1  (make <Choice-box> :title "Enter your choice" 
			  :title-anchor 'e :title-width 20 
			  :value "Type <Return> to add"))
	(bind c1 "<Return>" (lambda () (add-choice c1 (value c1))))

        ;; Now one with a set of value pre-defined and no other value allowed
	(define c2  (make <Choice-box> :title "Enter another choice" 
			  :title-anchor 'e :title-width 20 :value 1
			  :state "disabled" :choices '(1 2 3 4)))
	(pack c1 c2)
|#