141 lines
4.2 KiB
Plaintext
141 lines
4.2 KiB
Plaintext
|
;;;;
|
|||
|
|
;;;; L f r a m e . s t k l o s -- Labeled Frame 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: Lframe.stklos 1.2 Sun, 01 Feb 1998 23:14:16 +0100 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"))
|
|||
|
|
|#
|