1##
2## Copyright 1997-8 Jeffrey Hobbs, jeff.hobbs@acm.org, CADIX International
3##
4package require Widget 2.0
5package provide Tabnotebook 2.0
6
7## FIX:
8## option state of subitems could be kept in a clearer array
9
10##------------------------------------------------------------------------
11## PROCEDURE
12##	tabnotebook
13##
14## DESCRIPTION
15##	Implements a Tabbed Notebook megawidget
16##
17## ARGUMENTS
18##	tabnote <window pathname> <options>
19##
20## OPTIONS
21##	(Any entry widget option may be used in addition to these)
22##
23## -activebackground color		DEFAULT: {}
24##	The background color given to the active tab.  A value of {}
25##	means these items will pick up the widget's background color.
26##
27## -background color			DEFAULT: DEFAULT
28##	The background color for the container subwidgets.
29##
30## -browsecmd script			DEFAULT: {}
31##	A script that is evaluated each time a tab changes.  It appends
32##	the old tab and the new tab to the script.  An empty string ({})
33##	represents the blank (empty) tab.  This is eval'ed before the
34##	tab actually changes, allowing tab transitions to be aborted by
35##	returning an error value in this script.
36##
37## -disabledbackground color		DEFAULT: #c0c0c0 (dark gray)
38##	The background color given to disabled tabs.
39##
40## -font				DEFAULT: {Helvetica -12}
41##	The font for the tab text.  All tabs use the same font.
42##
43## -justify justification		DEFAULT: center
44##	The justification applied to the text in multi-line tabs.
45##	Must be one of: left, right, center.
46##
47## -linewidth pixels			DEFAULT: 2
48##	The width of the line surrounding the tabs.  Must be at least 1.
49##
50## -linecolor color			DEFAULT: black
51##	The color of the line surrounding the tabs.
52##
53## -normalbackground			DEFAULT: {}
54##	The background color of items with normal state.  A value of {}
55##	means these items will pick up the widget's background color.
56##
57## -padx pixels				DEFAULT: 6
58##	The X padding for folder tabs around the items.
59##
60## -pady pixels				DEFAULT: 4
61##	The Y padding for folder tabs around the items.
62##
63## RETURNS: the window pathname
64##
65## BINDINGS (in addition to default widget bindings)
66##
67## <1> in a tabs activates that tab.
68##
69## METHODS
70##	These are the methods that the Tabnote widget recognizes.  Aside from
71##	these, it accepts methods that are valid for entry widgets.
72##
73## activate id
74##	Activates the tab specified by id.  id may either by the unique id
75##	returned by the add command or the string used in the add command.
76##
77## add string ?options?
78##	Adds a tab to the tab notebook with the specified string, unless
79##	the string is the name of an image, in which case the image is used.
80##	Each string must be unique.  See ITEM OPTIONS for the options.
81##	A unique tab id is returned.
82##
83## delete id
84##	Deletes the tab specified by id.  id may either by the unique id
85##	returned by the add command or the string used in the add command.
86##
87## itemconfigure ?option? ?value option value ...?
88## itemcget option
89##	Configure or retrieve the option of a tab notebook item.
90##
91## name tabId
92##	Returns the text name for a given tabId.
93##
94## subwidget widget
95##	Returns the true widget path of the specified widget.  Valid
96##	widgets are hold (a frame), tabs (a canvas), blank (a frame).
97##
98## ITEM OPTIONS
99##	These are options for the items (tabs) of the notebook
100##
101## -window widget				DEFAULT: {}
102##	Specifies the widget to show when the tab is pressed.  It must be
103##	a child of the tab notebook (required for grid management) and exist
104##	prior to this command.
105##
106## -state normal|disabled|active		DEFAULT: normal
107##	The optional state can be normal, active or disabled.
108##	If active, then this tab becomes the active (displayed) tab.
109##
110## NAMESPACE & STATE
111##	The megawidget creates a global array with the classname, and a
112## global array which is the name of each megawidget is created.  The latter
113## array is deleted when the megawidget is destroyed.
114##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
115## Other procs that begin with $CLASSNAME are private.  For each widget,
116## commands named .$widgetname and $CLASSNAME$widgetname are created.
117##
118## EXAMPLE USAGE:
119##
120## pack [tabnotebook .t] -fill both -expand 1
121## text .t.t -height 10 -width 20
122## .t add "Text Widget" -window .t.t
123##------------------------------------------------------------------------
124
125# Create this to make sure there are registered in auto_mkindex
126# these must come before the [widget create ...]
127proc Tabnotebook args {}
128proc tabnotebook args {}
129
130widget create Tabnotebook -type frame -base frame -components {
131    {frame hold hold {-relief raised -bd 1}}
132    {frame blank}
133    {frame hide hide {-background $data(-background) -height 1 -width 40}}
134    {canvas tabs tabs {-bg $data(-background) -highlightthick 0 -takefocus 0}}
135} -options {
136    {-activebackground	activeBackground ActiveBackground {}}
137    {-bg		-background}
138    {-background	ALIAS frame -background}
139    {-bd		-borderwidth}
140    {-borderwidth	ALIAS frame -borderwidth}
141    {-browsecmd		browseCmd	BrowseCommand	{}}
142    {-disabledbackground	disabledBackground DisabledBackground #a3a3a3}
143    {-normalbackground	normalBackground normalBackground #c3c3c3}
144    {-font		font		Font		{Helvetica -12}}
145    {-justify		justify		Justify		center}
146    {-minwidth		minWidth	Width		-1}
147    {-minheight		minHeight	Height		-1}
148    {-padx		padX		PadX		6}
149    {-pady		padY		PadY		4}
150    {-relief		ALIAS frame -relief}
151    {-linewidth		lineWidth	LineWidth	1}
152    {-linecolor		lineColor	LineColor	black}
153}
154
155namespace eval ::Widget::Tabnotebook {;
156
157;proc construct {w} {
158    upvar \#0 [namespace current]::$w data
159
160    ## Private variables
161    array set data {
162	curtab	{}
163	numtabs	0
164	width	0
165	height	0
166	ids	{}
167    }
168
169    $data(tabs) itemconfigure TEXT -font $data(-font)
170
171    $data(tabs) yview moveto 0
172    $data(tabs) xview moveto 0
173
174    grid $data(tabs) -sticky ew
175    grid $data(hold) -sticky news
176    grid $data(blank) -in $data(hold) -row 0 -column 0 -sticky nsew
177    grid columnconfig $w 0 -weight 1
178    grid rowconfigure $w 1 -weight 1
179    grid columnconfig $data(hold) 0 -weight 1
180    grid rowconfigure $data(hold) 0 -weight 1
181
182    bind $data(tabs) <Configure> [namespace code \
183	    "if {!\[string compare $data(tabs) %W\]} { resize [list $w] %w }"]
184    bind $data(tabs) <2>		{ %W scan mark %x 0 }
185    bind $data(tabs) <B2-Motion>	[namespace code {
186	%W scan dragto %x 0
187	resize [winfo parent %W] [winfo width %W]
188    }
189    ]
190}
191
192;proc configure {w args} {
193    upvar \#0 [namespace current]::$w data
194
195    set truth {^(1|yes|true|on)$}
196    set post {}
197    foreach {key val} $args {
198	switch -- $key {
199	    -activebackground {
200		if {[string compare $data(curtab) {}]} {
201		    $data(tabs) itemconfig POLY:$data(curtab) -fill $val
202		}
203		if {[string compare $val {}]} {
204		    $data(hide) config -bg $val
205		} else {
206		    lappend post \
207			    [list $data(hide) config -bg $data(-background)]
208		}
209	    }
210	    -background	{
211		$data(tabs) config -bg $val
212		$data(hold) config -bg $val
213		$data(blank) config -bg $val
214	    }
215	    -borderwidth {
216		$data(hold) config -bd $val
217		$data(hide) config -height $val
218	    }
219	    -disabledbackground {
220		foreach i $data(ids) {
221		    if {[string match disabled $data(:$i:-state)]} {
222			$data(tabs) itemconfig POLY:$i -fill $val
223		    }
224		}
225	    }
226	    -font	{
227		$data(tabs) itemconfigure TEXT -font $val
228		recalculate $w
229	    }
230	    -justify	{ $data(tabs) itemconfigure TEXT -justify $val }
231	    -linewidth	{ $data(tabs) itemconfigure LINE -width $val }
232	    -linecolor	{ $data(tabs) itemconfigure LINE -fill $val }
233	    -minwidth	{
234		if {$val < 0} { set val 0 }
235		grid columnconfig $w 0 -minsize $val
236	    }
237	    -minheight	{
238		if {$val < 0} { set val 0 }
239		grid rowconfigure $w 1 -minsize $val
240	    }
241	    -normalbackground {
242		foreach i $data(ids) {
243		    if {[string match normal $data(:$i:-state)]} {
244			$data(tabs) itemconfig POLY:$i -fill $val
245		    }
246		}
247	    }
248	    -padx - -pady {
249		if {$val < 1} { set val 1 }
250	    }
251	    -relief	{
252		$data(hold) config -relief $val
253	    }
254	}
255	set data($key) $val
256    }
257    if {[string compare $post {}]} {
258	eval [join $post \n]
259    }
260}
261
262;proc _add { w text args } {
263    upvar \#0 [namespace current]::$w data
264
265    set c $data(tabs)
266    if {[string match {} $text]} {
267	return -code error "non-empty text required for noteboook label"
268    } elseif {[string compare {} [$c find withtag ID:$text]]} {
269	return -code error "tab \"$text\" already exists"
270    }
271    array set s {
272	-window	{}
273	-state	normal
274    }
275    foreach {key val} $args {
276	switch -glob -- $key {
277	    -w*	{
278		if {[string compare $val {}]} {
279		    if {![winfo exist $val]} {
280			return -code error "window \"$val\" does not exist"
281		    } elseif {[string comp $w [winfo parent $val]] && \
282			    [string comp $data(hold) [winfo parent $val]]} {
283			return -code error "window \"$val\" must be a\
284				child of the tab notebook ($w)"
285		    }
286		}
287		set s(-window) $val
288	    }
289	    -s* {
290		if {![regexp {^(normal|disabled|active)$} $val]} {
291		    return -code error "unknown state \"$val\", must be:\
292			    normal, disabled or active"
293		}
294		set s(-state) $val
295	    }
296	    default {
297		return -code error "unknown option '$key', must be:\
298			[join [array names s] {, }]"
299	    }
300	}
301    }
302    set tab [incr data(numtabs)]
303    set px [expr {int(ceil($data(-padx)/2))}]
304    set py [expr {int(ceil($data(-pady)/2))}]
305    if {[lsearch -exact [image names] $text] != -1} {
306	set i [$c create image $px $py -image $text -anchor nw \
307		-tags [list IMG M:$tab ID:$text TAB:$tab]]
308    } else {
309	set i [$c create text [expr {$px+1}] $py -text $text -anchor nw \
310		-tags [list TEXT M:$tab ID:$text TAB:$tab] \
311		-justify $data(-justify)]
312    }
313    foreach {x1 y1 x2 y2} [$c bbox $i] {
314	set W  [expr {$x2-$x1+$px}]
315	set FW [expr {$W+$px}]
316	set FH [expr {$y2-$y1+3*$py}]
317    }
318    set diff [expr {$FH-$data(height)}]
319    if {$diff > 0} {
320	$c move all 0 $diff
321	$c move $i 0 -$diff
322	set data(height) $FH
323    }
324    $c create poly 0 $FH $px $py $W $py $FW $FH -fill {} \
325	    -tags [list POLY POLY:$tab TAB:$tab]
326    $c create line 0 $FH $px $py $W $py $FW $FH -joinstyle round \
327	    -tags [list LINE LINE:$tab TAB:$tab] \
328	    -width $data(-linewidth) -fill $data(-linecolor)
329    $c move TAB:$tab $data(width) [expr {($diff<0)?-$diff:0}]
330    $c raise $i
331    $c raise LINE:$tab
332    incr data(width) $FW
333    $c configure -width $data(width) -height $data(height) \
334	    -scrollregion "0 0 $data(width) $data(height)"
335    $c bind TAB:$tab <1> [namespace code [list _activate $w $tab]]
336    array set data [list :$tab:-window $s(-window) :$tab:-state $s(-state)]
337    if {[string compare $s(-window) {}]} {
338	grid $s(-window) -in $data(hold) -row 0 -column 0 -sticky nsew
339	lower $s(-window)
340    }
341    switch $s(-state) {
342	active	{_activate $w $tab}
343	disabled {$c itemconfig POLY:$tab -fill $data(-disabledbackground)}
344	normal	{$c itemconfig POLY:$tab -fill $data(-normalbackground)}
345    }
346    lappend data(ids) $tab
347    return $tab
348}
349
350;proc _activate { w id } {
351    upvar \#0 [namespace current]::$w data
352
353    if {[string compare $data(-browsecmd) {}] && \
354	    [catch {uplevel \#0 $data(-browsecmd) \
355	    [list [_name $w $oldtab] [_name $w $tab]]}]} {
356	return
357    }
358    if {[string compare $id {}]} {
359	set tab [verify $w $id]
360	if {[string match disabled $data(:$tab:-state)]} return
361    } else {
362	set tab {}
363    }
364    if {[string match $data(curtab) $tab]} return
365    set c $data(tabs)
366    set oldtab $data(curtab)
367    if {[string compare $oldtab {}]} {
368	$c itemconfig POLY:$oldtab -fill $data(-normalbackground)
369	$c move TAB:$oldtab 0 2
370	set data(:$oldtab:-state) normal
371    }
372    set data(curtab) $tab
373    if {[string compare $tab {}]} {
374	set data(:$tab:-state) active
375	$c itemconfig POLY:$tab -fill $data(-activebackground)
376	$c move TAB:$tab 0 -2
377    }
378    if {[info exists data(:$tab:-window)] && \
379	    [winfo exists $data(:$tab:-window)]} {
380	raise $data(:$tab:-window)
381    } else {
382	raise $data(blank)
383    }
384    resize $w [winfo width $w]
385}
386
387;proc _delete { w id } {
388    upvar \#0 [namespace current]::$w data
389
390    set tab [verify $w $id]
391    set c $data(tabs)
392    foreach {x1 y1 x2 y2} [$c bbox TAB:$tab] { set W [expr {$x2-$x1-3}] }
393    $c delete TAB:$tab
394    for { set i [expr {$tab+1}] } { $i <= $data(numtabs) } { incr i } {
395	$c move TAB:$i -$W 0
396    }
397    foreach {x1 y1 x2 y2} [$c bbox all] { set H [expr {$y2-$y1-3}] }
398    if {$H<$data(height)} {
399	$c move all 0 [expr {$H-$data(height)}]
400	set data(height) $H
401    }
402    incr data(width) -$W
403    $c config -width $data(width) -height $data(height) \
404	    -scrollregion "0 0 $data(width) $data(height)"
405    set i [lsearch $data(ids) $tab]
406    set data(ids) [lreplace $data(ids) $i $i]
407    catch {grid forget $data(:$tab:-window)}
408    unset data(:$tab:-state) data(:$tab:-window)
409    if {[string match $tab $data(curtab)]} {
410	set data(curtab) {}
411	raise $data(blank)
412    }
413}
414
415;proc _itemcget { w id key } {
416    upvar \#0 [namespace current]::$w data
417
418    set tab [verify $w $id]
419    set opt [array names data :$tab:$key*]
420    set len [llength $opt]
421    if {$len == 1} {
422	return $data($opt)
423    } elseif {$len == 0} {
424	set all [array names data :$tab:-*]
425	foreach o $all { lappend opts [lindex [split $o :] end] }
426	return -code error "unknown option \"$key\", must be one of:\
427		[join $opts {, }]"
428    } else {
429	foreach o $opt { lappend opts [lindex [split $o :] end] }
430	return -code error "ambiguous option \"$key\", must be one of:\
431		[join $opts {, }]"
432    }
433}
434
435;proc _itemconfigure { w id args } {
436    upvar \#0 [namespace current]::$w data
437
438    set tab [verify $w $id]
439    set len [llength $args]
440    if {$len == 1} {
441	return [uplevel 1 _itemcget $w $tab $args]
442    } elseif {$len&1} {
443	return -code error "uneven set of key/value pairs in \"$args\""
444    }
445    if {[string match {} $args]} {
446	set all [array names data :$tab:-*]
447	foreach o $all { lappend res [lindex [split $o :] end] $data($o) }
448	return $res
449    }
450    foreach {key val} $args {
451	switch -glob -- $key {
452	    -w*	{
453		if {[string comp $val {}]} {
454		    if {![winfo exist $val]} {
455			return -code error "window \"$val\" does not exist"
456		    } elseif {[string comp $w [winfo parent $val]] && \
457			    [string comp $data(hold) [winfo parent $val]]} {
458			return -code error "window \"$val\" must be a\
459				child of the tab notebook ($w)"
460		    }
461		}
462		set old $data(:$tab:-window)
463		if {[winfo exists $old]} { grid forget $old }
464		set data(:$tab:-window) $val
465		if {[string comp $val {}]} {
466		    grid $val -in $data(hold) -row 0 -column 0 \
467			    -sticky nsew
468		    lower $val
469		}
470		if {[string match active $data(:$tab:-state)]} {
471		    if {[string comp $val {}]} {
472			raise $val
473		    } else {
474			raise $data(blank)
475		    }
476		}
477	    }
478	    -s* {
479		if {![regexp {^(normal|disabled|active)$} $val]} {
480		    return -code error "unknown state \"$val\", must be:\
481			    normal, disabled or active"
482		}
483		if {[string match $val $data(:$tab:-state)]} return
484		set old $data(:$tab:-state)
485		switch $val {
486		    active		{
487			set data(:$tab:-state) $val
488			_activate $w $tab
489		    }
490		    disabled	{
491			if {[string match active $old]} { _activate $w {} }
492			$data(tabs) itemconfig POLY:$tab \
493				-fill $data(-disabledbackground)
494			set data(:$tab:-state) $val
495		    }
496		    normal		{
497			if {[string match active $old]} { _activate $w {} }
498			$data(tabs) itemconfig POLY:$tab -fill {}
499			set data(:$tab:-state) $val
500		    }
501		}
502	    }
503	    default {
504		return -code error "unknown option '$key', must be:\
505			[join [array names s] {, }]"
506	    }
507	}
508    }
509}
510
511## given a tab number, return the text
512;proc _name { w id } {
513    upvar \#0 [namespace current]::$w data
514
515    if {[string match {} $id]} return
516    set text {}
517    foreach item [$data(tabs) find withtag TAB:$id] {
518	set tags [$data(tabs) gettags $item]
519	if {[set i [lsearch -glob $tags {ID:*}]] != -1} {
520	    set text [string range [lindex $tags $i] 3 end]
521	    break
522	}
523    }
524    return $text
525}
526
527#;proc _order {w args} {
528#    upvar \#0 [namespace current]::$w data
529#
530#    foreach i $data(ids) {
531#    }
532#}
533
534## Take all the tabs and reculate space requirements
535;proc recalculate {w} {
536    upvar \#0 [namespace current]::$w data
537
538    set c $data(tabs)
539    set px [expr {int(ceil($data(-padx)/2))}]
540    set py [expr {int(ceil($data(-pady)/2))}]
541    set data(width) 0
542    set data(height) 0
543    foreach i $data(ids) {
544	$c coords M:$i [expr \
545		{[string match text [$c type M:$i]]?$px+1:$px}] $py
546	foreach {x1 y1 x2 y2} [$c bbox M:$i] {
547	    set W  [expr {$x2-$x1+$px}]
548	    set FW [expr {$W+$px}]
549	    set FH [expr {$y2-$y1+3*$py}]
550	}
551	set diff [expr {$FH-$data(height)}]
552	if {$diff > 0} {
553	    $c move all 0 $diff
554	    $c move M:$i 0 -$diff
555	    set data(height) $FH
556	}
557	$c coords POLY:$i 0 $FH $px $py $W $py $FW $FH
558	$c coords LINE:$i 0 $FH $px $py $W $py $FW $FH
559	$c move TAB:$i $data(width) [expr {($diff<0)?-$diff:0}]
560	incr data(width) $FW
561    }
562    $c configure -width $data(width) -height $data(height) \
563	    -scrollregion "0 0 $data(width) $data(height)"
564}
565
566;proc resize {w x} {
567    upvar \#0 [namespace current]::$w data
568
569    if {[string compare $data(curtab) {}]} {
570	set x [expr {round(-[$data(tabs) canvasx 0])}]
571	foreach {x1 y1 x2 y2} [$data(tabs) bbox TAB:$data(curtab)] {
572	    place $data(hide) -y [winfo y $data(hold)] -x [expr {$x1+$x+3}]
573	    $data(hide) config -width [expr {$x2-$x1-5}]
574	}
575    } else {
576	place forget $data(hide)
577    }
578}
579
580;proc see {w id} {
581    upvar \#0 [namespace current]::$w data
582
583    set c $data(tabs)
584    set box [$c bbox $id]
585    if {[string match {} $box]} return
586    foreach {x y x1 y1} $box {left right} [$c xview] \
587	    {p q xmax ymax} [$c cget -scrollregion] {
588	set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}]
589    }
590    $c xview moveto $xpos
591}
592
593;proc verify { w id } {
594    upvar \#0 [namespace current]::$w data
595
596    set c $data(tabs)
597    if {[string compare [set i [$c find withtag ID:$id]] {}]} {
598	if {[regexp {TAB:([0-9]+)} [$c gettags [lindex $i 0]] junk id]} {
599	    return $id
600	}
601    } elseif {[string compare [$c find withtag TAB:$id] {}]} {
602	return $id
603    }
604    return -code error "unrecognized tab \"$id\""
605}
606
607}; #end of namespace ::Widget::Tabnotebook