;;;;
;;;; L f r a m e . s t k l o s 	    --  Labeled Frame composite widget
;;;;
;;;; 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: Lframe.stklos 1.2 Sun, 01 Feb 1998 22:14:16 +0000 eg $
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 25-Oct-1996 19:31
;;;; Last file update: 30-Jan-1998 00:00

(require "Basics")

(select-module STklos+Tk)

;=============================================================================
;
; 			< L a b e l e d - F r a m e >
;
;=============================================================================

;;;;
;;;; Resources
;;;;
(option 'add "*LabeledFrame.Box.Relief"      "ridge" "widgetDefault")
(option 'add "*LabeledFrame.Box.BorderWidth"       2 "widgetDefault")

;;;;
;;;; Utilities
;;;;

(define (configure-labeled-frame lf box filler label)
  (let ((width  (winfo 'width label))
	(height (winfo 'height label)))

    ;; Compute a new width and height for the filler
    (slot-set! filler 'height (+ (/ height 2) 2))
    (slot-set! filler 'width  width)
    (pack filler :expand #f :fill "x" :side "top")

    ;; Place the label on the frame
    (place label :in box :x 10 :y 0 :anchor "w")))


;;;;
;;;; Class definition
;;;;

(define-class <Labeled-Frame> (<Tk-composite-widget> <Frame>)
  ((class 	 :init-keyword :class
		 :init-form    "LabeledFrame")
   (fill-frame)
   (box-frame	 :accessor      box-frame-of)
   (label	 :accessor      label-of)

   ;; Fictive slots
   (title	 :accessor	title
		 :init-keyword	:title
		 :allocation	:propagated
		 :propagate-to	((label text)))
   (font	 :accessor	font
		 :init-keyword	:font
		 :allocation	:propagated
		 :propagate-to	(label))
   (background	 :accessor	background
		 :init-keyword	:background
		 :allocation	:propagated
		 :propagate-to	(frame label fill-frame box-frame))
   (foreground	 :accessor	foreground
		 :init-keyword	:foreground
		 :allocation	:propagated
		 :propagate-to	(label))
   (width	 :accessor	width
		 :init-keyword	:width
		 :allocation	:propagated
		 :propagate-to	(frame))
   (height	 :accessor	height
		 :init-keyword	:height
		 :allocation	:propagated
		 :propagate-to	(frame))))


(define-method initialize-composite-widget ((self <Labeled-frame>) initargs frame)
  (let* ((box    (make <Frame> :parent frame :class "Box"))
	 (filler (make <Frame> :parent box :relief "flat"))
	 (lab    (make <Label> :parent frame)))

    (next-method)
    
    ;; filler is here to avoid that the label overwrite first widget packed in 
    ;; the labeled frame
    (pack (Id box) :padx 10 :pady 10 :expand #t :fill "both")

    ;; Configure internal windows
    (configure-labeled-frame self box filler lab)

    (slot-set! self 'Id         (slot-ref box 'Id))
    (slot-set! self 'box-frame  box)
    (slot-set! self 'fill-frame filler)
    (slot-set! self 'label      lab)

    ;; Changing the text font must reconfigure the complete bwidget
    (bind lab "<Configure>" (lambda ()
			      (configure-labeled-frame self box filler lab)))))


#|
    Example: A classical Font chooser

	(define lf (make <Labeled-Frame> :title "Font"))
	(pack lf :fill "both" :expand #t :side "left")

	(for-each (lambda (x)
		    (pack (make <Radio-button> :anchor "w" :parent lf 
					       :variable 'font
					       :text x :string-value #f :width 8 
					       :font "fixed" :value x)
			  :fill "x" :expand #f :anchor "w" :side "top"))
		  '("10pt" "12pt" "14pt" "18pt"))


	(define lf2 (make <Labeled-Frame> :title "Type"))
	(pack lf2 :fill "both" :expand #t :side "left")

	(for-each (lambda (x)
		    (pack (make <Radio-button> :anchor "w" :parent lf2 
					       :variable 'type
					       :text x :string-value #f :width 15 
					       :font "fixed" :value x)
			  :fill "x" :expand #f :anchor "w" :side "top"))
		  '("Bold" "Italic" "Normal"))
|#