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