From: vanandel@rsf.atd.ucar.edu (Joe VanAndel)
Newsgroups: comp.lang.tcl
Subject: Interviews "deck" support in Tk/TCL - show 1 of N widgets
Keywords: deck
Date: 13 Apr 92 19:24:18 GMT
Organization: NCAR/UCAR

I've built a few procedures that allow a Tk/TCL programmer to display 1 of N different widgets in the same position in a window.  After the user has displayed each of the widgets once, no more resizing occurs, so the change between "cards" happens quite quickly.  Here is the code, note the demo at the bottom of the file.

# this procedure is designed to create a "deck" of widgets, only 1 of
# which is visible at time (ala Interviews)
# the deck is created within a fixed size frame, to avoid resizing when
# switching between different "cards"
#
# the first child created is visible by default.
#
#
# once the "deck" is created, we can select which "card" to show by calling
# deck_flip_to deck_name window_suffix
#
# we use the TCL convention that "args" is a list of lists, which allows
# a variable number of arguments
#
# __CurrentCard is a global array that keeps track of the currently visible
# "card" for each deck.
# 
# we create vertical and horizontal "props" to set minimum dimensions
# for the deck
#
proc create_deck {my_name args} {
    global __CurrentCard
    frame $my_name
    frame $my_name.width -geometry 5x1
    frame $my_name.height -geometry 1x5
    set nc [llength $args] 
#	puts stdout "args = $args ($nc)"
    if {[llength $args] > 0} {
	set first_child [lindex $args 0]

# we grab the 1st child widget's name, prepend our name, and create it
	set child_suffix [lindex $first_child 1]
	set child_name ${my_name}.${child_suffix}
	set child_cmd [lindex $first_child 0]
#	puts stdout "\$child_cmd = $child_cmd \$child_name = $child_name"
	set c  [eval $child_cmd $child_name [lrange $first_child 2 end]]

# now, we pack the child, so it is visible
 	pack append $my_name $my_name.width top $my_name.height right \
		    $c {expand frame center}
	set __CurrentCard($my_name) $child_name
#	deck_flip_to $my_name $child_suffix
    }
# simply create each subsequent child, but don't pack them
    foreach arg [lrange $args 1 end] {
	set child_suffix [lindex $arg 1]
	set child_name ${my_name}.${child_suffix}
	set c  [eval [lindex $arg 0] $child_name [lrange $arg 2 end]]
		
    }
    return $my_name
}
# make a given card of the deck visible by packing it.
#
# we set the size of the deck to the maximum size of any of the cards,
# so that we eliminate re-sizing when flipping between cards.
# At worst, we don't get the size correct until we've flipped thru all the
# cards
#
# TODO - protect against bad child_suffix being passed in

proc deck_flip_to {deck child_suffix} {
    global __CurrentCard
#    puts stderr "flip to $child_suffix"
# unpack the previously shown "card", so it is not visible
    pack unpack $__CurrentCard(${deck})
    set child_name ${deck}.${child_suffix}
    set __CurrentCard($deck) $child_name
    pack append $deck $child_name {expand frame center}
    update
# now, adjust dimensions of 'props' to maximum dimension of any 'card'
# subtract 1 to avoid height gradually growing by 1 pixel
# (caused by a bug in tk, I presume)
#
    set width [winfo width $deck]
#    set height [winfo height $deck]
    set height [expr [winfo height $deck]-1]
    set list [$deck.width configure -geometry]
# extract 5x1 from the string "-geometry geometry Geometry {} 5x1"
    set last [expr {[llength $list] -1} ]
# extract just the width number
     regsub {([0-9]*)x1}  [lrange $list $last $last] {\1} oldwidth
    if {$width > $oldwidth}  then {
	$deck.width configure -geometry ${width}x1 
#	puts stderr "oldwidth = $oldwidth, width = $width"
    }
    set list [$deck.height configure -geometry]
    set last [expr {[llength $list] -1} ]
     regsub {1x([0-9]*)}  [lrange $list $last $last] {\1} oldheight
    if {$height > $oldheight}  {
	$deck.height configure -geometry 1x${height} 
#	puts stderr "oldheight = $oldheight, height = $height"
    }
}

# this procedure creates a frame with a fixed size,
# and packs the specified window inside it with the specified arguments
#
# note - child_args must be specified as a list, specifying only the 
# last component of the name of # the widget, 
# which is always build as $my_name.child_name
#
# e.g.:
#  pack append .  [fixed_frame .x 400 200 { button but -text "SHORT"}] \
# {expand fill}

proc fixed_frame {my_name width height child_args } {
    frame $my_name
    frame $my_name.width -geometry ${width}x1
    frame $my_name.height -geometry 1x$height
# we want to create the child as $my_name.$child_end
#
    append child_name $my_name "."  [lindex $child_args 1] 
    set child [lindex $child_args 0]
#
# we use 'eval' to force a re-parse of $child_args as a sep. set of
# arguments, rather than a list
    set c [eval $child $child_name [lrange $child_args 2 end]]
    pack append $my_name $my_name.width top $my_name.height right \
	$c {expand frame center}
    return $my_name
}



proc deck_demo {w} {
    frame $w -borderwidth 1 -relief sunken
    pack append $w \
	[label $w.t1 -text "deck demo " ] {top} \
        [create_deck $w.deck \
	    "mk_card l1 $w.deck l2 {push for card 2} {CARD -> 1  <-  }" \
	    "mk_card l2 $w.deck l3 {push for card 3} {CARD ->2<-}" \
	    "mk_card l3 $w.deck l1 {push for card 1} {CARD ->3<-}" ] {top}
    return $w
}
proc mk_card {w deck card button_label card_label} {
    frame $w -borderwidth 1 -relief sunken
    pack append $w \
	[button $w.b -text $button_label -command "deck_flip_to $deck $card" ] {left expand fill} \
	[label $w.l -text $card_label ] {left expand fill} 
    return $w
}

# to demonstrate the deck 
#  execute the following line
# pack append . [deck_demo .f1] top

---------------------------------------

	Joe VanAndel  		Internet:vanandel@ncar.ucar.edu
	NCAR - ATD/RSF  			
	P.O Box 3000		Fax:	 303-497-2044
	Boulder, CO 80307-3000	Voice:	 303-497-2071 
Newsgroups: comp.lang.tcl