util/src/TclTk/blt2.5/demos/busy2.tcl

   1 #!../src/bltwish
   2
   3 package 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
  24 if { $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 #
  37 option add *Button.padX         10
  38 option add *Button.padY         2
  39 option add *Scale.relief        sunken
  40 #option add *Scale.orient       horizontal
  41 option add *Entry.relief        sunken
  42 option add *Frame.borderWidth   2
  43
  44 set visual [winfo screenvisual .]
  45 if { $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 #
  75 option add *f1.relief           sunken
  76 option add *f1.background       $normalBg
  77 option add *testButton.text     "Test"
  78 option add *quitButton.text     "Quit"
  79 option add *newButton.text      "New button"
  80 option add *holdButton.text     "Hold"
  81 option add *releaseButton.text  "Release"
  82 option add *buttonLabel.text    "Buttons"
  83 option add *entryLabel.text     "Entries"
  84 option add *scaleLabel.text     "Scales"
  85 option add *textLabel.text      "Text"
  86
  87 proc LoseFocus {} {
  88     focus -force .
  89 }
  90 proc KeepRaised { w } {
  91     bindtags $w keepRaised
  92 }
  93
  94 bind keepRaised <Visibility> { raise %W }
  95
  96 set file ./images/chalk.gif
  97 image 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 #
 110 set numWin 0
 111
 112 menu .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 #
 125 frame .f1
 126 frame .f2
 127
 128 #
 129 # Create some widgets to test the busy window and its cursor
 130 #
 131 label .buttonLabel
 132 button .testButton -command {
 133     puts stdout "Not busy."
 134 }
 135 button .quitButton -command { exit }
 136 entry .entry
 137 scale .scale
 138 text .text -width 20 -height 4
 139
 140 #
 141 # The following buttons sit in the lower frame to control the demo
 142 #
 143 button .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
 153 button .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 }
 162 button .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 #
 174 table .f1 \
 175     .testButton 0,0 \
 176     .scale 1,0 \
 177     .entry 0,1 \
 178     .text 1,1 -fill both \
 179     .quitButton 2,0
 180
 181 table .f2 \
 182     .newButton 0,0 \
 183     .holdButton 1,0 \
 184     .releaseButton 2,0
 185
 186 table configure .f1 .testButton .scale .entry .quitButton -padx 10 -pady 10 -fill both
 187 table configure .f2 .newButton .holdButton .releaseButton -padx 10 -pady 10
 188 table configure .f2 c0 -resize none
 189 #
 190 # Finally, realize and map the top level window
 191 #
 192 table . \
 193     .f1 0,0  \
 194     .f2 1,0
 195
 196 table 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
 200 table configure . r1 -resize none
 201
 202 set 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 #
 211 proc 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
 226 proc StopAnimation { widget } {
 227     global afterId
 228     after cancel $afterId($widget)
 229 }
 230
 231 proc 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
 241 if { [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 #
 253 wm min . 0 0
 254
 255 #
 256 # Force the demo to stay raised
 257 #
 258 raise .
 259 KeepRaised .