I386LINUX/util/I386LINUX/lib/blt2.4/demos/busy

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