1 # ui-notebook.tcl --
2 #
3 # Defines widgets that server as a substitute for Tk tab widget
4 #
5 # Copyright (c) 1997-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30
31
32 # Known "Issues"
33 #
34 # can't do a tab-config
35 # buttonRelease works even if cursor leaves tab
36 # doesn't do sideways tabs, or multilayer tabs
37 # Can't change tabs, etc once they are set up
38
39 #provide notebook
40
41 namespace eval NotebookWidget {
42
43 # The valid widget commands
44 set commands {configure cget index addTab addFrame addCommand tabPress}
45
46 # The valid widget configuration options
47 set options {
48 -height -width -tabheight -tabwidth -tabpadx -bd -bg -fg -variable -font
49 }
50
51 # Defaults for the options listed above
52 set defaults(-height) 200
53 set defaults(-width) 400
54 set defaults(-tabheight) 30
55 set defaults(-tabwidth) 0
56 set defaults(-font) {Helvetica -12 bold}
57 set defaults(-bd) 2
58 set defaults(-bg) gray87
59 set defaults(-fg) black
60 set defaults(-tabpadx) 5
61 set defaults(-variable) {}
62
63 # This command is exported outside this module
64 proc notebook {n args} {
65 eval newWidget $n $args
66 }
67
68 # Creates a new notebook widget
69 #
70 proc newWidget {n args} {
71 variable options
72 variable defaults
73
74 # Initialize widget options to defaults
75 foreach o $options {
76 vset $n $o $defaults($o)
77 }
78
79 eval configure $n $args
80 getMemberVars $n
81
82 # Calculate light and dark bg colors
83 calcBG $n
84
85 # Create canvas that contains notebook
86 set pad 2
87 incr height [expr 2*$pad]
88 incr width [expr 2*$pad]
89 canvas $n -height $height -width $width -bg $bg -highlightthickness 0
90 bind $n <Configure> "NotebookWidget::resizeContentsFrame $n"
91
92 # Create the frame which holds the notebook's "contents"
93 vset $n pad $pad
94 createContentsFrame $n frame frame_ids
95 vset $n frame $frame
96 vset $n frame_ids $frame_ids
97
98 # Initialize some values for the notebook
99 vset $n numtabs 0
100 vset $n activeTab -1
101 vset $n tabOffset [expr $pad+$bd]
102 vset $n callback 0
103 # Export the canvas's name as the notebook's widget procedure
104 if {[info commands _$n] != ""} {
105 rename _$n ""
106 }
107 rename $n _$n
108 proc $n {command args} "eval widgetCommand \$command $n \$args"
109 namespace export $n
110 namespace eval [namespace parent] "namespace import NotebookWidget::$n"
111
112 return $n
113 }
114
115 # Called when the user invokes a command on a notebook widget
116 # Checks to make sure command is valid, then dispatches command.
117 #
118 proc widgetCommand {command n args} {
119 variable commands
120
121 if {[lsearch $commands $command] < 0} {
122 error "bad option \"$command\": must be one of $commands"
123 }
124 eval $command $n $args
125 }
126
127 #### WIDGET COMMANDS ###############
128
129 # Works like the standard Tk widget command config,
130 # except that it returns list of {-switch default value} lists.
131 #
132 proc configure {n args} {
133 variable $n
134 variable options
135 variable defaults
136
137 set len [llength $args]
138 if {$len == 0} {
139 foreach switch $options {
140 lappend results [list $switch $defaults($switch) [cget $n $switch]]
141 }
142 return $results
143 }
144 if {$len == 1} {
145 return [eval cget $n $args]
146 }
147 if {$len > 1} {
148 for {set i 0} {$i < $len} {incr i 2} {
149 cset $n [lindex $args $i] [lindex $args [expr $i+1]]
150 }
151 }
152 }
153
154 # Used to get a particular widget configuration option.
155 # Checks for valididy of option, wrapper around vget
156 #
157 proc cget {n switch} {
158 variable options
159
160 if {[lsearch $options $switch] < 0} {
161 error "unknown option \"$switch\""
162 } else {
163 return [vget $n $switch]
164 }
165 }
166
167
168 # Creates a new tab with name "label". It should be associate
169 # with a frame later
170 #
171 proc addTab {n label} {
172 set t [vget $n numtabs]
173
174 createTab $n $label win ids
175
176 bind $win <ButtonRelease-1> "$n tabPress $t"
177
178 vset $n tab${t}_win $win
179 vset $n tab${t}_ids $ids
180
181 activateTab $n $t
182 deactivateTab $n $t
183 vset $n numtabs [expr $t+1]
184 }
185
186 # Associates a frame with a particular tab
187 #
188 proc addFrame {n frame tab args} {
189 set total [vget $n numtabs]
190
191 if {$tab < 0 || $tab >= $total} {
192 error "bad tab \"$tab\": want range \[0 [expr $total-1]\]"
193 }
194 vset $n frame${tab} $frame
195 vset $n frame${tab}_args $args
196
197 if {[vget $n activeTab] == $tab} {
198 tabPress $n $tab
199 }
200 }
201
202 # Associates a command with a particular tab
203 #
204 proc addCommand {n tab command} {
205 set total [vget $n numtabs]
206
207 if {$tab < 0 || $tab >= $total} {
208 error "bad tab \"$tab\": want range \[0 [expr $total-1]\]"
209 }
210 vset $n command${tab} $command
211 }
212
213 # Shows the contents for the current tab. Bound to a button
214 # press on a tab or can be called explicitly
215 #
216 proc tabPress {n newTab} {
217 if [vget $n callback] {
218 return
219 }
220
221 set total [vget $n numtabs]
222 set t [vget $n activeTab]
223 set contents [vget $n frame]
224
225 if {$newTab < 0 || $newTab >= $total} {
226 error "bad tab \"$newTab\": want range \[0 [expr $total-1]\]"
227 }
228
229 catch {deactivateTab $n $t}
230 activateTab $n $newTab
231 vset $n activeTab $newTab
232
233 if {[catch {vget $n frame${t}} frame] == 0} {
234 pack forget $frame
235 }
236 if {[catch {vget $n frame${newTab}} frame] == 0} {
237 set packArgs [vget $n frame${newTab}_args]
238 eval pack $frame -in $contents $packArgs
239 }
240 if {[catch {vget $n command${newTab}} command] == 0} {
241 uplevel #0 $command
242 }
243
244 set traceVar [vget $n -variable]
245 if {$traceVar != {}} {
246 vset $n callback 1
247 global $traceVar
248 set $traceVar $newTab
249 vset $n callback 0
250 }
251 }
252
253 # Returns the currently active tab index
254 #
255 proc index {n} {
256 variable $n
257 return [vget $n activeTab]
258 }
259
260 #### LOCAL PROCEDURES ###############
261
262 # given a background color, calculate the light and dark versions
263 # for shadows on tabs
264 proc calcBG {n} {
265 #set rgb [winfo rgb $n [cget $n -bg]]
266 set rgb [winfo rgb . [cget $n -bg]]
267 set r [lindex $rgb 0]
268 set g [lindex $rgb 1]
269 set b [lindex $rgb 2]
270
271 set dr [expr $r*3/5]
272 set dg [expr $g*3/5]
273 set db [expr $b*3/5]
274
275 set l1 [expr $r*7/5]
276 if {$l1 > 65535} {
277 set lr 65535
278 } else {
279 set l2 [expr (65535+$r)/2]
280 if {$l1 > $l2} { set lr $l1 } else { set lr $l2 }
281 }
282
283 set l1 [expr $g*7/5]
284 if {$l1 > 65535} {
285 set lg 65535
286 } else {
287 set l2 [expr (65535+$g)/2]
288 if {$l1 > $l2} { set lg $l1 } else { set lg $l2 }
289 }
290
291 set l1 [expr $b*7/5]
292 if {$l1 > 65535} {
293 set lb 65535
294 } else {
295 set l2 [expr (65535+$b)/2]
296 if {$l1 > $l2} { set lb $l1 } else { set lb $l2 }
297 }
298
299 vset $n bgd [format "#%04x%04x%04x" $dr $dg $db]
300 vset $n bgl [format "#%04x%04x%04x" $lr $lg $lb]
301 }
302
303 # Used to set a particular widget configuration option.
304 # Checks for valididy of option, wrapper around vset
305 #
306 proc cset {n switch value} {
307 variable options
308
309 if {[lsearch $options $switch] < 0} {
310 error "unknown option \"$switch\""
311 }
312
313 # Code to be evaluated before certain options change
314 switch -- $switch {
315 -variable {
316 global [vget $n -variable]
317 trace vdelete [vget $n -variable] w "NotebookWidget::callback $n"
318 }
319 }
320
321 vset $n $switch $value
322
323 # Code to be evaluated after certain options change
324 switch -- $switch {
325 -variable {
326 global $value
327 trace variable $value w "NotebookWidget::callback $n"
328 }
329 -bg {
330 calcBG $n
331 }
332 }
333 }
334
335 # Sets a member variable in a notebook widget
336 proc vset {n switch value} {
337 variable $n
338 set ${n}($switch) $value
339 }
340
341 # Gets a member variable in a notebook widget
342 proc vget {n switch} {
343 variable $n
344 return [set ${n}($switch)]
345 }
346
347 proc callback {n var nothing op} {
348 upvar $var index
349 tabPress $n $index
350 }
351
352 # Cool utility function that fetches all of the notebook's member
353 # variables into the local scope, removing dashes from "-switches"
354 #
355 proc getMemberVars {n} {
356 variable $n
357 foreach o [array names $n] {
358 if {[string index $o 0] == "-"} {
359 upvar [string range $o 1 end] opt
360 } else {
361 upvar $o opt
362 }
363 set opt [vget $n $o]
364 }
365 }
366
367 set tnum 0
368 set cnum 0
369
370 # Creates an tab and adds it to the
371 # notebook's canvas
372 #
373 proc createTab {n text win_ptr ids_ptr} {
374 variable tnum
375 upvar $win_ptr win $ids_ptr ids
376 getMemberVars $n
377
378 set win [label $n.t[incr tnum] -text $text -bg $bg -fg $fg -padx $tabpadx -font $font]
379
380 set x $tabOffset
381 set y $pad
382 set w [expr $tabwidth ? $tabwidth : [winfo reqwidth $win]]
383 set h $tabheight
384
385 # label window
386 lappend ids [_$n create window [expr $x+$bd] [expr $y+$bd] \
387 -height [expr $h-2*$bd] -width [expr $w-2*$bd] \
388 -window $win -anchor nw]
389 # left strip
390 lappend ids [_$n create rectangle $x [expr $y+$bd] [expr $x+$bd] \
391 [expr $y+$h-$bd] -fill $bgl -outline {}]
392 # left arc
393 lappend ids [_$n create arc $x $y [expr $x+2*$bd] [expr $y+2*$bd] \
394 -extent 90 -start 90 -fill $bgl -outline {}]
395 # top strip
396 lappend ids [_$n create rectangle [expr $x+$bd] $y \
397 [expr $x+$w-$bd] [expr $y+$bd] -fill $bgl -outline {}]
398 # right arc
399 lappend ids [_$n create arc [expr $x+$w-2*$bd] $y \
400 [expr $x+$w] [expr $y+2*$bd] -extent 90 -start 0 \
401 -fill $bgd -outline {}]
402 # right strip
403 lappend ids [_$n create rectangle [expr $x+$w-$bd] \
404 [expr $y+$bd] [expr $x+$w] [expr $y+$h-$bd] \
405 -fill $bgd -outline {}]
406 # bottom strip
407 lappend ids [_$n create rectangle [expr $x+$bd] [expr $y+$h-$bd] \
408 [expr $x+$w-$bd] [expr $y+$h] -fill $bg -outline {}]
409
410 vset $n tabOffset [expr $tabOffset+$w+1]
411 }
412
413 # Changes look of tab when it is activated
414 #
415 proc activateTab {n tab} {
416 variable $n
417
418 set ids [vget $n tab${tab}_ids]
419 set bd [vget $n -bd]
420
421 # Resize each part of tab in turn
422 # window
423 set id [lindex $ids 0]
424 set coords [_$n coords $id]
425 _$n coords $id [expr [lindex $coords 0]-$bd] [expr [lindex $coords 1]-$bd]
426 # left strip
427 set id [lindex $ids 1]
428 set coords [_$n coords $id]
429 _$n coords $id [expr [lindex $coords 0]-$bd] [expr [lindex $coords 1]-$bd] \
430 [expr [lindex $coords 2]-$bd] [lindex $coords 3]
431 _$n raise $id
432 # left arc
433 set id [lindex $ids 2]
434 set coords [_$n coords $id]
435 _$n coords $id [expr [lindex $coords 0]-$bd] [expr [lindex $coords 1]-$bd] \
436 [expr [lindex $coords 2]-$bd] [expr [lindex $coords 3]-$bd]
437 # top strip
438 set id [lindex $ids 3]
439 set coords [_$n coords $id]
440 _$n coords $id [expr [lindex $coords 0]-$bd] [expr [lindex $coords 1]-$bd] \
441 [expr [lindex $coords 2]+$bd] [expr [lindex $coords 3]-$bd]
442 # right arc
443 set id [lindex $ids 4]
444 set coords [_$n coords $id]
445 _$n coords $id [expr [lindex $coords 0]+$bd] [expr [lindex $coords 1]-$bd] \
446 [expr [lindex $coords 2]+$bd] [expr [lindex $coords 3]-$bd]
447 # right strip
448 set id [lindex $ids 5]
449 set coords [_$n coords $id]
450 _$n coords $id [expr [lindex $coords 0]+$bd] [expr [lindex $coords 1]-$bd] \
451 [expr [lindex $coords 2]+$bd] [lindex $coords 3]
452 _$n raise $id
453 # bottom strip
454 set id [lindex $ids 6]
455 set coords [_$n coords $id]
456 _$n coords $id [expr [lindex $coords 0]-$bd] [lindex $coords 1] \
457 [expr [lindex $coords 2]+$bd] [lindex $coords 3]
458
459 _$n raise $id
460 }
461
462
463 # Changes look of tab back to normal
464 #
465 proc deactivateTab {n tab} {
466 variable $n
467
468 set ids [vget $n tab${tab}_ids]
469 set bd [vget $n -bd]
470
471 # Resize each part of tab in turn
472 # window
473 set id [lindex $ids 0]
474 set coords [_$n coords $id]
475 _$n coords $id [expr [lindex $coords 0]+$bd] [expr [lindex $coords 1]+$bd]
476 # left strip
477 set id [lindex $ids 1]
478 set coords [_$n coords $id]
479 _$n coords $id [expr [lindex $coords 0]+$bd] [expr [lindex $coords 1]+$bd] \
480 [expr [lindex $coords 2]+$bd] [lindex $coords 3]
481 # left arc
482 set id [lindex $ids 2]
483 set coords [_$n coords $id]
484 _$n coords $id [expr [lindex $coords 0]+$bd] [expr [lindex $coords 1]+$bd] \
485 [expr [lindex $coords 2]+$bd] [expr [lindex $coords 3]+$bd]
486 # top strip
487 set id [lindex $ids 3]
488 set coords [_$n coords $id]
489 _$n coords $id [expr [lindex $coords 0]+$bd] [expr [lindex $coords 1]+$bd] \
490 [expr [lindex $coords 2]-$bd] [expr [lindex $coords 3]+$bd]
491 # right arc
492 set id [lindex $ids 4]
493 set coords [_$n coords $id]
494 _$n coords $id [expr [lindex $coords 0]-$bd] [expr [lindex $coords 1]+$bd] \
495 [expr [lindex $coords 2]-$bd] [expr [lindex $coords 3]+$bd]
496 # right strip
497 set id [lindex $ids 5]
498 set coords [_$n coords $id]
499 _$n coords $id [expr [lindex $coords 0]-$bd] [expr [lindex $coords 1]+$bd] \
500 [expr [lindex $coords 2]-$bd] [lindex $coords 3]
501 _$n raise $id
502 # bottom strip
503 set id [lindex $ids 6]
504 set coords [_$n coords $id]
505 _$n coords $id [expr [lindex $coords 0]+$bd] [lindex $coords 1] \
506 [expr [lindex $coords 2]-$bd] [lindex $coords 3]
507 _$n lower $id
508 }
509
510 # Creates an empty frame (used for the contents) and adds it to the
511 # notebook's canvas
512 #
513 proc createContentsFrame {n win_ptr ids_ptr} {
514 variable cnum
515 upvar $win_ptr win $ids_ptr ids
516 getMemberVars $n
517
518 set win [frame $n.c[incr cnum] -bg $bg]
519 pack propagate $win 0
520 grid propagate $win 0
521
522 set x $pad
523 set y [expr $tabheight-$bd+$pad]
524 set height [expr $height-$tabheight+$bd-$pad]
525
526 # create frame
527 lappend ids [$n create window [expr $x+$bd] [expr $y+$bd] \
528 -height [expr $height - 2*$bd] -width [expr $width - 2*$bd] \
529 -window $win -anchor nw]
530 # left strip
531 lappend ids [$n create rectangle $x $y [expr $x+$bd] [expr $y+$height] -fill $bgl -outline {}]
532 # top strip
533 lappend ids [$n create rectangle $x $y [expr $x+$width] [expr $y+$bd] -fill $bgl -outline {}]
534 # right strip
535 lappend ids [$n create rectangle [expr $x+$width-$bd] [expr $y+$bd] [expr $x+$width] [expr $y+$height] -fill $bgd -outline {}]
536 # bottom strip
537 lappend ids [$n create rectangle [expr $x+$width] [expr $y+$height] [expr $x+$bd] [expr $y+$height-$bd] -fill $bgd -outline {}]
538 }
539
540 proc resizeContentsFrame {n} {
541 variable $n
542 getMemberVars $n
543
544 # Get new height and width of canvas
545 set height [expr [winfo height $n] - 2]
546 set width [expr [winfo width $n] - 2]
547
548 set win [vget $n frame]
549 set ids [vget $n frame_ids]
550
551 set x $pad
552 set y [expr $tabheight-$bd+$pad]
553 set height [expr $height-$tabheight+$bd-$pad]
554
555 # frame id
556 set id [lindex $ids 0]
557 _$n coords $id [expr $x+$bd] [expr $y+$bd]
558 _$n itemconfigure $id -height [expr $height - 2*$bd] -width [expr $width - 2*$bd]
559 # left strip id
560 set id [lindex $ids 1]
561 _$n coords $id $x $y [expr $x+$bd] [expr $y+$height]
562 # top strip id
563 set id [lindex $ids 2]
564 _$n coords $id $x $y [expr $x+$width] [expr $y+$bd]
565 # right strip id
566 set id [lindex $ids 3]
567 _$n coords $id [expr $x+$width-$bd] [expr $y+$bd] [expr $x+$width] [expr $y+$height]
568 # bottom strip id
569 set id [lindex $ids 4]
570 _$n coords $id [expr $x+$width] [expr $y+$height] [expr $x+$bd] [expr $y+$height-$bd]
571 }
572
573
574
575 namespace export notebook
576
577 }
578
579 namespace import NotebookWidget::notebook
580
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.