Context Navigation

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

Last change on this file since 676 was 676, checked in by mmc, 18 years ago

Fixed all fonts to set pixelsize instead of pointsize, so that fonts in
the latest X distribution look right.

Added initial Rappture::bugreport::submit command for submitting bug
reports to nanoHUB.org. This isn't tied in yet, but it's a start.

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--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	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: