177 lines
6.7 KiB
Plaintext
177 lines
6.7 KiB
Plaintext
;;;; Notepad.stklos -- Notepad widget
|
|
;;;;
|
|
;;;; Copyright © 1997-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: 1-Feb-1997 11:43
|
|
;;;; Last file update: 3-Sep-1999 20:14 (eg)
|
|
|
|
|
|
(require "Tk-classes")
|
|
|
|
(select-module STklos+Tk)
|
|
(export select-tab unselect-tab current-tab)
|
|
|
|
(define-class <Notepad> (<Tk-composite-widget>)
|
|
(%cache ; A small label used to cache the bottom of tabs
|
|
%page ; The frame which contains the page associated to a tab
|
|
%tabs ; All the tabs (first one is a fake one)
|
|
(%current :init-form #f)
|
|
(class :init-keyword :class
|
|
:init-form "Notepad")
|
|
(width :accessor width
|
|
:allocation :propagated
|
|
:propagate-to (%page))
|
|
(height :accessor height
|
|
:allocation :propagated
|
|
:propagate-to (%page))
|
|
(background :accessor background
|
|
:init-keyword :background
|
|
:allocation :virtual
|
|
:slot-ref (lambda (o) (background (slot-ref o '%cache)))
|
|
:slot-set! (lambda (o v)
|
|
(for-each (lambda (x) (slot-set! x 'background v))
|
|
(list* (slot-ref o 'frame)
|
|
(slot-ref o '%cache)
|
|
(slot-ref o '%page)
|
|
(slot-ref o '%tabs)))))
|
|
(foreground :accessor foreground
|
|
:init-keyword :foreground
|
|
:allocation :virtual
|
|
:slot-ref (lambda (o) (foreground (car (slot-ref o '%tabs))))
|
|
:slot-set! (lambda (o v)
|
|
(for-each (lambda (x) (slot-set! x 'foreground v))
|
|
(slot-ref o '%tabs))))))
|
|
|
|
(define-method initialize-composite-widget ((self <Notepad>) initargs frame)
|
|
(let* ((w (get-keyword :width initargs 500))
|
|
(h (get-keyword :height initargs 300))
|
|
(f (make <Frame> :parent frame :border-width 2 :relief "raised"
|
|
:width w :height h))
|
|
(c (make <Frame> :parent frame :border-width 0 :height 4)))
|
|
(pack f :side 'bottom :fill 'both :expand #t)
|
|
(pack 'propagate f #f)
|
|
;; Create a first button in the frame. This button is never mapped but serves
|
|
;; as a prototype for next tabs
|
|
(slot-set! self '%tabs (list (make <Button> :parent frame)))
|
|
(slot-set! self '%cache c)
|
|
(slot-set! self '%page f)
|
|
(slot-set! self 'Id (slot-ref frame 'Id))
|
|
;; Add some space on the left of the frame to have the first button
|
|
;; not directly on the left side of the widget
|
|
; (pack (make <Frame> :width 10 :height 3 :parent self) :side 'left)
|
|
(bind self "<Configure>" (lambda () (place-cache self)))))
|
|
|
|
|
|
(define-method current-tab ((self <Notepad>))
|
|
(slot-ref self '%current))
|
|
|
|
|
|
(define-method place-cache ((self <Notepad>))
|
|
;; Place the cache window (associated to the <Configure> event)
|
|
(let* ((cache (slot-ref self '%cache))
|
|
(current (slot-ref self '%current))
|
|
(bd (border-width current)))
|
|
(update 'idle)
|
|
(place cache :in current :bordermode "inside"
|
|
:x -1 :y (- (winfo 'height current) (* 2 bd))
|
|
:width (- (winfo 'width current) (* 2 bd) -1) :height (+ (* 2 bd) 1))
|
|
(raise cache)))
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Notepad-Tab> class
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Notepad-Tab> (<Button>)
|
|
((action :accessor action :init-form list :init-keyword :action)
|
|
(page :accessor page :init-form #f)))
|
|
|
|
|
|
(define-method initialize ((self <Notepad-Tab>) initargs)
|
|
(let* ((parent (get-keyword :parent initargs #f))
|
|
(current (slot-ref parent '%current)))
|
|
(unless (is-a? parent <Notepad>)
|
|
(error "Parent of tab ~S is not a <Notepad>" self))
|
|
(next-method)
|
|
(slot-set! self 'command (lambda () (select-tab self)))
|
|
(slot-set! self 'active-background (background self))
|
|
(slot-set! self 'highlight-thickness 0)
|
|
(slot-set! parent '%tabs (append (slot-ref parent '%tabs) (list self)))
|
|
(pack self :side 'left :fill 'y)
|
|
( (if current unselect-tab select-tab) self)
|
|
(event 'generate parent "<Configure>"))) ; useful if the pad is bigger
|
|
; than previous ones
|
|
|
|
(define-method unselect-tab ((self <Notepad-Tab>))
|
|
;; Change graphical attributes of unselected tabs
|
|
(pack 'forget (page self))
|
|
(slot-set! self 'relief "sunken")
|
|
(slot-set! self 'foreground (slot-ref self 'disabled-foreground)))
|
|
|
|
|
|
(define-method select-tab ((self <Notepad-Tab>))
|
|
(let* ((parent (slot-ref self 'parent))
|
|
(proto (car (slot-ref parent '%tabs)))
|
|
(current (slot-ref parent '%current)))
|
|
;; Change grapical attributes of selected tabs
|
|
(slot-set! self 'relief "raised")
|
|
(slot-set! self 'foreground (slot-ref proto 'foreground))
|
|
;; Change the current item
|
|
(if (and current (not (eqv? current self)))
|
|
(unselect-tab current))
|
|
(slot-set! parent '%current self)
|
|
(event 'generate parent "<Configure>")
|
|
;; Call the associated action
|
|
((slot-ref self 'action) (slot-ref parent '%page) self)))
|
|
|
|
|
|
(provide "Notepad")
|
|
|
|
#|
|
|
Example:
|
|
|
|
;; Fist define the actions associated to the tab
|
|
;;
|
|
(define (Host parent tab)
|
|
(unless (page tab) ; First call. Create the interface
|
|
(let* ((f (make <Frame> :parent parent :border-width 3
|
|
:background "darkgray" :relief "groove"))
|
|
(b1 (make <Labeled-Entry> :parent f :title "Host: "))
|
|
(b2 (make <Labeled-Entry> :parent f :title "Port: ")))
|
|
(pack b1 b2 :fill 'x :padx 10 :pady 10)
|
|
(set! (page tab) f)))
|
|
(pack (page tab) :padx 10 :pady 10 :fill "both" :expand #t))
|
|
|
|
(define (Mess parent tab)
|
|
(unless (page tab) ; First call. Create the interface
|
|
(let ((m (make <Message> :parent parent :border-width 3
|
|
:relief "groove" :background "darkgray" :aspect 300
|
|
:justify "center" :font "10x20"
|
|
:text "This is a simple demonstration.")))
|
|
(pack m :expand #t :fill "both")
|
|
(set! (page tab) m)))
|
|
(pack (page tab) :padx 10 :pady 10 :fill "both" :expand #t))
|
|
|
|
|
|
;; Let's go
|
|
;;
|
|
(define f (make <NotePad> :width 450 :height 150))
|
|
(pack f :expand #t :fill "both" :padx 2 :pady 2)
|
|
|
|
(make <Notepad-Tab> :parent f :text "host1" :action Host)
|
|
(make <Notepad-Tab> :parent f :text "host2" :action Host)
|
|
(make <Notepad-Tab> :parent f :text "Multi-line\nlabel" :action Mess)
|
|
(make <Notepad-Tab> :parent f :bitmap "questhead" :width 30 :action Host)
|
|
|#
|