Context Navigation

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

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

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

Download in other formats: