+++ /dev/null
-#!../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 -resize both
-#
-# or you can import all the command into the global namespace.
-#
-# namespace import blt::*
-# graph .g
-# table . .g -resize 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\nButton"
-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"
-
-bind keepRaised <Visibility> { raise %W }
-
-proc KeepRaised { w } {
- bindtags $w keepRaised
-}
-
-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
-
-#
-# 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
- focus -force .
-}
-
-button .releaseButton -command {
- if { [busy isbusy .f1] == ".f1" } {
- busy release .f1
- }
- global normalBg
- .f1 configure -bg $normalBg
-}
-
-#
-# Notice that the widgets packed in .f1 and .f2 are not their children
-#
-table .f1 \
- 0,0 .testButton \
- 1,0 .scale -fill y \
- 0,1 .entry -fill x \
- 1,1 .text -fill both \
- 2,0 .quitButton -cspan 2
-
-table .f2 \
- 0,0 .holdButton \
- 0,1 .releaseButton \
- 0,2 .newButton
-
-table configure .f1 \
- .testButton .scale .entry .quitButton -padx 10 -pady 10
-table configure .f2 \
- .newButton .holdButton .releaseButton -padx 10 -pady 4 -reqwidth 1.i
-
-table configure .f1 r0 r2 -resize none
-table configure .f2 r* -resize none
-
-#
-# Finally, realize and map the top level window
-#
-table . \
- 0,0 .f1 -fill both \
- 1,0 .f2 -fill both
-
-table configure . r1 -resize none
-
-table configure .f1 c1 -weight 2.0
-
-# Initialize a list of bitmap file names which make up the animated
-# fish cursor. The bitmap mask files have a "m" appended to them.
-
-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 blue green ]
- 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"]
- if { $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 .
-
OSDN Git Service
