1#!/usr/local/bin/bltwish 2 3package require BLT 4# -------------------------------------------------------------------------- 5# Starting with Tcl 8.x, the BLT commands are stored in their own 6# namespace called "blt". The idea is to prevent name clashes with 7# Tcl commands and variables from other packages, such as a "table" 8# command in two different packages. 9# 10# You can access the BLT commands in a couple of ways. You can prefix 11# all the BLT commands with the namespace qualifier "blt::" 12# 13# blt::graph .g 14# blt::table . .g -fill both 15# 16# or you can import all the command into the global namespace. 17# 18# namespace import blt::* 19# graph .g 20# table . .g -fill both 21# 22# -------------------------------------------------------------------------- 23 24if { $tcl_version >= 8.0 } { 25 namespace import blt::* 26# namespace import -force blt::tile::* 27} 28#source scripts/demo.tcl 29 30# 31# Script to test the "busy" command. 32# 33 34# 35# General widget class resource attributes 36# 37option add *Button.padX 10 38option add *Button.padY 2 39option add *Scale.relief sunken 40#option add *Scale.orient horizontal 41option add *Entry.relief sunken 42option add *Frame.borderWidth 2 43 44set visual [winfo screenvisual .] 45if { $visual == "staticgray" || $visual == "grayscale" } { 46 set activeBg black 47 set normalBg white 48 set bitmapFg black 49 set bitmapBg white 50 option add *f1.background white 51} else { 52 set activeBg red 53 set normalBg springgreen 54 set bitmapFg blue 55 set bitmapBg green 56 option add *Button.background khaki2 57 option add *Button.activeBackground khaki1 58 option add *Frame.background khaki2 59 option add *f2.tile textureBg 60# option add *Button.tile textureBg 61 62 option add *releaseButton.background limegreen 63 option add *releaseButton.activeBackground springgreen 64 option add *releaseButton.foreground black 65 66 option add *holdButton.background red 67 option add *holdButton.activeBackground pink 68 option add *holdButton.foreground black 69 option add *f1.background springgreen 70} 71 72# 73# Instance specific widget options 74# 75option add *f1.relief sunken 76option add *f1.background $normalBg 77option add *testButton.text "Test" 78option add *quitButton.text "Quit" 79option add *newButton.text "New button" 80option add *holdButton.text "Hold" 81option add *releaseButton.text "Release" 82option add *buttonLabel.text "Buttons" 83option add *entryLabel.text "Entries" 84option add *scaleLabel.text "Scales" 85option add *textLabel.text "Text" 86 87proc LoseFocus {} { 88 focus -force . 89} 90proc KeepRaised { w } { 91 bindtags $w keepRaised 92} 93 94bind keepRaised <Visibility> { raise %W } 95 96set file ./images/chalk.gif 97image create photo textureBg -file $file 98 99# 100# This never gets used; it's reset by the Animate proc. It's 101# here to just demonstrate how to set busy window options via 102# the host window path name 103# 104#option add *f1.busyCursor bogosity 105 106 107# 108# Counter for new buttons created by the "New button" button 109# 110set numWin 0 111 112menu .menu 113.menu add command -label "First" 114.menu add command -label "Second" 115.menu add command -label "Third" 116.menu add command -label "Fourth" 117. configure -menu .menu 118 119# 120# Create two frames. The top frame will be the host window for the 121# busy window. It'll contain widgets to test the effectiveness of 122# the busy window. The bottom frame will contain buttons to 123# control the testing. 124# 125frame .f1 126frame .f2 127 128# 129# Create some widgets to test the busy window and its cursor 130# 131label .buttonLabel 132button .testButton -command { 133 puts stdout "Not busy." 134} 135button .quitButton -command { exit } 136entry .entry 137scale .scale 138text .text -width 20 -height 4 139 140# 141# The following buttons sit in the lower frame to control the demo 142# 143button .newButton -command { 144 global numWin 145 incr numWin 146 set name button#${numWin} 147 button .f1.$name -text "$name" \ 148 -command [list .f1 configure -bg blue] 149 table .f1 \ 150 .f1.$name $numWin+3,0 -padx 10 -pady 10 151} 152 153button .holdButton -command { 154 if { [busy isbusy .f1] == "" } { 155 global activeBg 156 .f1 configure -bg $activeBg 157 } 158 busy .f1 159 busy .#menu 160 LoseFocus 161} 162button .releaseButton -command { 163 if { [busy isbusy .f1] == ".f1" } { 164 busy release .f1 165 busy release .#menu 166 } 167 global normalBg 168 .f1 configure -bg $normalBg 169} 170 171# 172# Notice that the widgets packed in .f1 and .f2 are not their children 173# 174table .f1 \ 175 .testButton 0,0 \ 176 .scale 1,0 \ 177 .entry 0,1 \ 178 .text 1,1 -fill both \ 179 .quitButton 2,0 180 181table .f2 \ 182 .newButton 0,0 \ 183 .holdButton 1,0 \ 184 .releaseButton 2,0 185 186table configure .f1 .testButton .scale .entry .quitButton -padx 10 -pady 10 -fill both 187table configure .f2 .newButton .holdButton .releaseButton -padx 10 -pady 10 188table configure .f2 c0 -resize none 189# 190# Finally, realize and map the top level window 191# 192table . \ 193 .f1 0,0 \ 194 .f2 1,0 195 196table configure . .f1 .f2 -fill both 197# Initialize a list of bitmap file names which make up the animated 198# fish cursor. The bitmap mask files have a "m" appended to them. 199 200table configure . r1 -resize none 201 202set bitmapList { left left1 mid right1 right } 203 204# 205# Simple cursor animation routine: Uses the "after" command to 206# circulate through a list of cursors every 0.075 seconds. The 207# first pass through the cursor list may appear sluggish because 208# the bitmaps have to be read from the disk. Tk's cursor cache 209# takes care of it afterwards. 210# 211proc StartAnimation { widget count } { 212 global bitmapList 213 set prefix "bitmaps/fish/[lindex $bitmapList $count]" 214 set cursor [list @${prefix}.xbm ${prefix}m.xbm black white ] 215 busy configure $widget -cursor $cursor 216 217 incr count 218 set limit [llength $bitmapList] 219 if { $count >= $limit } { 220 set count 0 221 } 222 global afterId 223 set afterId($widget) [after 125 StartAnimation $widget $count] 224} 225 226proc StopAnimation { widget } { 227 global afterId 228 after cancel $afterId($widget) 229} 230 231proc TranslateBusy { window } { 232 #set widget [string trimright $window "_Busy"] 233 set widget [string trimright $window "Busy"] 234 set widget [string trimright $widget "_"] 235# if { [winfo toplevel $widget] != $widget } { 236# set widget [string trimright $widget "."] 237# } 238 return $widget 239} 240 241if { [info exists tcl_platform] && $tcl_platform(platform) == "unix" } { 242 bind Busy <Map> { 243 StartAnimation [TranslateBusy %W] 0 244 } 245 bind Busy <Unmap> { 246 StopAnimation [TranslateBusy %W] 247 } 248} 249 250# 251# For testing, allow the top level window to be resized 252# 253wm min . 0 0 254 255# 256# Force the demo to stay raised 257# 258raise . 259KeepRaised . 260