diff options
Diffstat (limited to 'blt/demos/busy1.tcl')
| -rwxr-xr-x | blt/demos/busy1.tcl | 254 |
1 files changed, 254 insertions, 0 deletions
diff --git a/blt/demos/busy1.tcl b/blt/demos/busy1.tcl new file mode 100755 index 00000000000..7c9c58c68b2 --- /dev/null +++ b/blt/demos/busy1.tcl @@ -0,0 +1,254 @@ +#!../src/bltwish + +package require BLT +# -------------------------------------------------------------------------- +# Starting with Tcl 8.x, the BLT commands are stored in their own +# namespace called "blt". The idea is to prevent name clashes with +# Tcl commands and variables from other packages, such as a "table" +# command in two different packages. +# +# You can access the BLT commands in a couple of ways. You can prefix +# all the BLT commands with the namespace qualifier "blt::" +# +# blt::graph .g +# blt::table . .g -resize both +# +# or you can import all the command into the global namespace. +# +# namespace import blt::* +# graph .g +# table . .g -resize both +# +# -------------------------------------------------------------------------- + +if { $tcl_version >= 8.0 } { + namespace import blt::* + namespace import -force blt::tile::* +} +source scripts/demo.tcl + +# +# Script to test the "busy" command. +# + +# +# General widget class resource attributes +# +option add *Button.padX 10 +option add *Button.padY 2 +option add *Scale.relief sunken +#option add *Scale.orient horizontal +option add *Entry.relief sunken +option add *Frame.borderWidth 2 + +set visual [winfo screenvisual .] +if { $visual == "staticgray" || $visual == "grayscale" } { + set activeBg black + set normalBg white + set bitmapFg black + set bitmapBg white + option add *f1.background white +} else { + set activeBg red + set normalBg springgreen + set bitmapFg blue + set bitmapBg green + option add *Button.background khaki2 + option add *Button.activeBackground khaki1 + option add *Frame.background khaki2 + option add *f2.tile textureBg +# option add *Button.tile textureBg + + option add *releaseButton.background limegreen + option add *releaseButton.activeBackground springgreen + option add *releaseButton.foreground black + + option add *holdButton.background red + option add *holdButton.activeBackground pink + option add *holdButton.foreground black + option add *f1.background springgreen +} + +# +# Instance specific widget options +# +option add *f1.relief sunken +option add *f1.background $normalBg +option add *testButton.text "Test" +option add *quitButton.text "Quit" +option add *newButton.text "New\nButton" +option add *holdButton.text "Hold" +option add *releaseButton.text "Release" +option add *buttonLabel.text "Buttons" +option add *entryLabel.text "Entries" +option add *scaleLabel.text "Scales" +option add *textLabel.text "Text" + +bind keepRaised <Visibility> { raise %W } + +proc KeepRaised { w } { + bindtags $w keepRaised +} + +set file ./images/chalk.gif +image create photo textureBg -file $file + +# +# This never gets used; it's reset by the Animate proc. It's +# here to just demonstrate how to set busy window options via +# the host window path name +# +#option add *f1.busyCursor bogosity + +# +# Counter for new buttons created by the "New button" button +# +set numWin 0 + +# +# Create two frames. The top frame will be the host window for the +# busy window. It'll contain widgets to test the effectiveness of +# the busy window. The bottom frame will contain buttons to +# control the testing. +# +frame .f1 +frame .f2 + +# +# Create some widgets to test the busy window and its cursor +# +label .buttonLabel +button .testButton -command { + puts stdout "Not busy." +} +button .quitButton -command { exit } +entry .entry +scale .scale +text .text -width 20 -height 4 + +# +# The following buttons sit in the lower frame to control the demo +# +button .newButton -command { + global numWin + incr numWin + set name button#${numWin} + button .f1.$name -text "$name" \ + -command [list .f1 configure -bg blue] + table .f1 \ + .f1.$name $numWin+3,0 -padx 10 -pady 10 +} + +button .holdButton -command { + if { [busy isbusy .f1] == "" } { + global activeBg + .f1 configure -bg $activeBg + } + busy .f1 + focus -force . +} + +button .releaseButton -command { + if { [busy isbusy .f1] == ".f1" } { + busy release .f1 + } + global normalBg + .f1 configure -bg $normalBg +} + +# +# Notice that the widgets packed in .f1 and .f2 are not their children +# +table .f1 \ + 0,0 .testButton \ + 1,0 .scale -fill y \ + 0,1 .entry -fill x \ + 1,1 .text -fill both \ + 2,0 .quitButton -cspan 2 + +table .f2 \ + 0,0 .holdButton \ + 0,1 .releaseButton \ + 0,2 .newButton + +table configure .f1 \ + .testButton .scale .entry .quitButton -padx 10 -pady 10 +table configure .f2 \ + .newButton .holdButton .releaseButton -padx 10 -pady 4 -reqwidth 1.i + +table configure .f1 r0 r2 -resize none +table configure .f2 r* -resize none + +# +# Finally, realize and map the top level window +# +table . \ + 0,0 .f1 -fill both \ + 1,0 .f2 -fill both + +table configure . r1 -resize none + +table configure .f1 c1 -weight 2.0 + +# Initialize a list of bitmap file names which make up the animated +# fish cursor. The bitmap mask files have a "m" appended to them. + +set bitmapList { + left left1 mid right1 right +} + +# +# Simple cursor animation routine: Uses the "after" command to +# circulate through a list of cursors every 0.075 seconds. The +# first pass through the cursor list may appear sluggish because +# the bitmaps have to be read from the disk. Tk's cursor cache +# takes care of it afterwards. +# +proc StartAnimation { widget count } { + global bitmapList + set prefix bitmaps/fish/[lindex $bitmapList $count] + set cursor [list @${prefix}.xbm ${prefix}m.xbm blue green ] + busy configure $widget -cursor $cursor + + incr count + set limit [llength $bitmapList] + if { $count >= $limit } { + set count 0 + } + global afterId + set afterId($widget) [after 125 StartAnimation $widget $count] +} + +proc StopAnimation { widget } { + global afterId + after cancel $afterId($widget) +} + +proc TranslateBusy { window } { + set widget [string trimright $window "_Busy"] + if { $widget != "." } { + set widget [string trimright $widget "."] + } + return $widget +} + +if { [info exists tcl_platform] && $tcl_platform(platform) == "unix" } { + bind Busy <Map> { + StartAnimation [TranslateBusy %W] 0 + } + bind Busy <Unmap> { + StopAnimation [TranslateBusy %W] + } +} + +# +# For testing, allow the top level window to be resized +# +wm min . 0 0 + +# +# Force the demo to stay raised +# +raise . +KeepRaised . + |