140 lines
4.1 KiB
Plaintext
140 lines
4.1 KiB
Plaintext
;;;;
|
|
;;;; L f r a m e . s t k l o s -- Labeled Frame composite widget
|
|
;;;;
|
|
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 25-Oct-1996 19:31
|
|
;;;; Last file update: 3-Sep-1999 20:13 (eg)
|
|
|
|
(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 '(Courier -12) :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 '(Courier -12) :value x)
|
|
:fill "x" :expand #f :anchor "w" :side "top"))
|
|
'("Bold" "Italic" "Normal"))
|
|
|#
|