#!../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 -fill both # # or you can import all the command into the global namespace. # # namespace import blt::* # graph .g # table . .g -fill 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 button" 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" proc LoseFocus {} { focus -force . } proc KeepRaised { w } { bindtags $w keepRaised } bind keepRaised <Visibility> { raise %W } 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 menu .menu .menu add command -label "First" .menu add command -label "Second" .menu add command -label "Third" .menu add command -label "Fourth" . configure -menu .menu # # 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 busy .#menu LoseFocus } button .releaseButton -command { if { [busy isbusy .f1] == ".f1" } { busy release .f1 busy release .#menu } global normalBg .f1 configure -bg $normalBg } # # Notice that the widgets packed in .f1 and .f2 are not their children # table .f1 \ .testButton 0,0 \ .scale 1,0 \ .entry 0,1 \ .text 1,1 -fill both \ .quitButton 2,0 table .f2 \ .newButton 0,0 \ .holdButton 1,0 \ .releaseButton 2,0 table configure .f1 .testButton .scale .entry .quitButton -padx 10 -pady 10 -fill both table configure .f2 .newButton .holdButton .releaseButton -padx 10 -pady 10 table configure .f2 c0 -resize none # # Finally, realize and map the top level window # table . \ .f1 0,0 \ .f2 1,0 table configure . .f1 .f2 -fill both # Initialize a list of bitmap file names which make up the animated # fish cursor. The bitmap mask files have a "m" appended to them. table configure . r1 -resize none 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 black white ] 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"] set widget [string trimright $window "Busy"] set widget [string trimright $widget "_"] # if { [winfo toplevel $widget] != $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 .