421 lines
13 KiB
Plaintext
421 lines
13 KiB
Plaintext
;;;;
|
|
;;;; T o o l b a r . s t k l o s -- Tool bar management
|
|
;;;;
|
|
;;;; Copyright © 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: 06-May-1999 15:08
|
|
;;;; Last file update: 3-Sep-1999 20:15 (eg)
|
|
;;;;
|
|
|
|
|
|
(require "Basics")
|
|
(require "palette")
|
|
(require "balloon")
|
|
|
|
(select-module STklos+Tk)
|
|
|
|
(export make-toolbar default-release-toolbar toolbar-item)
|
|
|
|
|
|
#|
|
|
FIXME: ° resources are not taken into account. Why?
|
|
|#
|
|
|
|
;;;
|
|
;;; Resources
|
|
;;;
|
|
;(option 'add "*ToolBar*Relief" "ridge" "widgetDefault")
|
|
;(option 'add "*ToolBar*BorderWidth" "1" "widgetDefault")
|
|
|
|
|
|
;;;
|
|
;;; Tool-bar default bindings
|
|
;;;
|
|
(bind "ToolBar" "<Enter>" (lambda (|W|) (tk-set! |W| :relief "raised")))
|
|
(bind "ToolBar" "<Leave>" (lambda (|W|) (tk-set! |W| :relief "flat")))
|
|
|
|
;=============================================================================
|
|
;
|
|
; Class <Toolbar>
|
|
;
|
|
;=============================================================================
|
|
(define-class <Toolbar> (<Frame>)
|
|
((%handle :init-form #f)
|
|
(%float :init-form #f)
|
|
(%clone :init-form #f)
|
|
(%components :init-form '())
|
|
(class :init-keyword :class
|
|
:init-form "ToolBar")
|
|
(orientation :init-form "horizontal"
|
|
:accessor orientation
|
|
:init-keyword :orientation)
|
|
(balloon-color :init-keyword :balloon-color ; Not settable by resources!!
|
|
:init-form "#ffffb0")
|
|
(press-command :init-form #f
|
|
:accessor press-command
|
|
:init-keyword :press-command)
|
|
(release-command :init-form #f
|
|
:accessor release-command
|
|
:init-keyword :release-command)))
|
|
|
|
|
|
|
|
(define-method initialize ((self <Toolbar>) initargs)
|
|
(next-method)
|
|
;; Create the handle to detach the tool bar
|
|
(let ((h (make <Label> :relief "ridge" :border-width 1 :parent self
|
|
:width 5 :height 5
|
|
:background (background self))))
|
|
(bind h "<ButtonPress-1>" (lambda (|X| |Y|) (clone-toolbar self |X| |Y|)))
|
|
(slot-set! self '%handle h)))
|
|
|
|
;=============================================================================
|
|
;
|
|
; <Toolbar> methods
|
|
;
|
|
;=============================================================================
|
|
|
|
;;;;
|
|
;;;; ==== Toolbar components constructors ====
|
|
;;;;
|
|
|
|
;;
|
|
;; add-button
|
|
;;
|
|
(define-method add-button((self <Toolbar>) img balloon action)
|
|
(let* ((bg (slot-ref self 'background))
|
|
(b (make <Button> :parent self :image (make-image img)
|
|
:relief "flat" :command action :highlight-thickness 0
|
|
:background bg :active-background bg)))
|
|
;; Add help ballon
|
|
(add-balloon-help (Id b) balloon 1500 (slot-ref self 'balloon-color))
|
|
;; Change button bindings to add a relief when entering it
|
|
(bindtags b (cons "ToolBar" (bindtags b)))
|
|
(slot-set! self '%components
|
|
(append (slot-ref self '%components)
|
|
(list (cons b (list img balloon action)))))
|
|
b))
|
|
|
|
;;
|
|
;; add-menubutton
|
|
;;
|
|
(define-method add-menubutton((self <Toolbar>) title)
|
|
(let* ((bg (slot-ref self 'background))
|
|
(mb (make <Menu-button> :parent self :text title
|
|
:background bg :active-background (make-lighter-color bg))))
|
|
(slot-set! self '%components
|
|
(append (slot-ref self '%components) (list (cons mb title))))
|
|
mb))
|
|
|
|
|
|
;;
|
|
;; add-space
|
|
;;
|
|
(define-method add-space ((self <Toolbar>) space)
|
|
(let ((f (make <Frame> :parent self :background (background self))))
|
|
;; Add the new frame to the list of components of the menu bar
|
|
(slot-set! self '%components
|
|
(append (slot-ref self '%components) (list (cons f space))))
|
|
f))
|
|
|
|
;;
|
|
;; toolbar-item
|
|
;;
|
|
(define-method toolbar-item ((self <Toolbar>) index)
|
|
(let ((l (slot-ref self '%components)))
|
|
(if (< index (length l))
|
|
(car (list-ref l index))
|
|
(error "toolbar-item: bad index ~S" index))))
|
|
|
|
|
|
;=============================================================================
|
|
|
|
;;;;
|
|
;;;; ==== map-toolbar ====
|
|
;;;;
|
|
;;;; This procedure is in charge of packing the components of the
|
|
;;;; toolbar. The arrangement depends of the orientation of the toolbar.
|
|
;;;;
|
|
(define-method map-toolbar ((self <toolbar>) orientation)
|
|
(let ((handle (slot-ref self '%handle))
|
|
(all (slot-ref self '%components))
|
|
(vertical? (equal? orientation "vertical"))
|
|
(set-width! (lambda (w size)
|
|
(when (zero? size)
|
|
; This is a filler (expand in x even if vertival)
|
|
(pack w :expand #t :fill 'x))
|
|
(slot-set! w 'width size))))
|
|
(if vertical?
|
|
;; Arrangement is vertical
|
|
(begin
|
|
(slot-set! handle 'image (make-image "tb_hborder.gif"))
|
|
(pack handle :side 'top :fill 'x)
|
|
(for-each (lambda (x)
|
|
(let ((w (car x)))
|
|
(pack w :side 'top :fill 'x)
|
|
(if (is-a? w <Frame>)
|
|
(set-width! w (cdr x)))))
|
|
all))
|
|
;; Arrangement is horizontal
|
|
(begin
|
|
(slot-set! handle 'image (make-image "tb_vborder.gif"))
|
|
(pack handle :side 'left :fill 'y)
|
|
(for-each (lambda (x)
|
|
(let ((w (car x)))
|
|
(pack w :side 'left :fill 'y)
|
|
(if (is-a? w <Frame>)
|
|
(set-width! w (cdr x)))))
|
|
all)))))
|
|
|
|
|
|
;=============================================================================
|
|
|
|
;;;;
|
|
;;;; ==== clone-toolbar ====
|
|
;;;;
|
|
|
|
|
|
;;
|
|
;; clone-widget method for toolbars
|
|
;;
|
|
(define-method clone-widget ((self <Toolbar>) new-parent)
|
|
(let ((my-clone (next-method)))
|
|
;; Clone all the components of this original button bar
|
|
(slot-set! my-clone '%components '())
|
|
(for-each (lambda (x)
|
|
(let ((w (car x)))
|
|
(cond
|
|
((is-a? w <Button>) (apply add-button my-clone (cdr x)))
|
|
((is-a? w <Menu-button>)
|
|
(let ((new (add-menubutton my-clone (cdr x)))
|
|
(m (menu-of w)))
|
|
;; Clone the associated menu
|
|
(slot-set! new 'menu (clone-widget m new))))
|
|
((is-a? w <Frame>)
|
|
(let ((new (add-space my-clone (cdr x))))
|
|
(unless (null? (children w))
|
|
(pack (clone-widget (car (children w)) new))))))))
|
|
(slot-ref self '%components))
|
|
my-clone))
|
|
|
|
|
|
;;
|
|
;; clone-toolbar itself
|
|
;;
|
|
(define-method clone-toolbar ((self <Toolbar>) X Y)
|
|
;;
|
|
;; Create-floating-toolbar
|
|
;;
|
|
(define (create-floating-toolbar tb)
|
|
(let* ((t (make <Toplevel> :parent tb :border-width 2 :relief "solid"))
|
|
(clone (clone-widget tb t))
|
|
(handle (slot-ref clone '%handle)))
|
|
(pack clone)
|
|
(make-transient t)
|
|
;; Associate bindings to the toolbar handle
|
|
(bind handle "<ButtonRelease-1>"
|
|
(lambda (|X| |Y|)
|
|
(let ((action (slot-ref self 'release-command)))
|
|
(if (procedure? action)
|
|
(let ((res (action self |X| |Y|)))
|
|
(if res
|
|
;; Delete the floating toolbar
|
|
(wm 'withdraw t))))
|
|
(map-toolbar tb (slot-ref self 'orientation))
|
|
(grab 'release handle))))
|
|
|
|
(bind handle "<ButtonPress-1>"
|
|
(lambda () (grab :global handle)))
|
|
|
|
(bind handle "<Button1-Motion>"
|
|
(lambda (|X| |Y|)
|
|
(wm 'geometry t (format #f "+~A+~A" (- |X| 3) (- |Y| 3)))))
|
|
|
|
(slot-set! self '%float t)
|
|
(slot-set! self '%clone clone)
|
|
t))
|
|
;;
|
|
;; ==== clone-button-bar starts here ====
|
|
;;
|
|
(let* ((action (slot-ref self 'press-command))
|
|
(do-action (if (procedure? action) (action self X Y) #t)))
|
|
(when do-action
|
|
(let ((ftb (or (slot-ref self '%float) (create-floating-toolbar self))))
|
|
(pack 'forget self)
|
|
(let ((handle (slot-ref (slot-ref self '%clone) '%handle)))
|
|
(wm 'geometry ftb (format #f "+~A+~A"
|
|
(- (winfo 'pointerx handle) 3)
|
|
(- (winfo 'pointery handle) 3)))
|
|
(map-toolbar (slot-ref self '%clone) (slot-ref self 'orientation))
|
|
(deiconify ftb)
|
|
(update)
|
|
(grab :global handle))))))
|
|
|
|
;=============================================================================
|
|
|
|
;;;;
|
|
;;;; ==== Make-toolbar ====
|
|
;;;;
|
|
;;;; A simpler way to make toolbars: In fact this is intended to be
|
|
;;;; the only entry point for end-users
|
|
;;;;
|
|
|
|
(define (make-toolbar parent l . options)
|
|
;;
|
|
;; Predicates for testing the type of the items of a description
|
|
;;
|
|
(define (image? l) (and (list? l) (= (length l) 3) (procedure? (caddr l))))
|
|
(define space? integer?)
|
|
(define menu? list?)
|
|
|
|
;;
|
|
;; make-submenu
|
|
;;
|
|
(define (make-submenu tb mb items)
|
|
(let* ((bg (background tb))
|
|
(m (make <Menu> :parent mb :tear-off #f
|
|
:background bg :active-background bg)))
|
|
(for-each (lambda (item)
|
|
(cond
|
|
;; Tear-off
|
|
((equal? (car item) "---")
|
|
(slot-set! m 'tear-off #t))
|
|
;; Separator
|
|
((equal? (car item) "")
|
|
(menu-add m 'separator))
|
|
;; Normal Menu
|
|
((and (= (length item) 2) (procedure? (cadr item)))
|
|
(menu-add m 'command :label (car item)
|
|
:command (cadr item)))
|
|
;; Cascade menu
|
|
((and (>= (length item) 2) (list? (cadr item)))
|
|
(menu-add m 'cascade :label (car item)
|
|
:menu (make-submenu tb m (cdr item))))
|
|
(else (apply menu-add m item))))
|
|
items)
|
|
m))
|
|
|
|
;;
|
|
;; make-item
|
|
;;
|
|
(define (make-item tb item)
|
|
(cond
|
|
((image? item) (apply add-button tb item))
|
|
((space? item) (add-space tb item))
|
|
((menu? l) (let ((mb (add-menubutton tb (car item))))
|
|
(make-submenu tb mb (cdr item))))
|
|
(else (error "make-toolbar: bad item specification ~S" item))))
|
|
|
|
;;
|
|
;; code of make-toolbar starts here
|
|
;;
|
|
(let ((tb (apply make <toolbar> :parent parent options)))
|
|
(for-each (lambda (x) (make-item tb x)) l) ; Create the items
|
|
(map-toolbar tb (slot-ref tb 'orientation)) ; map them and
|
|
tb)) ; return the new toolbar
|
|
|
|
|
|
|
|
;=============================================================================
|
|
|
|
(define (default-release-toolbar master)
|
|
(lambda (toolbar x y)
|
|
(let* ((x1 (- (winfo 'rootx master) 20))
|
|
(y1 (- (winfo 'rooty master) 20))
|
|
(x2 (+ x1 (winfo 'width master) 40))
|
|
(y2 (+ y1 (winfo 'height master) 40)))
|
|
(and (<= x1 x x2)
|
|
(<= y1 y y2)
|
|
(cond
|
|
((<= y1 y (+ y1 40)) ;; Place on top
|
|
(slot-set! toolbar 'orientation "horizontal")
|
|
(pack toolbar :before master :fill 'x :side 'top)
|
|
#t)
|
|
((<= (- y2 40) y y2) ;; Place on bottom
|
|
(slot-set! toolbar 'orientation "horizontal")
|
|
(pack toolbar :before master :fill 'x :side 'bottom)
|
|
#t)
|
|
((<= x1 x (+ x1 40)) ;; place on left
|
|
(slot-set! toolbar 'orientation "vertical")
|
|
(pack toolbar :before master :fill 'y :side 'left)
|
|
#t)
|
|
((<= (- x2 40) x x2) ;; Place on right
|
|
(slot-set! toolbar 'orientation "vertical")
|
|
(pack toolbar :before master :fill 'y :side 'right)
|
|
#t)
|
|
(else #f))))))
|
|
|
|
|
|
#|
|
|
Example: This could seem rather complicated but I think it is fairly
|
|
exhaustive of what is possible with floating toolbars
|
|
|
|
(define-macro (P x) ; A macro for printing traces (for this demo)
|
|
`(lambda () (display ,x) (newline)))
|
|
|
|
(define top (make <toplevel> :title "Toolbar Demo"))
|
|
(define st (make <Scroll-Text> :parent top :font '(Helvetica 18 bold)
|
|
:width 48 :height 12
|
|
:value (& "\n\n\n"
|
|
"\tTo re-attach a detached toolbar, drag it on\n"
|
|
"\tone of the 4 sides of this text editor")))
|
|
(define action (default-release-toolbar st))
|
|
|
|
(define f1
|
|
(make-toolbar *top-root*
|
|
`(("File"
|
|
("---") ;; we want a tear-off
|
|
("Open" ,(P "Open"))
|
|
("Close" ,(P "Close"))
|
|
("") ;; insert a separator
|
|
("Exit" ,(lambda() (exit 0))))
|
|
("Edit"
|
|
("Cut" ,(P "Cut"))
|
|
("Copy" ,(P "Copy"))
|
|
("Paste" ,(P "Paste"))
|
|
("Submenu" ;; a submenu without tear-off
|
|
("sub1" ,(P "sub1"))
|
|
("sub2" ,(P "sub2")))
|
|
;; a completely managed item
|
|
(radiobutton :label "Foo" :foreground "blue3")
|
|
(radiobutton :label "Bar" :foreground "blue3"))
|
|
0
|
|
("Help"
|
|
("About" ,(P "About"))))
|
|
:parent top :background "Bisque3" :release-command action))
|
|
|
|
(define f2
|
|
(make-toolbar *top-root*
|
|
`(("tb_console.gif" "Open New Console" ,(P 1))
|
|
("tb_edit.gif" "Open New Editor" ,(P 2))
|
|
("tb_customize.gif" "Customize Environment" ,(P 3))
|
|
20 ; insert a 20 pixels wide space
|
|
("tb_fileopen.gif" "Load File" ,(P 4)))
|
|
:parent top :background "Bisque4" :release-command action))
|
|
|
|
(define f3
|
|
(make-toolbar *top-root*
|
|
`(("tb_copy.gif" "Copy" ,(P 5))
|
|
("tb_paste.gif" "Paste" ,(P 6))
|
|
("tb_cut.gif" "Cut" ,(P 7))
|
|
20
|
|
("tb_info.gif" "Help on Console" , (P 8)))
|
|
:parent top :background "Wheat2" :release-command action
|
|
:orientation "vertical"))
|
|
|
|
(pack f1 f2 :side "top" :fill 'x)
|
|
(pack f3 :side "left" :fill 'y)
|
|
(pack st :fill 'both :expand #t :side "bottom")
|
|
|
|
|#
|