;;;; butbar.stk -- Button bar management ;;;; ;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; 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: butbar.stk 1.3 Fri, 22 Jan 1999 14:44:12 +0100 eg $ ;;;; ;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Creation date: 8-Dec-1998 18:58 ;;;; Last file update: 22-Jan-1999 14:22 (require "balloon") (select-module Tk) (export make-bordered-frame make-button-bar) ;;; ;;; Button-bar default bindings ;;; (bind "ButtonBar" "" (lambda (|W|) (tk-set! |W| :relief "raised"))) (bind "ButtonBar" "" (lambda (|W|) (tk-set! |W| :relief "flat"))) ;============================================================================= ; ; bordered-frame functions ; ;============================================================================= (define (hide-bordered-frame parent) (let* ((info (pack 'info parent)) (grand-pa (winfo 'parent parent)) (b (button (& grand-pa ".hb") :image (make-image "hborder.gif")))) (tk-set! b :command (lambda () (pack 'unpack b) (apply pack parent (cddr info)) (destroy b))) (pack 'unpack parent) (pack b :side "left"))) (define (make-bordered-frame parent) (let* ((f (frame (gensym (& parent ".border") :relief "ridge" :bd 1))) (b (button (& f ".b") :image (make-image "border.gif") :bd 1 :relief "ridge" :command (lambda () (hide-bordered-frame f))))) (pack b :side "left" :fill 'y) (pack f :fill 'x) f)) ;============================================================================= ; ; make-button-bar ; ;============================================================================= (define (make-button-bar parent l) (define (make-button parent img balloon action) (let* ((name (gensym (& parent ".b"))) (but (button name :image (make-image img) :relief "flat" :comm action))) (pack but :side "left" :fill "both") (add-balloon-help but balloon 1500 "#ffffb0") (bindtags but (cons "ButtonBar" (bindtags but))))) (define (make-space parent size) (let ((name (gensym (& parent ".f")))) (pack (frame name :width size) :side "left" :fill "both"))) ;; make-button-bar starts here (let ((f (make-bordered-frame parent))) (for-each (lambda (x) (if (integer? x) (make-space f x) (apply make-button f x))) l) f)) (provide "butbar")