Context Navigation

source: trunk/gui/scripts/pager.tcl @ 154

Last change on this file since 154 was 115, checked in by mmc, 18 years ago
Updated all copyright notices.
File size: 22.8 KB

Line
1	# ----------------------------------------------------------------------
2	# COMPONENT: pager - notebook for displaying pages of widgets
3	#
4	# This widget is something like a tabbed notebook, but with a little
5	# more flexibility. Pages can be inserted and deleted, and then shown
6	# in various arrangements.
7	# ======================================================================
8	# AUTHOR: Michael McLennan, Purdue University
9	# Copyright (c) 2004-2005 Purdue Research Foundation
10	#
11	# See the file "license.terms" for information on usage and
12	# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13	# ======================================================================
14	package require Itk
15	package require BLT
16
17	option add *Pager.arrangement "pages" widgetDefault
18	option add *Pager.width 0 widgetDefault
19	option add *Pager.height 0 widgetDefault
20	option add *Pager.padding 8 widgetDefault
21	option add *Pager.crumbColor black widgetDefault
22	option add *Pager.crumbNumberColor white widgetDefault
23	option add *Pager.dimCrumbColor gray70 widgetDefault
24	option add *Pager.activeCrumbColor blue widgetDefault
25	option add *Pager.crumbFont \
26	--helvetica-bold-r-normal---120- widgetDefault
27
28	blt::bitmap define Pager-arrow {
29	#define arrow_width 9
30	#define arrow_height 9
31	static unsigned char arrow_bits[] = {
32	0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xff, 0x00, 0xff, 0x01, 0xff, 0x00,
33	0x70, 0x00, 0x30, 0x00, 0x10, 0x00};
34	}
35
36	itcl::class Rappture::Pager {
37	inherit itk::Widget
38
39	itk_option define -width width Width 0
40	itk_option define -height height Height 0
41	itk_option define -padding padding Padding 0
42	itk_option define -crumbcolor crumbColor Foreground ""
43	itk_option define -crumbnumbercolor crumbNumberColor Foreground ""
44	itk_option define -crumbfont crumbFont Font ""
45	itk_option define -dimcrumbcolor dimCrumbColor DimForeground ""
46	itk_option define -activecrumbcolor activeCrumbColor ActiveForeground ""
47	itk_option define -arrangement arrangement Arrangement ""
48
49	constructor {args} { # defined below }
50
51	public method insert {pos args}
52	public method delete {first {last ""}}
53	public method index {name}
54	public method page {args}
55	public method current {args}
56
57	protected method _layout {}
58	protected method _fixSize {}
59	protected method _drawCrumbs {how}
60
61	private variable _counter 0 ;# counter for page names
62	private variable _dispatcher "" ;# dispatcher for !events
63	private variable _pages "" ;# list of known pages
64	private variable _page2info ;# maps page name => -frame,-title,-command
65	private variable _current "" ;# page currently shown
66	}
67
68	itk::usual Pager {
69	}
70
71	# ----------------------------------------------------------------------
72	# CONSTRUCTOR
73	# ----------------------------------------------------------------------
74	itcl::body Rappture::Pager::constructor {args} {
75	Rappture::dispatcher _dispatcher
76	$_dispatcher register !layout
77	$_dispatcher dispatch $this !layout "[itcl::code $this _layout]; list"
78	$_dispatcher register !fixsize
79	$_dispatcher dispatch $this !fixsize "[itcl::code $this _fixSize]; list"
80
81	itk_component add controls {
82	frame $itk_interior.cntls
83	}
84
85	itk_component add next {
86	button $itk_component(controls).next -text "Next >" \
87	-command [itcl::code $this current next>]
88	}
89	pack $itk_component(next) -side right
90
91	itk_component add back {
92	button $itk_component(controls).back -text "< Back" \
93	-command [itcl::code $this current <back]
94	}
95	pack $itk_component(back) -side left
96
97	set font [$itk_component(next) cget -font]
98	set ht [font metrics $font -linespace]
99	itk_component add breadcrumbs {
100	canvas $itk_interior.breadcrumbs -width 10 -height [expr {$ht+2}]
101	}
102
103	itk_component add line {
104	frame $itk_interior.line -height 2 -borderwidth 1 -relief sunken
105	}
106
107
108	itk_component add inside {
109	frame $itk_interior.inside
110	}
111	pack $itk_component(inside) -expand yes -fill both
112	pack propagate $itk_component(inside) no
113
114	eval itk_initialize $args
115	$_dispatcher event -idle !layout
116	}
117
118	# ----------------------------------------------------------------------
119	# USAGE: insert <pos> ?-name <name>? ?-title <label>? ?-command <str>?
120	#
121	# Clients use this to insert a new page into this pager. The page is
122	# inserted into the list at position <pos>, which can be an integer
123	# starting from 0 or the keyword "end". The optional <name> can be
124	# used to identify the page. If it is not supplied, a name is created
125	# for the page. The -title and -command are other values associated
126	# with the page.
127	#
128	# Returns the name used to identify the page.
129	# ----------------------------------------------------------------------
130	itcl::body Rappture::Pager::insert {pos args} {
131	if {"end" == $pos} {
132	set pos [llength $_pages]
133	} elseif {![string is integer $pos]} {
134	error "bad index \"$pos\": should be integer or \"end\""
135	}
136
137	Rappture::getopts args params {
138	value -name page#auto
139	value -title "Page #auto"
140	value -command ""
141	}
142	if {[llength $args] > 0} {
143	error "wrong # args: should be \"insert pos ?-name n? ?-title t? ?-command c?\""
144	}
145
146	incr _counter
147	if {$_counter > 1} {
148	set subst "#$_counter"
149	} else {
150	set subst ""
151	}
152	if {[regexp {#auto} $params(-name)]} {
153	regsub -all {#auto} $params(-name) $subst params(-name)
154	}
155	if {[regexp {#auto} $params(-title)]} {
156	regsub -all {#auto} $params(-title) $subst params(-title)
157	}
158
159	# allocate the page
160	if {[info exists _page2info($params(-name)-frame)]} {
161	error "page \"$params(-name)\" already exists"
162	}
163	set win $itk_component(inside).page$_counter
164	frame $win
165	set _page2info($params(-name)-frame) $win
166	set _page2info($params(-name)-title) $params(-title)
167	set _page2info($params(-name)-command) $params(-command)
168	set _pages [linsert $_pages $pos $params(-name)]
169
170	bind $win <Configure> \
171	[itcl::code $_dispatcher event -idle !fixsize]
172
173	# the number of pages affects the arrangment -- force an update
174	configure -arrangement $itk_option(-arrangement)
175
176	$_dispatcher event -idle !layout
177
178	return $params(-name)
179	}
180
181	# ----------------------------------------------------------------------
182	# USAGE: delete <first> ?<last>?
183	#
184	# Clients use this to delete one or more pages from this widget.
185	# The <first> and <last> represent the integer index of the desired
186	# page. You can use the "index" method to convert a page name to
187	# its integer index. If only <first> is specified, then that one
188	# page is deleted. If <last> is specified, then all pages in the
189	# range <first> to <last> are deleted.
190	# ----------------------------------------------------------------------
191	itcl::body Rappture::Pager::delete {first {last ""}} {
192	if {$last == ""} {
193	set last $first
194	}
195	if {![regexp {^[0-9]+\|end$} $first]} {
196	error "bad index \"$first\": should be integer or \"end\""
197	}
198	if {![regexp {^[0-9]+\|end$} $last]} {
199	error "bad index \"$last\": should be integer or \"end\""
200	}
201
202	foreach name [lrange $_pages $first $last] {
203	if {[info exists _page2info($name-frame)]} {
204	destroy $_page2info($name-frame)
205	unset _page2info($name-frame)
206	unset _page2info($name-title)
207	unset _page2info($name-command)
208	}
209	}
210	set _pages [lreplace $_pages $first $last]
211
212	# the number of pages affects the arrangment -- force an update
213	configure -arrangement $itk_option(-arrangement)
214
215	$_dispatcher event -idle !layout
216	}
217
218	# ----------------------------------------------------------------------
219	# USAGE: index <name>\|@n
220	#
221	# Clients use this to convert a page <name> into its corresponding
222	# integer index. Returns an error if the <name> is not recognized.
223	# ----------------------------------------------------------------------
224	itcl::body Rappture::Pager::index {name} {
225	set i [lsearch $_pages $name]
226	if {$i >= 0} {
227	return $i
228	}
229	if {[regexp {^@([0-9]+)$} $name match i]} {
230	return $i
231	}
232	error "bad page name \"$name\": should be @int or one of [join [lsort $_pages] {, }]"
233	}
234
235	# ----------------------------------------------------------------------
236	# USAGE: page
237	# USAGE: page <name>\|@n ?-frame\|-title\|-command? ?<newvalue>?
238	#
239	# Clients use this to get information about pages. With no args, it
240	# returns a list of all page names. Otherwise, it returns the
241	# requested information for a page specified by its <name> or index
242	# @n. By default, it returns the -frame for the page, but it can
243	# also return the -title and -command. The -title and -command
244	# can also be set to a <newvalue>.
245	# ----------------------------------------------------------------------
246	itcl::body Rappture::Pager::page {args} {
247	if {[llength $args] == 0} {
248	return $_pages
249	}
250	set i [index [lindex $args 0]]
251	set name [lindex $_pages $i]
252
253	set args [lrange $args 1 end]
254	Rappture::getopts args params {
255	flag what -frame default
256	flag what -title
257	flag what -command
258	}
259
260	if {[llength $args] == 0} {
261	set opt $params(what)
262	return $_page2info($name$opt)
263	} elseif {[llength $args] == 1} {
264	set val [lindex $args 0]
265	if {$params(-title)} {
266	set _page2info($name-title) $val
267	} elseif {$params(-command)} {
268	set _page2info($name-command) $val
269	}
270	} else {
271	error "wrong # args: should be \"page ?which? ?-frame\|-title\|-command? ?newvalue?\""
272	}
273	}
274
275	# ----------------------------------------------------------------------
276	# USAGE: current ?<name>\|next>\|<back?
277	#
278	# Used to query/set the current page in the notebook. With no args,
279	# it returns the name of the current page. Otherwise, it sets the
280	# current page. The special token "next>" is used to set the pager
281	# to the next logical page, and "<back" sets to the previous.
282	# ----------------------------------------------------------------------
283	itcl::body Rappture::Pager::current {args} {
284	switch -- [llength $args] {
285	0 {
286	return $_current
287	}
288	1 {
289	if {$itk_option(-arrangement) != "pages"} {
290	return ""
291	}
292	set name [lindex $args 0]
293	set index 0
294	if {$name == "next>"} {
295	if {$_current == ""} {
296	set index 0
297	} else {
298	set i [lsearch -exact $_pages $_current]
299	set index [expr {$i+1}]
300	if {$index >= [llength $_pages]} {
301	set index [expr {[llength $_pages]-1}]
302	}
303	}
304	set _current [lindex $_pages $index]
305	} elseif {$name == "<back"} {
306	if {$_current == ""} {
307	set index end
308	} else {
309	set i [lsearch -exact $_pages $_current]
310	set index [expr {$i-1}]
311	if {$index < 0} {
312	set index 0
313	}
314	}
315	set _current [lindex $_pages $index]
316	} else {
317	if {$name == ""} {
318	set _current ""
319	set index 0
320	} else {
321	set index [lsearch -exact $_pages $name]
322	if {$index < 0} {
323	error "can't move to page \"$name\""
324	}
325	set _current [lindex $_pages $index]
326	}
327	}
328
329	foreach w [pack slaves $itk_component(inside)] {
330	pack forget $w
331	}
332	if {$_current != ""} {
333	pack $_page2info($_current-frame) -expand yes -fill both \
334	-padx $itk_option(-padding) -pady $itk_option(-padding)
335	}
336
337	if {$index == 0} {
338	pack forget $itk_component(back)
339	} else {
340	set prev [expr {$index-1}]
341	if {$prev >= 0} {
342	set label "< [page @$prev -title]"
343	} else {
344	set label "< Back"
345	}
346	$itk_component(back) configure -text $label
347	pack $itk_component(back) -side left
348	}
349	if {$index == [expr {[llength $_pages]-1}]} {
350	pack forget $itk_component(next)
351	} else {
352	set next [expr {$index+1}]
353	if {$next <= [llength $_pages]} {
354	set label "[page @$next -title] >"
355	} else {
356	set label "Next >"
357	}
358	$itk_component(next) configure -text $label
359	pack $itk_component(next) -side right
360	}
361	_drawCrumbs current
362
363	#
364	# If this new page has a command associated with it, then
365	# invoke it now.
366	#
367	if {"" != $_current
368	&& [string length $_page2info($_current-command)] > 0} {
369	uplevel #0 $_page2info($_current-command)
370	}
371	}
372	default {
373	error "wrong # args: should be \"current name\|next>\|<back\""
374	}
375	}
376	}
377
378	# ----------------------------------------------------------------------
379	# USAGE: _layout
380	#
381	# Used internally to fix the current page management whenever pages
382	# are added or deleted, or when the page arrangement changes.
383	# ----------------------------------------------------------------------
384	itcl::body Rappture::Pager::_layout {} {
385	if {$itk_option(-arrangement) == "pages"} {
386	if {$_current == ""} {
387	set _current [lindex $_pages 0]
388	if {$_current != ""} {
389	current $_current
390	}
391	}
392	_drawCrumbs all
393	}
394	}
395
396	# ----------------------------------------------------------------------
397	# USAGE: _fixSize
398	#
399	# Invoked automatically whenever a page changes size or the -width
400	# or -height options change. When the -width/-height are zero, this
401	# method computes the minimum size needed to accommodate all pages.
402	# Otherwise, it passes the size request onto the hull.
403	# ----------------------------------------------------------------------
404	itcl::body Rappture::Pager::_fixSize {} {
405	set sw [expr {[winfo screenwidth $itk_component(hull)]-200}]
406	set sh [expr {[winfo screenheight $itk_component(hull)]-200}]
407
408	update ;# force layout changes so sizes are correct
409	switch -- $itk_option(-arrangement) {
410	pages {
411	if {$itk_option(-width) <= 0} {
412	set maxw [expr {
413	[winfo reqwidth $itk_component(next)]
414	+ 10
415	+ [winfo reqwidth $itk_component(back)]}]
416
417	foreach name $_pages {
418	set w [winfo reqwidth $_page2info($name-frame)]
419	if {$w > $maxw} { set maxw $w }
420	}
421	set maxw [expr {$maxw + 2*$itk_option(-padding)}]
422	if {$maxw > $sw} { set maxw $sw }
423	$itk_component(inside) configure -width $maxw
424	} else {
425	$itk_component(inside) configure -width $itk_option(-width)
426	}
427
428	if {$itk_option(-height) <= 0} {
429	set maxh 0
430	foreach name $_pages {
431	set h [winfo reqheight $_page2info($name-frame)]
432	if {$h > $maxh} { set maxh $h }
433	}
434	set maxh [expr {$maxh + 2*$itk_option(-padding)}]
435	if {$maxh > $sh} { set maxh $sh }
436	$itk_component(inside) configure -height $maxh
437	} else {
438	$itk_component(inside) configure -height $itk_option(-height)
439	}
440	}
441	side-by-side {
442	if {$itk_option(-width) <= 0} {
443	set maxw [expr {
444	[winfo reqwidth $itk_component(next)]
445	+ 10
446	+ [winfo reqwidth $itk_component(back)]}]
447
448	set wtotal 0
449	foreach name $_pages {
450	set w [winfo reqwidth $_page2info($name-frame)]
451	set wtotal [expr {$wtotal + $w + 2*$itk_option(-padding)}]
452	}
453	if {$wtotal > $maxw} { set maxw $wtotal }
454	if {$maxw > $sw} { set maxw $sw }
455	$itk_component(inside) configure -width $maxw
456	} else {
457	$itk_component(inside) configure -width $itk_option(-width)
458	}
459
460	if {$itk_option(-height) <= 0} {
461	set maxh 0
462	foreach name $_pages {
463	set h [winfo reqheight $_page2info($name-frame)]
464	if {$h > $maxh} { set maxh $h }
465	}
466	set maxh [expr {$maxh + 2*$itk_option(-padding)}]
467	if {$maxh > $sh} { set maxh $sh }
468	$itk_component(inside) configure -height $maxh
469	} else {
470	$itk_component(inside) configure -height $itk_option(-height)
471	}
472	}
473	}
474	}
475
476	# ----------------------------------------------------------------------
477	# OPTION: -arrangement
478	# ----------------------------------------------------------------------
479	itcl::configbody Rappture::Pager::arrangement {
480	switch -- $itk_option(-arrangement) {
481	pages {
482	pack forget $itk_component(inside)
483	pack $itk_component(controls) -side bottom -fill x -padx 8 -pady 8
484	if {[llength $_pages] > 2} {
485	pack $itk_component(breadcrumbs) -side top -fill x \
486	-padx 8 -pady 8
487	pack $itk_component(line) -side top -fill x
488	}
489	pack $itk_component(inside) -expand yes -fill both
490	current [lindex $_pages 0]
491	}
492	side-by-side {
493	pack forget $itk_component(controls)
494	pack forget $itk_component(line)
495	pack forget $itk_component(breadcrumbs)
496
497	foreach w [pack slaves $itk_component(inside)] {
498	pack forget $w
499	}
500	foreach name $_pages {
501	pack $_page2info($name-frame) -side left \
502	-expand yes -fill both \
503	-padx $itk_option(-padding) -pady $itk_option(-padding)
504	}
505	}
506	default {
507	error "bad value \"$itk_option(-arrangement)\": should be pages or side-by-side"
508	}
509	}
510	$_dispatcher event -now !fixsize
511	}
512
513	# ----------------------------------------------------------------------
514	# OPTION: -width
515	# ----------------------------------------------------------------------
516	itcl::configbody Rappture::Pager::width {
517	$_dispatcher event -idle !fixsize
518	}
519
520	# ----------------------------------------------------------------------
521	# OPTION: -height
522	# ----------------------------------------------------------------------
523	itcl::configbody Rappture::Pager::height {
524	$_dispatcher event -idle !fixsize
525	}
526
527	# ----------------------------------------------------------------------
528	# OPTION: -padding
529	# ----------------------------------------------------------------------
530	itcl::configbody Rappture::Pager::padding {
531	if {$_current != ""} {
532	pack $_page2info($_current-frame) -expand yes -fill both \
533	-padx $itk_option(-padding) -pady $itk_option(-padding)
534	}
535	$_dispatcher event -idle !fixsize
536	}
537
538	# ----------------------------------------------------------------------
539	# USAGE: _drawCrumbs all\|current
540	#
541	# Invoked automatically whenever the pages change. The value "all"
542	# signifies that the number of pages has changed, so all should be
543	# redrawn. The value "current" means that the current page has
544	# changed, so there is just a simple color change.
545	# ----------------------------------------------------------------------
546	itcl::body Rappture::Pager::_drawCrumbs {how} {
547	set c $itk_component(breadcrumbs)
548	set fnt $itk_option(-crumbfont)
549
550	switch -- $how {
551	all {
552	$c delete all
553
554	set x 0
555	set y [expr {[winfo reqheight $c]/2}]
556	set last [lindex $_pages end]
557
558	set num 1
559	foreach name $_pages {
560	set ht [expr {[font metrics $fnt -linespace]+2}]
561	set id [$c create oval $x [expr {$y-$ht/2}] \
562	[expr {$x+$ht}] [expr {$y+$ht/2}] \
563	-outline "" -fill $itk_option(-dimcrumbcolor) \
564	-tags $name]
565	set id [$c create text [expr {$x+$ht/2}] [expr {$y+1}] \
566	-text $num -fill $itk_option(-crumbnumbercolor) \
567	-tags [list $name $name-num]]
568	set x [expr {$x + $ht+2}]
569
570	set id [$c create text $x [expr {$y+1}] -anchor w \
571	-text [page $name -title] -font $fnt -tags $name]
572
573	$c bind $name <Enter> [itcl::code $this _drawCrumbs active]
574	$c bind $name <Leave> [itcl::code $this _drawCrumbs current]
575	$c bind $name <ButtonPress> [itcl::code $this current $name]
576
577	foreach {x0 y0 x1 y1} [$c bbox $id] break
578	set x [expr {$x + ($x1-$x0)+6}]
579
580	if {$name != $last} {
581	set id [$c create bitmap $x $y -anchor w \
582	-bitmap Pager-arrow \
583	-foreground $itk_option(-dimcrumbcolor)]
584	foreach {x0 y0 x1 y1} [$c bbox $id] break
585	set x [expr {$x + ($x1-$x0)+6}]
586	}
587
588	incr num
589	}
590
591	# fix the scrollregion in case we go off screen
592	$c configure -scrollregion [$c bbox all]
593
594	_drawCrumbs current
595	}
596	current {
597	# make all crumbs dim
598	foreach name $_pages {
599	$c itemconfigure $name \
600	-fill $itk_option(-dimcrumbcolor)
601	$c itemconfigure $name-num \
602	-fill $itk_option(-crumbnumbercolor)
603	}
604
605	# make all the current crumb bright
606	if {$_current != ""} {
607	$c itemconfigure $_current \
608	-fill $itk_option(-crumbcolor)
609	$c itemconfigure $_current-num \
610	-fill $itk_option(-crumbnumbercolor)
611
612	# scroll the view to see the crumb
613	if {[$c bbox $_current] != ""} {
614	foreach {x0 y0 x1 y1} [$c bbox $_current] break
615	foreach {xm0 ym0 xm1 ym1} [$c bbox all] break
616	set xm [expr {double($x0)/($xm1-$xm0)}]
617	$c xview moveto $xm
618	}
619	} else {
620	$c xview moveto 0
621	}
622	}
623	active {
624	foreach tag [$c gettags current] {
625	if {[lsearch -exact $_pages $tag] >= 0} {
626	$c itemconfigure $tag -fill $itk_option(-activecrumbcolor)
627	$c itemconfigure $tag-num -fill white
628	}
629	}
630	}
631	}
632	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: