1 | #!/bin/sh |
---|
2 | # the next line restarts using wish \ |
---|
3 | exec wish8.4 "$0" "$@" |
---|
4 | |
---|
5 | # widget -- |
---|
6 | # This script demonstrates the various widgets provided by Tk, |
---|
7 | # along with many of the features of the Tk toolkit. This file |
---|
8 | # only contains code to generate the main window for the |
---|
9 | # application, which invokes individual demonstrations. The |
---|
10 | # code for the actual demonstrations is contained in separate |
---|
11 | # ".tcl" files is this directory, which are sourced by this script |
---|
12 | # as needed. |
---|
13 | # |
---|
14 | # RCS: @(#) $Id: widget,v 1.9.2.1 2003/09/25 05:37:48 das Exp $ |
---|
15 | |
---|
16 | eval destroy [winfo child .] |
---|
17 | wm title . "Widget Demonstration" |
---|
18 | if {[tk windowingsystem] eq "x11"} { |
---|
19 | # This won't work everywhere, but there's no other way in core Tk |
---|
20 | # at the moment to display a coloured icon. |
---|
21 | image create photo TclPowered \ |
---|
22 | -file [file join $tk_library images logo64.gif] |
---|
23 | wm iconwindow . [toplevel ._iconWindow] |
---|
24 | pack [label ._iconWindow.i -image TclPowered] |
---|
25 | wm iconname . "tkWidgetDemo" |
---|
26 | } |
---|
27 | |
---|
28 | array set widgetFont { |
---|
29 | main {Helvetica 12} |
---|
30 | bold {Helvetica 12 bold} |
---|
31 | title {Helvetica 18 bold} |
---|
32 | status {Helvetica 10} |
---|
33 | vars {Helvetica 14} |
---|
34 | } |
---|
35 | |
---|
36 | set widgetDemo 1 |
---|
37 | set font $widgetFont(main) |
---|
38 | |
---|
39 | #---------------------------------------------------------------- |
---|
40 | # The code below create the main window, consisting of a menu bar |
---|
41 | # and a text widget that explains how to use the program, plus lists |
---|
42 | # all of the demos as hypertext items. |
---|
43 | #---------------------------------------------------------------- |
---|
44 | |
---|
45 | menu .menuBar -tearoff 0 |
---|
46 | .menuBar add cascade -menu .menuBar.file -label "File" -underline 0 |
---|
47 | menu .menuBar.file -tearoff 0 |
---|
48 | |
---|
49 | # On the Mac use the specia .apple menu for the about item |
---|
50 | if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { |
---|
51 | .menuBar add cascade -menu .menuBar.apple |
---|
52 | menu .menuBar.apple -tearoff 0 |
---|
53 | .menuBar.apple add command -label "About..." -command "aboutBox" |
---|
54 | } else { |
---|
55 | .menuBar.file add command -label "About..." -command "aboutBox" \ |
---|
56 | -underline 0 -accelerator "<F1>" |
---|
57 | .menuBar.file add sep |
---|
58 | } |
---|
59 | |
---|
60 | .menuBar.file add command -label "Quit" -command "exit" -underline 0 \ |
---|
61 | -accelerator "Meta-Q" |
---|
62 | . configure -menu .menuBar |
---|
63 | bind . <F1> aboutBox |
---|
64 | |
---|
65 | frame .statusBar |
---|
66 | label .statusBar.lab -text " " -relief sunken -bd 1 \ |
---|
67 | -font $widgetFont(status) -anchor w |
---|
68 | label .statusBar.foo -width 8 -relief sunken -bd 1 \ |
---|
69 | -font $widgetFont(status) -anchor w |
---|
70 | pack .statusBar.lab -side left -padx 2 -expand yes -fill both |
---|
71 | pack .statusBar.foo -side left -padx 2 |
---|
72 | pack .statusBar -side bottom -fill x -pady 2 |
---|
73 | |
---|
74 | frame .textFrame |
---|
75 | scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ |
---|
76 | -takefocus 1 |
---|
77 | pack .s -in .textFrame -side right -fill y |
---|
78 | text .t -yscrollcommand {.s set} -wrap word -width 70 -height 30 \ |
---|
79 | -font $widgetFont(main) -setgrid 1 -highlightthickness 0 \ |
---|
80 | -padx 4 -pady 2 -takefocus 0 |
---|
81 | pack .t -in .textFrame -expand y -fill both -padx 1 |
---|
82 | pack .textFrame -expand yes -fill both |
---|
83 | |
---|
84 | # Create a bunch of tags to use in the text widget, such as those for |
---|
85 | # section titles and demo descriptions. Also define the bindings for |
---|
86 | # tags. |
---|
87 | |
---|
88 | .t tag configure title -font $widgetFont(title) |
---|
89 | .t tag configure bold -font $widgetFont(bold) |
---|
90 | |
---|
91 | # We put some "space" characters to the left and right of each demo description |
---|
92 | # so that the descriptions are highlighted only when the mouse cursor |
---|
93 | # is right over them (but not when the cursor is to their left or right) |
---|
94 | # |
---|
95 | .t tag configure demospace -lmargin1 1c -lmargin2 1c |
---|
96 | |
---|
97 | |
---|
98 | if {[winfo depth .] == 1} { |
---|
99 | .t tag configure demo -lmargin1 1c -lmargin2 1c \ |
---|
100 | -underline 1 |
---|
101 | .t tag configure visited -lmargin1 1c -lmargin2 1c \ |
---|
102 | -underline 1 |
---|
103 | .t tag configure hot -background black -foreground white |
---|
104 | } else { |
---|
105 | .t tag configure demo -lmargin1 1c -lmargin2 1c \ |
---|
106 | -foreground blue -underline 1 |
---|
107 | .t tag configure visited -lmargin1 1c -lmargin2 1c \ |
---|
108 | -foreground #303080 -underline 1 |
---|
109 | .t tag configure hot -foreground red -underline 1 |
---|
110 | } |
---|
111 | .t tag bind demo <ButtonRelease-1> { |
---|
112 | invoke [.t index {@%x,%y}] |
---|
113 | } |
---|
114 | set lastLine "" |
---|
115 | .t tag bind demo <Enter> { |
---|
116 | set lastLine [.t index {@%x,%y linestart}] |
---|
117 | .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" |
---|
118 | .t config -cursor hand2 |
---|
119 | showStatus [.t index {@%x,%y}] |
---|
120 | } |
---|
121 | .t tag bind demo <Leave> { |
---|
122 | .t tag remove hot 1.0 end |
---|
123 | .t config -cursor xterm |
---|
124 | .statusBar.lab config -text "" |
---|
125 | } |
---|
126 | .t tag bind demo <Motion> { |
---|
127 | set newLine [.t index {@%x,%y linestart}] |
---|
128 | if {[string compare $newLine $lastLine] != 0} { |
---|
129 | .t tag remove hot 1.0 end |
---|
130 | set lastLine $newLine |
---|
131 | |
---|
132 | set tags [.t tag names {@%x,%y}] |
---|
133 | set i [lsearch -glob $tags demo-*] |
---|
134 | if {$i >= 0} { |
---|
135 | .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" |
---|
136 | } |
---|
137 | } |
---|
138 | showStatus [.t index {@%x,%y}] |
---|
139 | } |
---|
140 | |
---|
141 | # Create the text for the text widget. |
---|
142 | |
---|
143 | proc addDemoSection {title demos} { |
---|
144 | .t insert end "\n" {} $title title " \n " demospace |
---|
145 | set num 0 |
---|
146 | foreach {name description} $demos { |
---|
147 | .t insert end "[incr num]. $description." [list demo demo-$name] |
---|
148 | .t insert end " \n " demospace |
---|
149 | } |
---|
150 | } |
---|
151 | |
---|
152 | .t insert end "Tk Widget Demonstrations\n" title |
---|
153 | .t insert end "\nThis application provides a front end for several short\ |
---|
154 | scripts that demonstrate what you can do with Tk widgets. Each of\ |
---|
155 | the numbered lines below describes a demonstration; you can click\ |
---|
156 | on it to invoke the demonstration. Once the demonstration window\ |
---|
157 | appears, you can click the " {} "See Code" bold " button to see the\ |
---|
158 | Tcl/Tk code that created the demonstration. If you wish, you can\ |
---|
159 | edit the code and click the " {} "Rerun Demo" bold " button in the\ |
---|
160 | code window to reinvoke the demonstration with the modified code.\n" |
---|
161 | |
---|
162 | addDemoSection "Labels, buttons, checkbuttons, and radiobuttons" { |
---|
163 | label "Labels (text and bitmaps)" |
---|
164 | unicodeout "Labels and UNICODE text" |
---|
165 | button "Buttons" |
---|
166 | check "Check-buttons (select any of a group)" |
---|
167 | radio "Radio-buttons (select one of a group)" |
---|
168 | puzzle "A 15-puzzle game made out of buttons" |
---|
169 | icon "Iconic buttons that use bitmaps" |
---|
170 | image1 "Two labels displaying images" |
---|
171 | image2 "A simple user interface for viewing images" |
---|
172 | labelframe "Labelled frames" |
---|
173 | } |
---|
174 | addDemoSection "Listboxes" { |
---|
175 | states "The 50 states" |
---|
176 | colors "Colors: change the color scheme for the application" |
---|
177 | sayings "A collection of famous and infamous sayings" |
---|
178 | } |
---|
179 | addDemoSection "Entries and Spin-boxes" { |
---|
180 | entry1 "Entries without scrollbars" |
---|
181 | entry2 "Entries with scrollbars" |
---|
182 | entry3 "Validated entries and password fields" |
---|
183 | spin "Spin-boxes" |
---|
184 | form "Simple Rolodex-like form" |
---|
185 | } |
---|
186 | addDemoSection "Text" { |
---|
187 | text "Basic editable text" |
---|
188 | style "Text display styles" |
---|
189 | bind "Hypertext (tag bindings)" |
---|
190 | twind "A text widget with embedded windows" |
---|
191 | search "A search tool built with a text widget" |
---|
192 | } |
---|
193 | addDemoSection "Canvases" { |
---|
194 | items "The canvas item types" |
---|
195 | plot "A simple 2-D plot" |
---|
196 | ctext "Text items in canvases" |
---|
197 | arrow "An editor for arrowheads on canvas lines" |
---|
198 | ruler "A ruler with adjustable tab stops" |
---|
199 | floor "A building floor plan" |
---|
200 | cscroll "A simple scrollable canvas" |
---|
201 | } |
---|
202 | addDemoSection "Scales" { |
---|
203 | hscale "Horizontal scale" |
---|
204 | vscale "Vertical scale" |
---|
205 | } |
---|
206 | addDemoSection "Paned Windows" { |
---|
207 | paned1 "Horizontal paned window" |
---|
208 | paned2 "Vertical paned window" |
---|
209 | } |
---|
210 | addDemoSection "Menus" { |
---|
211 | menu "Menus and cascades (sub-menus)" |
---|
212 | menubu "Menu-buttons" |
---|
213 | } |
---|
214 | addDemoSection "Common Dialogs" { |
---|
215 | msgbox "Message boxes" |
---|
216 | filebox "File selection dialog" |
---|
217 | clrpick "Color picker" |
---|
218 | } |
---|
219 | addDemoSection "Miscellaneous" { |
---|
220 | bitmap "The built-in bitmaps" |
---|
221 | dialog1 "A dialog box with a local grab" |
---|
222 | dialog2 "A dialog box with a global grab" |
---|
223 | } |
---|
224 | |
---|
225 | .t configure -state disabled |
---|
226 | focus .s |
---|
227 | |
---|
228 | # positionWindow -- |
---|
229 | # This procedure is invoked by most of the demos to position a |
---|
230 | # new demo window. |
---|
231 | # |
---|
232 | # Arguments: |
---|
233 | # w - The name of the window to position. |
---|
234 | |
---|
235 | proc positionWindow w { |
---|
236 | wm geometry $w +300+300 |
---|
237 | } |
---|
238 | |
---|
239 | # showVars -- |
---|
240 | # Displays the values of one or more variables in a window, and |
---|
241 | # updates the display whenever any of the variables changes. |
---|
242 | # |
---|
243 | # Arguments: |
---|
244 | # w - Name of new window to create for display. |
---|
245 | # args - Any number of names of variables. |
---|
246 | |
---|
247 | proc showVars {w args} { |
---|
248 | global widgetFont |
---|
249 | catch {destroy $w} |
---|
250 | toplevel $w |
---|
251 | wm title $w "Variable values" |
---|
252 | label $w.title -text "Variable values:" -width 20 -anchor center \ |
---|
253 | -font $widgetFont(vars) |
---|
254 | pack $w.title -side top -fill x |
---|
255 | set len 1 |
---|
256 | foreach i $args { |
---|
257 | if {[string length $i] > $len} { |
---|
258 | set len [string length $i] |
---|
259 | } |
---|
260 | } |
---|
261 | foreach i $args { |
---|
262 | frame $w.$i |
---|
263 | label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w |
---|
264 | label $w.$i.value -textvar $i -anchor w |
---|
265 | pack $w.$i.name -side left |
---|
266 | pack $w.$i.value -side left -expand 1 -fill x |
---|
267 | pack $w.$i -side top -anchor w -fill x |
---|
268 | } |
---|
269 | button $w.ok -text OK -command "destroy $w" -default active |
---|
270 | bind $w <Return> "tkButtonInvoke $w.ok" |
---|
271 | pack $w.ok -side bottom -pady 2 |
---|
272 | } |
---|
273 | |
---|
274 | # invoke -- |
---|
275 | # This procedure is called when the user clicks on a demo description. |
---|
276 | # It is responsible for invoking the demonstration. |
---|
277 | # |
---|
278 | # Arguments: |
---|
279 | # index - The index of the character that the user clicked on. |
---|
280 | |
---|
281 | proc invoke index { |
---|
282 | global tk_library |
---|
283 | set tags [.t tag names $index] |
---|
284 | set i [lsearch -glob $tags demo-*] |
---|
285 | if {$i < 0} { |
---|
286 | return |
---|
287 | } |
---|
288 | set cursor [.t cget -cursor] |
---|
289 | .t configure -cursor watch |
---|
290 | update |
---|
291 | set demo [string range [lindex $tags $i] 5 end] |
---|
292 | uplevel [list source [file join $tk_library demos $demo.tcl]] |
---|
293 | update |
---|
294 | .t configure -cursor $cursor |
---|
295 | |
---|
296 | .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" |
---|
297 | } |
---|
298 | |
---|
299 | # showStatus -- |
---|
300 | # |
---|
301 | # Show the name of the demo program in the status bar. This procedure |
---|
302 | # is called when the user moves the cursor over a demo description. |
---|
303 | # |
---|
304 | proc showStatus index { |
---|
305 | global tk_library |
---|
306 | set tags [.t tag names $index] |
---|
307 | set i [lsearch -glob $tags demo-*] |
---|
308 | set cursor [.t cget -cursor] |
---|
309 | if {$i < 0} { |
---|
310 | .statusBar.lab config -text " " |
---|
311 | set newcursor xterm |
---|
312 | } else { |
---|
313 | set demo [string range [lindex $tags $i] 5 end] |
---|
314 | .statusBar.lab config -text "Run the \"$demo\" sample program" |
---|
315 | set newcursor hand2 |
---|
316 | } |
---|
317 | if [string compare $cursor $newcursor] { |
---|
318 | .t config -cursor $newcursor |
---|
319 | } |
---|
320 | } |
---|
321 | |
---|
322 | |
---|
323 | # showCode -- |
---|
324 | # This procedure creates a toplevel window that displays the code for |
---|
325 | # a demonstration and allows it to be edited and reinvoked. |
---|
326 | # |
---|
327 | # Arguments: |
---|
328 | # w - The name of the demonstration's window, which can be |
---|
329 | # used to derive the name of the file containing its code. |
---|
330 | |
---|
331 | proc showCode w { |
---|
332 | global tk_library |
---|
333 | set file [string range $w 1 end].tcl |
---|
334 | if ![winfo exists .code] { |
---|
335 | toplevel .code |
---|
336 | frame .code.buttons |
---|
337 | pack .code.buttons -side bottom -fill x |
---|
338 | button .code.buttons.dismiss -text Dismiss \ |
---|
339 | -default active -command "destroy .code" |
---|
340 | button .code.buttons.rerun -text "Rerun Demo" -command { |
---|
341 | eval [.code.text get 1.0 end] |
---|
342 | } |
---|
343 | pack .code.buttons.dismiss .code.buttons.rerun -side left \ |
---|
344 | -expand 1 -pady 2 |
---|
345 | frame .code.frame |
---|
346 | pack .code.frame -expand yes -fill both -padx 1 -pady 1 |
---|
347 | text .code.text -height 40 -wrap word\ |
---|
348 | -xscrollcommand ".code.xscroll set" \ |
---|
349 | -yscrollcommand ".code.yscroll set" \ |
---|
350 | -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 |
---|
351 | scrollbar .code.xscroll -command ".code.text xview" \ |
---|
352 | -highlightthickness 0 -orient horizontal |
---|
353 | scrollbar .code.yscroll -command ".code.text yview" \ |
---|
354 | -highlightthickness 0 -orient vertical |
---|
355 | |
---|
356 | grid .code.text -in .code.frame -padx 1 -pady 1 \ |
---|
357 | -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news |
---|
358 | grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ |
---|
359 | -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news |
---|
360 | # grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ |
---|
361 | # -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news |
---|
362 | grid rowconfig .code.frame 0 -weight 1 -minsize 0 |
---|
363 | grid columnconfig .code.frame 0 -weight 1 -minsize 0 |
---|
364 | } else { |
---|
365 | wm deiconify .code |
---|
366 | raise .code |
---|
367 | } |
---|
368 | wm title .code "Demo code: [file join $tk_library demos $file]" |
---|
369 | wm iconname .code $file |
---|
370 | set id [open [file join $tk_library demos $file]] |
---|
371 | .code.text delete 1.0 end |
---|
372 | .code.text insert 1.0 [read $id] |
---|
373 | .code.text mark set insert 1.0 |
---|
374 | close $id |
---|
375 | } |
---|
376 | |
---|
377 | # aboutBox -- |
---|
378 | # |
---|
379 | # Pops up a message box with an "about" message |
---|
380 | # |
---|
381 | proc aboutBox {} { |
---|
382 | tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ |
---|
383 | "Tk widget demonstration |
---|
384 | |
---|
385 | Copyright (c) 1996-1997 Sun Microsystems, Inc. |
---|
386 | |
---|
387 | Copyright (c) 1997-2000 Ajuba Solutions, Inc. |
---|
388 | |
---|
389 | Copyright (c) 2001-2002 Donal K. Fellows" |
---|
390 | } |
---|
391 | |
---|
392 | # Local Variables: |
---|
393 | # mode: tcl |
---|
394 | # End: |
---|