You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
394 lines
12 KiB
Tcl
394 lines
12 KiB
Tcl
#!/bin/sh
|
|
# the next line restarts using wish \
|
|
exec wish "$0" "$@"
|
|
|
|
# widget --
|
|
# This script demonstrates the various widgets provided by Tk,
|
|
# along with many of the features of the Tk toolkit. This file
|
|
# only contains code to generate the main window for the
|
|
# application, which invokes individual demonstrations. The
|
|
# code for the actual demonstrations is contained in separate
|
|
# ".tcl" files is this directory, which are sourced by this script
|
|
# as needed.
|
|
#
|
|
# RCS: @(#) $Id: widget,v 1.8 2002/08/31 06:12:28 das Exp $
|
|
|
|
eval destroy [winfo child .]
|
|
wm title . "Widget Demonstration"
|
|
if {$tcl_platform(platform) eq "unix"} {
|
|
# This won't work everywhere, but there's no other way in core Tk
|
|
# at the moment to display a coloured icon.
|
|
image create photo TclPowered \
|
|
-file [file join $tk_library images logo64.gif]
|
|
wm iconwindow . [toplevel ._iconWindow]
|
|
pack [label ._iconWindow.i -image TclPowered]
|
|
wm iconname . "tkWidgetDemo"
|
|
}
|
|
|
|
array set widgetFont {
|
|
main {Helvetica 12}
|
|
bold {Helvetica 12 bold}
|
|
title {Helvetica 18 bold}
|
|
status {Helvetica 10}
|
|
vars {Helvetica 14}
|
|
}
|
|
|
|
set widgetDemo 1
|
|
set font $widgetFont(main)
|
|
|
|
#----------------------------------------------------------------
|
|
# The code below create the main window, consisting of a menu bar
|
|
# and a text widget that explains how to use the program, plus lists
|
|
# all of the demos as hypertext items.
|
|
#----------------------------------------------------------------
|
|
|
|
menu .menuBar -tearoff 0
|
|
.menuBar add cascade -menu .menuBar.file -label "File" -underline 0
|
|
menu .menuBar.file -tearoff 0
|
|
|
|
# On the Mac use the specia .apple menu for the about item
|
|
if {[string equal [tk windowingsystem] "classic"]} {
|
|
.menuBar add cascade -menu .menuBar.apple
|
|
menu .menuBar.apple -tearoff 0
|
|
.menuBar.apple add command -label "About..." -command "aboutBox"
|
|
} else {
|
|
.menuBar.file add command -label "About..." -command "aboutBox" \
|
|
-underline 0 -accelerator "<F1>"
|
|
.menuBar.file add sep
|
|
}
|
|
|
|
.menuBar.file add command -label "Quit" -command "exit" -underline 0 \
|
|
-accelerator "Meta-Q"
|
|
. configure -menu .menuBar
|
|
bind . <F1> aboutBox
|
|
|
|
frame .statusBar
|
|
label .statusBar.lab -text " " -relief sunken -bd 1 \
|
|
-font $widgetFont(status) -anchor w
|
|
label .statusBar.foo -width 8 -relief sunken -bd 1 \
|
|
-font $widgetFont(status) -anchor w
|
|
pack .statusBar.lab -side left -padx 2 -expand yes -fill both
|
|
pack .statusBar.foo -side left -padx 2
|
|
pack .statusBar -side bottom -fill x -pady 2
|
|
|
|
frame .textFrame
|
|
scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \
|
|
-takefocus 1
|
|
pack .s -in .textFrame -side right -fill y
|
|
text .t -yscrollcommand {.s set} -wrap word -width 70 -height 30 \
|
|
-font $widgetFont(main) -setgrid 1 -highlightthickness 0 \
|
|
-padx 4 -pady 2 -takefocus 0
|
|
pack .t -in .textFrame -expand y -fill both -padx 1
|
|
pack .textFrame -expand yes -fill both
|
|
|
|
# Create a bunch of tags to use in the text widget, such as those for
|
|
# section titles and demo descriptions. Also define the bindings for
|
|
# tags.
|
|
|
|
.t tag configure title -font $widgetFont(title)
|
|
.t tag configure bold -font $widgetFont(bold)
|
|
|
|
# We put some "space" characters to the left and right of each demo description
|
|
# so that the descriptions are highlighted only when the mouse cursor
|
|
# is right over them (but not when the cursor is to their left or right)
|
|
#
|
|
.t tag configure demospace -lmargin1 1c -lmargin2 1c
|
|
|
|
|
|
if {[winfo depth .] == 1} {
|
|
.t tag configure demo -lmargin1 1c -lmargin2 1c \
|
|
-underline 1
|
|
.t tag configure visited -lmargin1 1c -lmargin2 1c \
|
|
-underline 1
|
|
.t tag configure hot -background black -foreground white
|
|
} else {
|
|
.t tag configure demo -lmargin1 1c -lmargin2 1c \
|
|
-foreground blue -underline 1
|
|
.t tag configure visited -lmargin1 1c -lmargin2 1c \
|
|
-foreground #303080 -underline 1
|
|
.t tag configure hot -foreground red -underline 1
|
|
}
|
|
.t tag bind demo <ButtonRelease-1> {
|
|
invoke [.t index {@%x,%y}]
|
|
}
|
|
set lastLine ""
|
|
.t tag bind demo <Enter> {
|
|
set lastLine [.t index {@%x,%y linestart}]
|
|
.t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars"
|
|
.t config -cursor hand2
|
|
showStatus [.t index {@%x,%y}]
|
|
}
|
|
.t tag bind demo <Leave> {
|
|
.t tag remove hot 1.0 end
|
|
.t config -cursor xterm
|
|
.statusBar.lab config -text ""
|
|
}
|
|
.t tag bind demo <Motion> {
|
|
set newLine [.t index {@%x,%y linestart}]
|
|
if {[string compare $newLine $lastLine] != 0} {
|
|
.t tag remove hot 1.0 end
|
|
set lastLine $newLine
|
|
|
|
set tags [.t tag names {@%x,%y}]
|
|
set i [lsearch -glob $tags demo-*]
|
|
if {$i >= 0} {
|
|
.t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars"
|
|
}
|
|
}
|
|
showStatus [.t index {@%x,%y}]
|
|
}
|
|
|
|
# Create the text for the text widget.
|
|
|
|
proc addDemoSection {title demos} {
|
|
.t insert end "\n" {} $title title " \n " demospace
|
|
set num 0
|
|
foreach {name description} $demos {
|
|
.t insert end "[incr num]. $description." [list demo demo-$name]
|
|
.t insert end " \n " demospace
|
|
}
|
|
}
|
|
|
|
.t insert end "Tk Widget Demonstrations\n" title
|
|
.t insert end "\nThis application provides a front end for several short\
|
|
scripts that demonstrate what you can do with Tk widgets. Each of\
|
|
the numbered lines below describes a demonstration; you can click\
|
|
on it to invoke the demonstration. Once the demonstration window\
|
|
appears, you can click the " {} "See Code" bold " button to see the\
|
|
Tcl/Tk code that created the demonstration. If you wish, you can\
|
|
edit the code and click the " {} "Rerun Demo" bold " button in the\
|
|
code window to reinvoke the demonstration with the modified code.\n"
|
|
|
|
addDemoSection "Labels, buttons, checkbuttons, and radiobuttons" {
|
|
label "Labels (text and bitmaps)"
|
|
button "Buttons"
|
|
check "Check-buttons (select any of a group)"
|
|
radio "Radio-buttons (select one of a group)"
|
|
puzzle "A 15-puzzle game made out of buttons"
|
|
icon "Iconic buttons that use bitmaps"
|
|
image1 "Two labels displaying images"
|
|
image2 "A simple user interface for viewing images"
|
|
labelframe "Labelled frames"
|
|
}
|
|
addDemoSection "Listboxes" {
|
|
states "The 50 states"
|
|
colors "Colors: change the color scheme for the application"
|
|
sayings "A collection of famous and infamous sayings"
|
|
}
|
|
addDemoSection "Entries and Spin-boxes" {
|
|
entry1 "Entries without scrollbars"
|
|
entry2 "Entries with scrollbars"
|
|
entry3 "Validated entries and password fields"
|
|
spin "Spin-boxes"
|
|
form "Simple Rolodex-like form"
|
|
}
|
|
addDemoSection "Text" {
|
|
text "Basic editable text"
|
|
style "Text display styles"
|
|
bind "Hypertext (tag bindings)"
|
|
twind "A text widget with embedded windows"
|
|
search "A search tool built with a text widget"
|
|
}
|
|
addDemoSection "Canvases" {
|
|
items "The canvas item types"
|
|
plot "A simple 2-D plot"
|
|
ctext "Text items in canvases"
|
|
arrow "An editor for arrowheads on canvas lines"
|
|
ruler "A ruler with adjustable tab stops"
|
|
floor "A building floor plan"
|
|
cscroll "A simple scrollable canvas"
|
|
}
|
|
addDemoSection "Scales" {
|
|
hscale "Horizontal scale"
|
|
vscale "Vertical scale"
|
|
}
|
|
addDemoSection "Paned Windows" {
|
|
paned1 "Horizontal paned window"
|
|
paned2 "Vertical paned window"
|
|
}
|
|
addDemoSection "Menus" {
|
|
menu "Menus and cascades (sub-menus)"
|
|
menubu "Menu-buttons"
|
|
}
|
|
addDemoSection "Common Dialogs" {
|
|
msgbox "Message boxes"
|
|
filebox "File selection dialog"
|
|
clrpick "Color picker"
|
|
}
|
|
addDemoSection "Miscellaneous" {
|
|
bitmap "The built-in bitmaps"
|
|
dialog1 "A dialog box with a local grab"
|
|
dialog2 "A dialog box with a global grab"
|
|
}
|
|
|
|
.t configure -state disabled
|
|
focus .s
|
|
|
|
# positionWindow --
|
|
# This procedure is invoked by most of the demos to position a
|
|
# new demo window.
|
|
#
|
|
# Arguments:
|
|
# w - The name of the window to position.
|
|
|
|
proc positionWindow w {
|
|
wm geometry $w +300+300
|
|
}
|
|
|
|
# showVars --
|
|
# Displays the values of one or more variables in a window, and
|
|
# updates the display whenever any of the variables changes.
|
|
#
|
|
# Arguments:
|
|
# w - Name of new window to create for display.
|
|
# args - Any number of names of variables.
|
|
|
|
proc showVars {w args} {
|
|
global widgetFont
|
|
catch {destroy $w}
|
|
toplevel $w
|
|
wm title $w "Variable values"
|
|
label $w.title -text "Variable values:" -width 20 -anchor center \
|
|
-font $widgetFont(vars)
|
|
pack $w.title -side top -fill x
|
|
set len 1
|
|
foreach i $args {
|
|
if {[string length $i] > $len} {
|
|
set len [string length $i]
|
|
}
|
|
}
|
|
foreach i $args {
|
|
frame $w.$i
|
|
label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w
|
|
label $w.$i.value -textvar $i -anchor w
|
|
pack $w.$i.name -side left
|
|
pack $w.$i.value -side left -expand 1 -fill x
|
|
pack $w.$i -side top -anchor w -fill x
|
|
}
|
|
button $w.ok -text OK -command "destroy $w" -default active
|
|
bind $w <Return> "tkButtonInvoke $w.ok"
|
|
pack $w.ok -side bottom -pady 2
|
|
}
|
|
|
|
# invoke --
|
|
# This procedure is called when the user clicks on a demo description.
|
|
# It is responsible for invoking the demonstration.
|
|
#
|
|
# Arguments:
|
|
# index - The index of the character that the user clicked on.
|
|
|
|
proc invoke index {
|
|
global tk_library
|
|
set tags [.t tag names $index]
|
|
set i [lsearch -glob $tags demo-*]
|
|
if {$i < 0} {
|
|
return
|
|
}
|
|
set cursor [.t cget -cursor]
|
|
.t configure -cursor watch
|
|
update
|
|
set demo [string range [lindex $tags $i] 5 end]
|
|
uplevel [list source [file join $tk_library demos $demo.tcl]]
|
|
update
|
|
.t configure -cursor $cursor
|
|
|
|
.t tag add visited "$index linestart +1 chars" "$index lineend -1 chars"
|
|
}
|
|
|
|
# showStatus --
|
|
#
|
|
# Show the name of the demo program in the status bar. This procedure
|
|
# is called when the user moves the cursor over a demo description.
|
|
#
|
|
proc showStatus index {
|
|
global tk_library
|
|
set tags [.t tag names $index]
|
|
set i [lsearch -glob $tags demo-*]
|
|
set cursor [.t cget -cursor]
|
|
if {$i < 0} {
|
|
.statusBar.lab config -text " "
|
|
set newcursor xterm
|
|
} else {
|
|
set demo [string range [lindex $tags $i] 5 end]
|
|
.statusBar.lab config -text "Run the \"$demo\" sample program"
|
|
set newcursor hand2
|
|
}
|
|
if [string compare $cursor $newcursor] {
|
|
.t config -cursor $newcursor
|
|
}
|
|
}
|
|
|
|
|
|
# showCode --
|
|
# This procedure creates a toplevel window that displays the code for
|
|
# a demonstration and allows it to be edited and reinvoked.
|
|
#
|
|
# Arguments:
|
|
# w - The name of the demonstration's window, which can be
|
|
# used to derive the name of the file containing its code.
|
|
|
|
proc showCode w {
|
|
global tk_library
|
|
set file [string range $w 1 end].tcl
|
|
if ![winfo exists .code] {
|
|
toplevel .code
|
|
frame .code.buttons
|
|
pack .code.buttons -side bottom -fill x
|
|
button .code.buttons.dismiss -text Dismiss \
|
|
-default active -command "destroy .code"
|
|
button .code.buttons.rerun -text "Rerun Demo" -command {
|
|
eval [.code.text get 1.0 end]
|
|
}
|
|
pack .code.buttons.dismiss .code.buttons.rerun -side left \
|
|
-expand 1 -pady 2
|
|
frame .code.frame
|
|
pack .code.frame -expand yes -fill both -padx 1 -pady 1
|
|
text .code.text -height 40 -wrap word\
|
|
-xscrollcommand ".code.xscroll set" \
|
|
-yscrollcommand ".code.yscroll set" \
|
|
-setgrid 1 -highlightthickness 0 -pady 2 -padx 3
|
|
scrollbar .code.xscroll -command ".code.text xview" \
|
|
-highlightthickness 0 -orient horizontal
|
|
scrollbar .code.yscroll -command ".code.text yview" \
|
|
-highlightthickness 0 -orient vertical
|
|
|
|
grid .code.text -in .code.frame -padx 1 -pady 1 \
|
|
-row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
|
|
grid .code.yscroll -in .code.frame -padx 1 -pady 1 \
|
|
-row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
|
|
# grid .code.xscroll -in .code.frame -padx 1 -pady 1 \
|
|
# -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
|
|
grid rowconfig .code.frame 0 -weight 1 -minsize 0
|
|
grid columnconfig .code.frame 0 -weight 1 -minsize 0
|
|
} else {
|
|
wm deiconify .code
|
|
raise .code
|
|
}
|
|
wm title .code "Demo code: [file join $tk_library demos $file]"
|
|
wm iconname .code $file
|
|
set id [open [file join $tk_library demos $file]]
|
|
.code.text delete 1.0 end
|
|
.code.text insert 1.0 [read $id]
|
|
.code.text mark set insert 1.0
|
|
close $id
|
|
}
|
|
|
|
# aboutBox --
|
|
#
|
|
# Pops up a message box with an "about" message
|
|
#
|
|
proc aboutBox {} {
|
|
tk_messageBox -icon info -type ok -title "About Widget Demo" -message \
|
|
"Tk widget demonstration
|
|
|
|
Copyright (c) 1996-1997 Sun Microsystems, Inc.
|
|
|
|
Copyright (c) 1997-2000 Ajuba Solutions, Inc.
|
|
|
|
Copyright (c) 2001-2002 Donal K. Fellows"
|
|
}
|
|
|
|
# Local Variables:
|
|
# mode: tcl
|
|
# End:
|