#!/bin/sh
# the next line restarts using wish \
exec wish "$0" ${1+"$@"}
# 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.
package require tk 8.7-
package require msgcat
destroy {*}[winfo children .]
set tk_demoDirectory [file join [pwd] [file dirname [info script]]]
::msgcat::mcload $tk_demoDirectory
namespace import ::msgcat::mc
wm title . [mc "Widget Demonstration"]
if {[tk windowingsystem] eq "x11"} {
# 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 . [mc "tkWidgetDemo"]
}
if {"defaultFont" ni [font names]} {
# TIP #145 defines some standard named fonts
if {"TkDefaultFont" in [font names] && "TkFixedFont" in [font names]} {
# FIX ME: the following technique of cloning the font to copy it works
# fine but means that if the system font is changed by Tk
# cannot update the copied font. font alias might be useful
# here -- or fix the app to use TkDefaultFont etc.
font create mainFont {*}[font configure TkDefaultFont]
font create fixedFont {*}[font configure TkFixedFont]
font create boldFont {*}[font configure TkDefaultFont] -weight bold
font create titleFont {*}[font configure TkDefaultFont] -weight bold
font create statusFont {*}[font configure TkDefaultFont]
font create varsFont {*}[font configure TkDefaultFont]
if {[tk windowingsystem] eq "aqua"} {
font configure titleFont -size 17
}
} else {
font create mainFont -family Helvetica -size 12
font create fixedFont -family Courier -size 10
font create boldFont -family Helvetica -size 12 -weight bold
font create titleFont -family Helvetica -size 18 -weight bold
font create statusFont -family Helvetica -size 10
font create varsFont -family Helvetica -size 14
}
}
set widgetDemo 1
set font mainFont
# The SVG images used below are based on some icons provided by the
# official open source SVG icon library for the Bootstrap project,
# licensed under the MIT license (https://opensource.org/licenses/MIT).
#
# See https://github.com/twbs/icons.
set viewData {
}
set refreshData {
}
set printData {
}
proc images {arg} {
set fgColor [ttk::style lookup . -foreground {} black]
lassign [winfo rgb . $fgColor] r g b
set fgColor [format "#%02x%02x%02x" \
[expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}]]
foreach action {view refresh print} {
upvar ${action}Data imgData
for {set data $imgData; set startIdx 0} \
{[set idx1 [string first "#000000" $data $startIdx]] >= 0} \
{set startIdx [expr {$idx1 + 7}]} {
set idx2 [expr {$idx1 + 6}]
set data [string replace $data $idx1 $idx2 $fgColor]
}
switch $arg {
create {
image create photo ::img::$action -format $::tk::svgFmt \
-data $data
}
configure { ::img::$action configure -data $data }
}
}
}
images create
set mainClass [winfo class .]
foreach event {<> <> <>} {
bind $mainClass $event { images configure }
}
unset mainClass event
image create photo ::img::delete -format $::tk::svgFmt -data {
}
#----------------------------------------------------------------
# The code below creates 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
# On Aqua, just use the default menu.
if {[tk windowingsystem] ne "aqua"} {
# This is a tk-internal procedure to make i18n easier
::tk::AmpMenuArgs .menuBar add cascade -label [mc "&File"] \
-menu .menuBar.file
menu .menuBar.file -tearoff 0
::tk::AmpMenuArgs .menuBar.file add command -label [mc "&About..."] \
-command {tkAboutDialog} -accelerator [mc ""]
bind . {tkAboutDialog}
.menuBar.file add sep
if {[tk windowingsystem] eq "win32"} {
# Windows doesn't usually have a Meta key
::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \
-command {exit} -accelerator [mc "Ctrl+Q"]
bind . <[mc "Control-q"]> {exit}
} else {
::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \
-command {exit} -accelerator [mc "Meta-Q"]
bind . <[mc "Meta-q"]> {exit}
}
. configure -menu .menuBar
}
ttk::frame .statusBar
ttk::label .statusBar.lab -text " " -anchor w
if {[tk windowingsystem] eq "aqua"} {
ttk::separator .statusBar.sep
pack .statusBar.sep -side top -expand yes -fill x -pady 0
}
pack .statusBar.lab -side left -padx 1.5p -expand yes -fill both
if {[tk windowingsystem] ne "aqua"} {
ttk::sizegrip .statusBar.foo
pack .statusBar.foo -side left -padx 1.5p
}
pack .statusBar -side bottom -fill x -pady 1.5p
set textheight 30
catch {
set textheight [expr {
([winfo screenheight .] * 0.7) /
[font metrics mainFont -displayof . -linespace]
}]
}
ttk::frame .textFrame
ttk::scrollbar .s -orient vertical -command {.t yview} -takefocus 1
pack .s -in .textFrame -side right -fill y
text .t -yscrollcommand {.s set} -wrap word -width 70 -height $textheight \
-font mainFont -setgrid 1 -highlightthickness 0 \
-padx 3p -pady 1.5p -takefocus 0
pack .t -in .textFrame -expand y -fill both -padx 1
pack .textFrame -expand yes -fill both
if {[tk windowingsystem] eq "aqua"} {
pack configure .statusBar.lab -padx {10 18} -pady {4 6}
pack configure .statusBar -pady 0
.t configure -padx 10 -pady 0
}
# 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 titleFont
.t tag configure subtitle -font titleFont
.t tag configure bold -font boldFont
if {[tk windowingsystem] eq "aqua"} {
.t tag configure title -spacing1 8
.t tag configure subtitle -spacing3 3
}
# 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
if {[tk windowingsystem] eq "aqua"} {
.t tag configure demo -foreground systemLinkColor
.t tag configure visited -foreground purple
}
.t tag configure hot -foreground red -underline 1
}
# The tag "new" must be the one having the highest priority.
#
.t tag configure new -foreground #c00000 -underline 0 -font boldFont
.t tag bind demo {
invoke [.t index {@%x,%y}]
}
set lastLine ""
.t tag bind demo {
set lastLine [.t index {@%x,%y linestart}]
.t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars"
.t config -cursor [::ttk::cursor link]
showStatus [.t index {@%x,%y}]
}
.t tag bind demo {
.t tag remove hot 1.0 end
.t config -cursor [::ttk::cursor text]
.statusBar.lab config -text ""
}
.t tag bind demo {
set newLine [.t index {@%x,%y linestart}]
if {$newLine ne $lastLine} {
.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.
# addFormattedText --
#
# Add formatted text (but not hypertext) to the text widget after first
# passing it through the message catalog to allow for localization.
# Lines starting with @@ are formatting directives (insert title, insert
# demo hyperlink, begin newline, or change style) and all other lines
# are literal strings to be inserted. Substitutions are performed,
# allowing processing pieces through the message catalog. Blank lines
# are ignored.
#
proc addFormattedText {formattedText} {
set style normal
set isNL 1
set demoCount 0
set new 0
foreach line [split $formattedText \n] {
set line [string trim $line]
if {$line eq ""} {
continue
}
if {[string match @@* $line]} {
set data [string range $line 2 end]
set key [lindex $data 0]
set values [lrange $data 1 end]
switch -exact -- $key {
title {
.t insert end [mc $values]\n title \n normal
}
newline {
.t insert end \n $style
set isNL 1
}
subtitle {
.t insert end "\n" {} [mc $values] subtitle \
" \n " demospace
set demoCount 0
}
demo {
set description [lassign $values name]
.t insert end "[incr demoCount]. [mc $description]" \
[list demo demo-$name]
if {$new} {
.t insert end " [mc NEW]" new
set new 0
}
.t insert end " \n " demospace
}
new {
set new 1
}
default {
set style $key
}
}
continue
}
if {!$isNL} {
.t insert end " " $style
}
set isNL 0
.t insert end [mc $line] $style
}
}
addFormattedText {
@@title Tk Widget Demonstrations
This 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
@@bold
See Code
@@normal
button to see the Tcl/Tk code that created the demonstration. If
you wish, you can edit the code and click the
@@bold
Rerun Demo
@@normal
button in the code window to reinvoke the demonstration with the
modified code.
@@newline
@@subtitle Labels, buttons, checkbuttons, and radiobuttons
@@demo label Labels (text and bitmaps)
@@demo unicodeout Labels and UNICODE text
@@demo button Buttons
@@demo check Check-buttons (select any of a group)
@@demo radio Radio-buttons (select one of a group)
@@demo puzzle A 15-puzzle game made out of buttons
@@demo icon Iconic buttons that use bitmaps
@@demo image1 Two labels displaying images
@@demo image2 A simple user interface for viewing images
@@demo labelframe Labelled frames
@@demo ttkbut The simple Themed Tk widgets
}
if {[tk windowingsystem] eq "aqua"} {
addFormattedText {
@@subtitle Mac-Specific Widgets and Window Styles
@@new
@@demo mac_styles Special widgets for macOS
@@new
@@demo mac_wm Window styles for macOS
@@new
@@demo mac_tabs Tabbed Windows on macOS
}
}
addFormattedText {
@@subtitle Listboxes and Trees
@@demo states The 50 states
@@demo colors Colors: change the color scheme for the application
@@demo sayings A collection of famous and infamous sayings
@@demo mclist A multi-column list of countries
@@demo tree A directory browser tree
@@subtitle Entries, Spin-boxes and Combo-boxes
@@demo entry1 Entries without scrollbars
@@demo entry2 Entries with scrollbars
@@demo entry3 Validated entries and password fields
@@demo spin Spin-boxes
@@demo ttkspin Themed spin-boxes
@@demo combo Combo-boxes
@@demo form Simple Rolodex-like form
@@subtitle Text
@@demo text Basic editable text
@@demo style Text display styles
@@demo bind Hypertext (tag bindings)
@@demo twind A text widget with embedded windows and other features
@@demo search A search tool built with a text widget
@@demo textpeer Peering text widgets
@@subtitle Canvases
@@demo items The canvas item types
@@demo plot A simple 2-D plot
@@demo ctext Text items in canvases
@@demo arrow An editor for arrowheads on canvas lines
@@demo ruler A ruler with adjustable tab stops
@@demo floor A building floor plan
@@demo cscroll A simple scrollable canvas
@@demo knightstour A Knight's tour of the chess board
@@subtitle Scales and Progress Bars
@@demo hscale Horizontal scale
@@demo vscale Vertical scale
@@demo ttkscale Themed scale linked to a label with traces
@@demo ttkprogress Progress bar
@@subtitle Paned Windows and Notebooks
@@demo paned1 Horizontal paned window
@@demo paned2 Vertical paned window
@@demo ttkpane Themed nested panes
@@demo ttknote Notebook widget
@@subtitle Menus and Toolbars
@@demo menu Menus and cascades (sub-menus)
@@demo menubu Menu-buttons
@@demo ttkmenu Themed menu buttons
@@demo toolbar Themed toolbar
@@subtitle Common Dialogs
@@demo msgbox Message boxes
@@demo filebox File selection dialog
@@demo clrpick Color picker
@@demo fontchoose Font selection dialog
@@new
@@demo systray System tray icon and notification
@@new
@@demo print Printing from canvas and text widgets
@@subtitle Animation
@@demo anilabel Animated labels
@@demo aniwave Animated wave
@@demo pendulum Pendulum simulation
@@demo goldberg A celebration of Rube Goldberg
@@subtitle Miscellaneous
@@demo bitmap The built-in bitmaps
@@demo dialog1 A dialog box with a local grab
@@demo dialog2 A dialog box with a global grab
@@new
@@demo windowicons Window icons and badges
}
##############################################################################
.t configure -state disabled
focus .s
# addSeeDismiss --
# Add "See Code" and "Dismiss" button frame, with optional "See Vars"
#
# Arguments:
# w - The name of the frame to use.
proc addSeeDismiss {w show {vars {}} {extra {}}} {
## See Code / Dismiss buttons
ttk::frame $w
#ttk::frame $w.sep -height 2 -relief sunken
ttk::separator $w.sep
grid $w.sep -columnspan 4 -row 0 -sticky ew -pady 1.5p
ttk::button $w.dismiss -text [mc "Dismiss"] \
-image ::img::delete -compound left \
-command [list destroy [winfo toplevel $w]]
ttk::button $w.code -text [mc "See Code"] \
-image ::img::view -compound left \
-command [list showCode $show]
set buttons [list x $w.code $w.dismiss]
if {[llength $vars]} {
ttk::button $w.vars -text [mc "See Variables"] \
-image ::img::view -compound left \
-command [concat [list showVars $w.dialog] $vars]
set buttons [linsert $buttons 1 $w.vars]
}
if {$extra ne ""} {
set buttons [linsert $buttons 1 [uplevel 1 $extra]]
}
grid {*}$buttons -padx 3p -pady 3p
grid columnconfigure $w 0 -weight 1
if {[tk windowingsystem] eq "aqua"} {
foreach b [lrange $buttons 1 end] {$b configure -takefocus 0}
grid configure $w.sep -pady 0
grid configure {*}$buttons -pady {10 12}
grid configure [lindex $buttons 1] -padx {16 4}
grid configure [lindex $buttons end] -padx {4 18}
}
return $w
}
# 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} {
catch {destroy $w}
toplevel $w
if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
wm title $w [mc "Variable values"]
set b [ttk::frame $w.frame]
grid $b -sticky news
set f [ttk::labelframe $b.title -text [mc "Variable values:"]]
foreach var $args {
ttk::label $f.n$var -text "$var:" -anchor w
ttk::label $f.v$var -textvariable $var -anchor w
grid $f.n$var $f.v$var -padx 1.5p -pady 1.5p -sticky w
}
ttk::button $b.ok -text [mc "OK"] \
-command [list destroy $w] -default active
bind $w [list $b.ok invoke]
bind $w [list $b.ok invoke]
grid $f -sticky news -padx 3p
grid $b.ok -sticky e -padx 3p -pady {4.5p 3p}
if {[tk windowingsystem] eq "aqua"} {
$b.ok configure -takefocus 0
grid configure $b.ok -pady {10 12} -padx {16 18}
grid configure $f -padx 10 -pady {10 0}
}
grid columnconfig $f 1 -weight 1
grid rowconfigure $f 100 -weight 1
grid columnconfig $b 0 -weight 1
grid rowconfigure $b 0 -weight 1
grid columnconfig $w 0 -weight 1
grid rowconfigure $w 0 -weight 1
}
# 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_demoDirectory
set tags [.t tag names $index]
set i [lsearch -glob $tags demo-*]
if {$i < 0} {
return
}
set cursor [.t cget -cursor]
.t configure -cursor [::ttk::cursor busy]
update
set demo [string range [lindex $tags $i] 5 end]
uplevel 1 [list source -encoding utf-8 [file join $tk_demoDirectory $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 {
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 [::ttk::cursor text]
} else {
set demo [string range [lindex $tags $i] 5 end]
.statusBar.lab config -text [mc "Run the \"%s\" sample program" $demo]
set newcursor [::ttk::cursor link]
}
if {$cursor ne $newcursor} {
.t config -cursor $newcursor
}
}
# evalShowCode --
#
# Arguments:
# w - Name of text widget containing code to eval
proc evalShowCode {w} {
set code [$w get 1.0 end-1c]
uplevel #0 $code
}
# 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_demoDirectory
set file [string range $w 1 end].tcl
set top .code
if {![winfo exists $top]} {
toplevel $top
if {[tk windowingsystem] eq "x11"} {wm attributes $top -type dialog}
set t [frame $top.f]
set text [text $t.text -font fixedFont -height 24 -wrap word \
-xscrollcommand [list $t.xscroll set] \
-yscrollcommand [list $t.yscroll set] \
-setgrid 1 -highlightthickness 0 -padx 3p -pady 1.5p \
-tabstyle wordprocessor]
ttk::scrollbar $t.xscroll -command [list $t.text xview] \
-orient horizontal
ttk::scrollbar $t.yscroll -command [list $t.text yview] \
-orient vertical
grid $t.text $t.yscroll -sticky news
#grid $t.xscroll
grid rowconfigure $t 0 -weight 1
grid columnconfig $t 0 -weight 1
set btns [ttk::frame $top.btns]
ttk::separator $btns.sep
grid $btns.sep -columnspan 4 -row 0 -sticky ew -pady 1.5p
ttk::button $btns.dismiss -text [mc "Dismiss"] \
-default active -command [list destroy $top] \
-image ::img::delete -compound left
ttk::button $btns.print -text [mc "Print Code"] \
-command [list printCode $text $file] \
-image ::img::print -compound left
ttk::button $btns.rerun -text [mc "Rerun Demo"] \
-command [list evalShowCode $text] \
-image ::img::refresh -compound left
set buttons [list x $btns.rerun $btns.print $btns.dismiss]
grid {*}$buttons -padx 3p -pady 3p
grid columnconfigure $btns 0 -weight 1
if {[tk windowingsystem] eq "aqua"} {
foreach b [lrange $buttons 1 end] {$b configure -takefocus 0}
grid configure $btns.sep -pady 0
grid configure {*}$buttons -pady {10 12}
grid configure [lindex $buttons 1] -padx {16 4}
grid configure [lindex $buttons end] -padx {4 18}
}
grid $t -sticky news
grid $btns -sticky ew
grid rowconfigure $top 0 -weight 1
grid columnconfig $top 0 -weight 1
bind $top {
if {[winfo class %W] ne "Text"} { .code.btns.dismiss invoke }
}
bind $top [bind $top ]
} else {
wm deiconify $top
raise $top
}
wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]]
wm iconname $top $file
set id [open [file join $tk_demoDirectory $file]]
fconfigure $id -encoding utf-8 -eofchar "\032 {}"
$top.f.text delete 1.0 end
$top.f.text insert 1.0 [read $id]
$top.f.text mark set insert 1.0
close $id
}
# printCode --
# Prints the source code currently displayed in the See Code dialog. Much
# thanks to Arjen Markus for this.
#
# Arguments:
# w - Name of text widget containing code to print
# file - Name of the original file (implicitly for title)
proc printCode {w file} {
tk print $w
}
# tkAboutDialog --
#
# Pops up a message box with an "about" message
#
proc tkAboutDialog {} {
tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \
-message [mc "Tk widget demonstration application"] -detail \
"[mc "Copyright © %s" {1996-1997 Sun Microsystems, Inc.}]
[mc "Copyright © %s" {1997-2000 Ajuba Solutions, Inc.}]
[mc "Copyright © %s" {2001-2009 Donal K. Fellows}]
[mc "Copyright © %s" {2002-2007 Daniel A. Steffen}]
[mc "Copyright © %s" {2021 Kevin Walzer}]"
}
# Local Variables:
# mode: tcl
# End: