#
# $Id: demo.tcl,v 1.20 2004/01/16 00:09:39 jenglish Exp $
#
# Demo for 'tile' package.
#
lappend auto_path . [file dirname [info script]]
# Read the pkgIndex.tcl file to get available package names.
[package unknown] Tcl [package provide Tcl]
package require tile
package require tile::blue
# The descriptive names of the builtin themes.
set themelist {
{} "Classic"
alt "Alternate"
step "OpenStep"
xpnative "XP Native"
}
array set themes $themelist
# Add in any available loadable themes.
foreach id [lsearch -glob -all [package names] tile::*] {
set name [lindex [split [lindex [package names] $id] :] end]
if {$name eq "pixmap"} {
# not a real theme
continue
}
if {![info exists themes($name)]} {
lappend themelist $name [string totitle $name]
set themes($name) [string totitle $name]
}
}
# This permits delayes loading of pixmap themes. So we dont load
# lots of images until we need them.
#
proc SetTheme {container style} {
if {$style != {} && [package provide tile::$style] == {}} {
if {[catch {package require tile::$style} msg]} {
$container.s$style state disabled
return -code error $msg
}
}
style settheme $style
}
#
# Load icons...
#
set buttons [list open new save]
set checkboxes [list bold italic]
source [file join [file dirname [info script]] iconlib.tcl]
foreach icon [concat $buttons $checkboxes] {
set Icon($icon) [image create photo -data $ImgData($icon)]
}
#
# Utilities:
#
proc foreachWidget {varname Q script} {
upvar 1 $varname w
while {[llength $Q]} {
set QN [list]
foreach w $Q {
uplevel 1 $script
foreach child [winfo children $w] {
lappend QN $child
}
}
set Q $QN
}
}
# sbstub $sb --
# Used as the -command option for a scrollbar,
# updates the scrollbar's position.
#
proc sbstub {sb cmd number {units units}} { sbstub.$cmd $sb $number $units }
proc sbstub.moveto {sb number _} { $sb set $number [expr {$number + 0.5}] }
proc sbstub.scroll {sb number units} {
if {$units eq "pages"} {
set delta 0.2
} else {
set delta 0.05
}
set current [$sb get]
set new0 [expr {[lindex $current 0] + $delta*$number}]
set new1 [expr {[lindex $current 1] + $delta*$number}]
$sb set $new0 $new1 ;
}
# ... for debugging:
bind all <ButtonPress-3> { set ::W %W }
bind all <Control-ButtonPress-3> { focus %W }
proc showHelp {} {
tk_messageBox -message "Not yet implemented..."
}
#
# The following demonstrates the flexibility of dynamic resources:
# [@@@@ AND IS CURRENTLY BROKEN -- IGNORE THIS BIT]
# Toolbar buttons normally have a flat relief, but "pop up"
# when the mouse is over them (the same effect you get with
# '-relief flat -overrelief raised' with Tk's regular buttons)
#
# In addition, with dynamic resources we can also specify different
# foreground and background colors for when the button is pressed,
# (without having to write a TIP to add new widget options!)
#
# For now, do this with the option database. Eventually there
# will be an easier way to define customized widget styles so
# you can define this in one place and just say "button .b -style toolbar"
# to get the desired effect.
# [@@@@ WORKING ON THAT RIGHT NOW @@@@]
#
option add *Toolbar.relief groove
option add *Toolbar.borderWidth 2
option add *Toolbar.TButton.padding 2
option add *Toolbar.TButton.relief flat
option add *Toolbar.Button.Pad 2
set top "."
set f ""
set ctl [frame $f.control]
#
# Toolbar button standard vs. tile comparison:
#
variable compound top
set tb [frame $f.toolbar -class Toolbar]
set i 0
foreach icon $buttons {
pack \
[tbutton $tb.tb[incr i] \
-text $icon -image $Icon($icon) -compound $compound] \
-side left -expand false -fill none;
}
foreach icon $checkboxes {
pack [tcheckbutton $tb.cb[incr i] \
-text $icon -image $Icon($icon) -compound $compound \
-variable V($icon)] \
-side left -expand false -fill none;
}
set tb [frame $f.toolbar2 -class Toolbar]
set i 0
foreach icon $buttons {
pack [button $tb.tb[incr i] \
-text $icon -image $Icon($icon) -compound $compound \
-relief flat -overrelief raised ] \
-side left -expand false -fill none;
}
foreach icon $checkboxes {
pack [checkbutton $tb.cb[incr i] \
-text $icon -image $Icon($icon) -compound $compound \
-variable V($icon) \
-indicatoron false -selectcolor {} ] \
-side left -expand false -fill none;
}
#
# Overall theme control:
#
pack [set c [labelframe $ctl.style -text "Theme"]] \
-side top -expand false -fill x -padx 6 -ipadx 6
set i 0
foreach {style label} $themelist {
pack [tradiobutton $c.s$style -text $label -anchor w \
-variable style -value $style -command [list SetTheme $c $style] \
] -side top -expand false -fill x;
set style ""
}
if {[package provide tile::xpnative] == {}} {
$c.sxpnative state disabled
}
#
# Toolbar -compound control:
#
variable compoundStrings {text image none top bottom left right center}
pack [set c [labelframe $ctl.compound -text "Compound"]] \
-side top -expand false -fill x -padx 6 -ipadx 6
foreach string $compoundStrings {
pack [tradiobutton $c.$string -anchor w -text [string totitle $string] \
-variable compound -value $string -command changeToolbars] \
-side top -expand false -fill x ;
}
proc changeToolbars {} {
variable compound
foreachWidget w {.toolbar .toolbar2} {
catch {
$w configure -compound $compound
}
}
}
proc ScrolledWidget {parent class themed args} {
if {$themed} {
set sbcmd tscrollbar
} else {
set sbcmd scrollbar
}
for {set n 0} {[winfo exists $parent.f$n]} {incr n} {}
set f [frame $parent.f$n]
set t [eval [linsert $args 0 $class $f.$class]]
set vs [$sbcmd $f.vs -orient vertical -command [list $t yview]]
set hs [$sbcmd $f.hs -orient horizontal -command [list $t xview]]
$t configure -yscrollcommand [list $vs set] -xscrollcommand [list $hs set]
grid configure $t $vs -sticky news
grid configure $hs - -sticky news
grid rowconfigure $f 0 -weight 1
grid columnconfigure $f 0 -weight 1
return $f
}
#
# Notebook demonstration:
#
set nb [tnotebook $f.nb]
set client [frame $nb.client]
$nb add $client -text "Demo"
$nb raise $client
$nb add [label $nb.stuff -text "Nothing to see here..."] -text "Stuff"
$nb add [label $nb.more -text "Nothing to see here either."] -text "More stuff"
#
# Side-by side check & radiobutton comparison:
#
set l [labelframe $client.l -text "Styled" -borderwidth 2 -relief groove]
set r [labelframe $client.r -text "Standard" -borderwidth 2 -relief groove]
set ltext [ScrolledWidget $l text 1 -width 12 -height 5 -wrap none]
set rtext [ScrolledWidget $r text 0 -width 12 -height 5 -wrap none]
set msg "The cat crept into the crypt, crapped and crept out again\n"
for {set n 0} {$n < 50} {incr n} {
$ltext.text insert end "$n: $msg"
$rtext.text insert end "$n: $msg"
}
pack \
[tcheckbutton $l.tcb -text "Checkbutton" -variable selected -underline 2] \
[tradiobutton $l.trb1 -text "One" -variable choice -value 1 -underline 0] \
[tradiobutton $l.trb2 -text "Two" -variable choice -value 2] \
[tradiobutton $l.trb3 -text "Three" -variable choice -value 3 -under 0] \
[tbutton $l.tbutton -text "Button" -underline 0] \
$ltext \
[tscale $l.scale -orient horizontal -from 0 -to 100] \
[tscale $l.vscale -orient vertical -from -25 -to 25] \
-side top -expand false -fill x
pack \
[checkbutton $r.cb -text "Checkbutton" -variable selected] \
[radiobutton $r.rb1 -text "One" -variable choice -value 1] \
[radiobutton $r.rb2 -text "Two" -variable choice -value 2 -underline 1] \
[radiobutton $r.rb3 -text "Three" -variable choice -value 3] \
[button $r.button -text "Button"] \
$rtext \
[scale $r.scale -orient horizontal -from 0 -to 100] \
[scale $r.vscale -orient vertical -from -25 -to 25] \
-side top -expand false -fill x
if {[info command tprogress] != {}} {
pack forget $l.vscale
frame $l.fp
tprogress $l.progress -orient horizontal -from 0 -to 100
tprogress $l.vprogress -orient vertical -from -25 -to 25
pack $l.vscale $l.vprogress -in $l.fp -side left -expand false -fill y
pack $l.progress $l.fp -side top -expand false -fill x
raise $l.vscale
$l.scale configure -command [list $l.progress set]
$l.progress set [$l.progress cget -from]
$l.vscale configure -command [list $l.vprogress set]
$l.vprogress set [$l.vprogress cget -from]
}
pack $client.l $client.r -side left -expand true -fill both -padx 6 -ipadx 6
#
# Command box:
#
set cmd [frame $f.command]
grid \
[tbutton $cmd.close -text Close -underline 0 -default normal \
-command [list destroy .] ] \
[tbutton $cmd.help -text Help -underline 0 -default normal \
-command showHelp] \
-pady {6 4} -padx 4;
#
# Set up accelerators:
#
bind $top <KeyPress-Escape> [list event generate $cmd.close <<Invoke>>]
bind $top <<Help>> [list event generate $cmd.help <<Invoke>>]
keynav::enableMnemonics $top
keynav::defaultButton $cmd.help
pack $f.toolbar -side top -expand false -fill x
pack $f.toolbar2 -side top -expand false -fill x
pack $f.command -side bottom -expand false -fill none -anchor e
pack $f.control -side left -expand false -fill y
#pack .tvsb .vsb -side right -expand false -fill y
#pack .thsb .hsb -side bottom -expand false -fill x
pack $f.nb -side top -expand true -fill both
#
# Add a menu
#
. configure -menu [menu .menu]
.menu add cascade -label File -underline 0 \
-menu [menu .menu.file -tearoff 0]
.menu.file add command -label Open -underline 0 \
-compound left -image $Icon(open)
.menu.file add command -label Save -underline 0 \
-compound left -image $Icon(save)
.menu.file add separator
.menu.file add cascade -label "Test submenu" -underline 0 \
-menu [menu .menu.file.test -tearoff 0]
.menu.file add checkbutton -label "Text check" -underline 5 \
-variable ::menucheck1
.menu.file add command -label Exit -underline 1 \
-command [list event generate $cmd.close <<Invoke>>]
foreach label {One Two Three Four} {
.menu.file.test add radiobutton -label $label -variable ::menuradio1
}
set menuradio1 One
set menucheck1 1
# Add a theme menu.
# This uses the package command to dynamically build a list of available
# themes.
proc settheme {style} {
style settheme $style
set ::style $style
}
.menu add cascade -label Theme -underline 3 \
-menu [menu .menu.theme -tearoff 0]
.menu.theme add checkbutton -label Classic -underline 0 \
-variable style -onvalue {} -command [list settheme {}]
foreach id [lsearch -glob -all [package names] tile::*] {
set name [lindex [package names] $id]
set name [lindex [split $name :] end]
.menu.theme add checkbutton -label [string totitle $name] -underline 0 \
-variable style -onvalue $name -command [list settheme $name]
}
#
# Add a console menu item for windows.
#
if {[tk windowingsystem] == "win32"} {
set console 0
proc toggleconsole {} {
global console
if {$console} {console show} else {console hide}
}
set ndx [.menu.file index end]
.menu.file insert $ndx checkbutton -label Console -underline 0 \
-variable ::console -command toggleconsole
}