86 lines
2.7 KiB
Plaintext
86 lines
2.7 KiB
Plaintext
|
;;;;
|
|||
|
|
;;;; C h o i c e b o x . s t k -- Choice Box composite widget
|
|||
|
|
;;;;
|
|||
|
|
;;;; Copyright <20> 1993-1996 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: 24-Sep-1996 17:49
|
|||
|
|
|
|||
|
|
(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
|
|||
|
|
:text ""
|
|||
|
|
:relief "flat"
|
|||
|
|
:indicator-on #t
|
|||
|
|
:relief "raised"))
|
|||
|
|
(m (make <Menu> :parent mb)))
|
|||
|
|
|
|||
|
|
(pack 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)
|
|||
|
|
|
|||
|
|
;; 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)
|
|||
|
|
(menu-add (Menu-of self) 'command
|
|||
|
|
:label mess
|
|||
|
|
:command (lambda ()
|
|||
|
|
(set! (value self) mess))))
|
|||
|
|
|
|||
|
|
(provide "Choicebox")
|