These are the support routines for Canvas Buttons in 3-D.
These routines can also be used to make other things. The corners and sides are all separate, so one could build anything rectangular and 3-D on a canvas. A combobox would be interesting.
Here's a link to the Canvas Buttons in 3-D, that use these routines.
proc CreateTopLeftCorner {theCanvas x y height args} {
global tlcorner
set id [$theCanvas create rectangle 0 0 1 1]
set tlcorner($id,theCanvas) $theCanvas
set tlcorner($id,adjustedHeight) [expr round(0.707 * $height)]
# I'd rather deal with integers.
set tlcorner($id,x) $x
set tlcorner($id,y) $y
set tlcorner($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {
set tlcorner($id,color) $value
# No checking at present that color value is valid.
}
-tag -
-tags {
set tags $value
}
-state {
switch -- $value {
normal {
set state normal
}
hidden {
set state hidden
}
default {
tk_messageBox -message "CreateTopLeftCorner: \
Unrecognized state value: $value" -type ok
}
}
}
default {
tk_messageBox -message "CreateTopLeftCorner: Unrecognized\
option: $option" -type ok
}
}
}
set ah $tlcorner($id,adjustedHeight)
set ax [expr $x + $ah] ;# Altered x.
set ay [expr $y + $ah] ;# Altered y.
$theCanvas coords $id $x $y $ax $ay
set c $tlcorner($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
# Both the fill and the outline need to be set, for rectangle
# to match polygon.
return $id
# Hopefully, the caller won't keep the id long, but will assign
# a tag to the assemblage.
}
# Since I don't want to make a separate routine to set the state for each
# piece, and I don't want the rectangle to have to directly twiddle variables
# belonging to a piece, I don't make the state of the canvas item, hidden or
# normal, part of the state of the piece.
proc CreateLeftSide {theCanvas x ty by height args} {
global lside
set id [$theCanvas create rectangle 0 0 1 1]
set lside($id,theCanvas) $theCanvas
set lside($id,adjustedHeight) [expr round(0.707 * $height)]
set lside($id,x) $x
set lside($id,ty) $ty
set lside($id,by) $by
set lside($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {set lside($id,color) $value}
-tag - -tags {set tags $value}
-state {
switch -- $value {
normal {set state normal}
hidden {set state hidden}
default {tk_messageBox -message "CreateLeftSide: \
Unrecognized state value: $value" -type ok}
}
}
default {tk_messageBox -message "CreateLeftSide: \
Unrecognized option: $option" -type ok}
}
}
set ah $lside($id,adjustedHeight)
set ax [expr $x + $ah]
set aty [expr $ty + $ah]
set aby [expr $by - $ah]
$theCanvas coords $id $x $aty $ax $aby
set c $lside($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
return $id
}
proc CreateBottomLeftCorner {theCanvas x y height args} {
global blcorner
set id [$theCanvas create polygon 0 0 1 0 1 1]
set blcorner($id,theCanvas) $theCanvas
set blcorner($id,adjustedHeight) [expr round(0.707 * $height)]
set blcorner($id,x) $x
set blcorner($id,y) $y
set blcorner($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {set blcorner($id,color) $value}
-tag - -tags {set tags $value}
-state {
switch -- $value {
normal {set state normal}
hidden {set state hidden}
default {tk_messageBox -message "CreateBottomLeftCorner: \
Unrecognized state value: $value" -type ok}
}
}
default {tk_messageBox -message "CreateBottomLeftCorner: \
Unrecognized option: $option" -type ok}
}
}
set ah $blcorner($id,adjustedHeight)
set ax [expr $x + $ah]
set by [expr $y + $ah]
set ty [expr $y - $ah]
$theCanvas coords $id $x $y $ax $by $ax $ty $x $ty
set c $blcorner($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
return $id
}
# We let the corner manage the territory a little way up the side,
# so if we ever decide to allow the customer to change the perspective
# so that he is to the left and below the button, instead of to the left
# and above, we can.
#
# This seems as good a place as any to mention that if the height of the
# button or whatever gets to be an appreciable fraction of the width and
# breadth of the button, these routines will fail.
proc CreateTopSide {theCanvas lx rx y height args} {
global tside
set id [$theCanvas create rectangle 0 0 1 1]
set tside($id,theCanvas) $theCanvas
set tside($id,adjustedHeight) [expr round(0.707 * $height)]
set tside($id,lx) $lx
set tside($id,rx) $rx
set tside($id,y) $y
set tside($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {set tside($id,color) $value}
-tag - -tags {set tags $value}
-state {
switch -- $value {
normal {set state normal}
hidden {set state hidden}
default {tk_messageBox -message "CreateTopSide: \
Unrecognized state value: $value" -type ok}
}
}
default {tk_messageBox -message "CreateTopSide: \
Unrecognized option: $option" -type ok}
}
}
set ah $tside($id,adjustedHeight)
set alx [expr $lx + $ah]
set arx [expr $rx - $ah]
set ay [expr $y + $ah]
$theCanvas coords $id $alx $y $arx $ay
set c $tside($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
return $id
}
proc CreateTopRightCorner {theCanvas x y height args} {
global trcorner
set id [$theCanvas create polygon 0 0 1 0 1 1]
set trcorner($id,theCanvas) $theCanvas
set trcorner($id,adjustedHeight) [expr round(0.707 * $height)]
set trcorner($id,x) $x
set trcorner($id,y) $y
set trcorner($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {set trcorner($id,color) $value}
-tag - -tags {set tags $value}
-state {
switch -- $value {
normal {set state normal}
hidden {set state hidden}
default {tk_messageBox -message "CreateTopRightCorner: \
Unrecognized state value: $value" -type ok}
}
}
default {tk_messageBox -message "CreateTopRightCorner: \
Unrecognized option: $option" -type ok}
}
}
set ah $trcorner($id,adjustedHeight)
set arx [expr $x + $ah]
set alx [expr $x - $ah]
set ay [expr $y + $ah]
$theCanvas coords $id $x $y $alx $y $alx $ay $arx $ay
set c $trcorner($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
return $id
}
proc CreateBottomSide {theCanvas lx rx y height args} {
global bside
set id [$theCanvas create rectangle 0 0 1 1]
set bside($id,theCanvas) $theCanvas
set bside($id,adjustedHeight) [expr round(0.707 * $height)]
set bside($id,lx) $lx
set bside($id,rx) $rx
set bside($id,y) $y
set bside($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {set bside($id,color) $value}
-tag - -tags {set tags $value}
-state {
switch -- $value {
normal {set state normal}
hidden {set state hidden}
default {tk_messageBox -message "CreateBottomSide: \
Unrecognized state value: $value" -type ok}
}
}
default {tk_messageBox -message "CreateBottomSide: \
Unrecognized option: $option" -type ok}
}
}
set ah $bside($id,adjustedHeight)
set arx [expr $rx - $ah]
set ay [expr $y - $ah]
$theCanvas coords $id $lx $y $arx $ay
set c $bside($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
return $id
}
# Logically, the corner owns the territory out an adjustedHeight distance
# from the vertex. But I can't bring myself to make a separate little
# corner when it won't be visible. So I extend this side, and the right
# side, all the way to the vertex.
proc CreateBottomRightCorner {theCanvas x y height args} {
global brcorner
set id [$theCanvas create rectangle 0 0 1 1]
set brcorner($id,theCanvas) $theCanvas
set brcorner($id,adjustedHeight) [expr round(0.707 * $height)]
set brcorner($id,x) $x
set brcorner($id,y) $y
set brcorner($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {set brcorner($id,color) $value}
-tag - -tags {set tags $value}
-state {
switch -- $value {
normal {set state normal}
hidden {set state hidden}
default {tk_messageBox -message "CreateBottomRightCorner: \
Unrecognized state value: $value" -type ok}
}
}
default {tk_messageBox -message "CreateBottomRightCorner: \
Unrecognized option: $option" -type ok}
}
}
set ah $brcorner($id,adjustedHeight)
set ax [expr $x - $ah]
set ay [expr $y - $ah]
$theCanvas coords $id $x $y $ax $ay
set c $brcorner($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
return $id
}
proc CreateRightSide {theCanvas x ty by height args} {
global rside
set id [$theCanvas create rectangle 0 0 1 1]
set rside($id,theCanvas) $theCanvas
set rside($id,adjustedHeight) [expr round(0.707 * $height)]
set rside($id,x) $x
set rside($id,ty) $ty
set rside($id,by) $by
set rside($id,color) white
set tags ""
set state normal
foreach {option value} $args {
switch -- $option {
-color {set rside($id,color) $value}
-tag - -tags {set tags $value}
-state {
switch -- $value {
normal {set state normal}
hidden {set state hidden}
default {tk_messageBox -message "CreateRightSide: \
Unrecognized state value: $value" -type ok}
}
}
default {tk_messageBox -message "CreateRightSide: \
Unrecognized option: $option" -type ok}
}
}
set ah $rside($id,adjustedHeight)
set ax [expr $x - $ah]
set aby [expr $by - $ah]
$theCanvas coords $id $x $aby $ax $ty
set c $rside($id,color)
$theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
return $id
}
proc DestroyTopLeftCorner id {
global tlcorner
# I thought about converting from a tag to an id, if the value passed
# is not numeric, but how are you going to get the canvas name?
$tlcorner($id,theCanvas) delete $id
unset tlcorner($id,theCanvas)
unset tlcorner($id,adjustedHeight)
unset tlcorner($id,x)
unset tlcorner($id,y)
unset tlcorner($id,color)
}
# Rather than have a procedure "ShowTopLeftCorner" and one "HideTopLeftCorner"
# I think I'll have the orchestrator configure state using a tag that refers
# to all the parts.
proc DestroyLeftSide id {
global lside
$lside($id,theCanvas) delete $id
unset lside($id,theCanvas)
unset lside($id,adjustedHeight)
unset lside($id,x)
unset lside($id,ty)
unset lside($id,by)
unset lside($id,color)
}
proc DestroyBottomLeftCorner id {
global blcorner
$blcorner($id,theCanvas) delete $id
unset blcorner($id,theCanvas)
unset blcorner($id,adjustedHeight)
unset blcorner($id,x)
unset blcorner($id,y)
unset blcorner($id,color)
}
proc DestroyTopSide id {
global tside
$tside($id,theCanvas) delete $id
unset tside($id,theCanvas)
unset tside($id,adjustedHeight)
unset tside($id,lx)
unset tside($id,rx)
unset tside($id,y)
unset tside($id,color)
}
proc DestroyTopRightCorner id {
global trcorner
$trcorner($id,theCanvas) delete $id
unset trcorner($id,theCanvas)
unset trcorner($id,adjustedHeight)
unset trcorner($id,x)
unset trcorner($id,y)
unset trcorner($id,color)
}
proc DestroyBottomSide id {
global bside
$bside($id,theCanvas) delete $id
unset bside($id,theCanvas)
unset bside($id,adjustedHeight)
unset bside($id,lx)
unset bside($id,rx)
unset bside($id,y)
unset bside($id,color)
}
proc DestroyBottomRightCorner id {
global brcorner
$brcorner($id,theCanvas) delete $id
unset brcorner($id,theCanvas)
unset brcorner($id,adjustedHeight)
unset brcorner($id,x)
unset brcorner($id,y)
unset brcorner($id,color)
}
proc DestroyRightSide id {
global rside
$rside($id,theCanvas) delete $id
unset rside($id,theCanvas)
unset rside($id,adjustedHeight)
unset rside($id,x)
unset rside($id,ty)
unset rside($id,by)
unset rside($id,color)
}
# --------------------- Above are the pieces of a rectangle -------------------
# to be assembled in different ways.
# Some options that might be confusing are:
#
# dx, dy - If you have something written on the surface of your box
# (for example if the box is a button and the top of it says "Quit")
# as the box is raised and recessed, the text or image should be moved
# with a canvas move command. Dx and dy tell you how much to move your
# image over. They are relative to if you had written your image directly
# in the surface, without being raised above it or lowered below it.
# The names of the variables where you would like the values placed are
# passed using these options.
proc Create3DBox {theCanvas lx ty rx by height args} {
global box3d
set id [$theCanvas create rectangle 0 0 1 1]
set box3d($id,theCanvas) $theCanvas
set box3d($id,adjustedHeight) [expr round(0.707 * $height)]
set box3d($id,lx) $lx
set box3d($id,ty) $ty
set box3d($id,rx) $rx
set box3d($id,by) $by
set box3d($id,outSideColor) white
set box3d($id,inSideColor) white
set box3d($id,topFillColor) gray
set box3d($id,topOutlineColor) black
set box3d($id,relief) raised
set dxname ""
set dyname ""
set tags ""
foreach {option value} $args {
switch -- $option {
-outsidecolor {
set box3d($id,outSideColor) $value
# No checking that color value is valid.
}
-insidecolor {
set box3d($id,inSideColor) $value
}
-topfillcolor {
set box3d($id,topFillColor) $value
}
-topoutlinecolor {
set box3d($id,topOutlineColor) $value
}
-relief {
switch -- $value {
raised {
set box3d($id,relief) raised
}
sunken -
recessed {
set box3d($id,relief) recessed
# Tk users are likely to say sunken.
}
flat {
set box3d($id,relief) flat
}
default {
tk_messageBox -message "Create3DBox: \
Unrecognized relief value: $value" -type ok
}
}
}
-dx {
set dxname $value
}
-dy {
set dyname $value
}
-tag -
-tags {
set tags $value
}
default {
tk_messageBox -message "Create3DBox: Unrecognized\
option: $option" -type ok
}
}
}
set osc $box3d($id,outSideColor)
set isc $box3d($id,inSideColor)
set tfc $box3d($id,topFillColor)
set toc $box3d($id,topOutlineColor)
lappend tags box3d$id
set box3d($id,blcid) [CreateBottomLeftCorner $theCanvas $lx $by \
$height -color $osc -tags $tags]
set box3d($id,lsid) [CreateLeftSide $theCanvas $lx $ty $by $height \
-color $osc -tags $tags]
set box3d($id,tlcid) [CreateTopLeftCorner $theCanvas $lx $ty $height \
-color $osc -tags $tags]
set box3d($id,tsid) [CreateTopSide $theCanvas $lx $rx $ty $height \
-color $osc -tags $tags]
set box3d($id,trcid) [CreateTopRightCorner $theCanvas $rx $ty $height \
-color $osc -tags $tags]
set box3d($id,bsid) [CreateBottomSide $theCanvas $lx $rx $by $height \
-color $isc -tags $tags]
set box3d($id,brcid) [CreateBottomRightCorner $theCanvas $rx $by \
$height -color $isc -tags $tags]
set box3d($id,rsid) [CreateRightSide $theCanvas $rx $ty $by $height \
-color $isc -tags $tags]
$theCanvas itemconfig $id -outline $toc -fill $tfc -tags $tags
Draw3DBox $id localdx localdy
if {$dxname != ""} {
upvar $dxname dx
set dx $localdx
}
if {$dyname != ""} {
upvar $dyname dy
set dy $localdy
}
return $id
}
# First we set tags to an empty string, then set it with any list of tags,
# then appended our required tag. Thus we kept it a one level list.
#
# Typically, Create3DBox will be called with only one tag, but it it becomes
# part of a larger assemblage later, this may be useful.
proc Destroy3DBox id {
global box3d
DestroyBottomLeftCorner $box3d($id,blcid)
DestroyLeftSide $box3d($id,lsid)
DestroyTopLeftCorner $box3d($id,tlcid)
DestroyTopSide $box3d($id,tsid)
DestroyTopRightCorner $box3d($id,trcid)
DestroyRightSide $box3d($id,rsid)
DestroyBottomRightCorner $box3d($id,brcid)
DestroyBottomSide $box3d($id,bsid)
$box3d($id,theCanvas) delete $id
unset box3d($id,theCanvas)
unset box3d($id,adjustedHeight)
unset box3d($id,lx)
unset box3d($id,ty)
unset box3d($id,rx)
unset box3d($id,by)
unset box3d($id,outSideColor)
unset box3d($id,inSideColor)
unset box3d($id,topFillColor)
unset box3d($id,topOutlineColor)
unset box3d($id,relief)
unset box3d($id,blcid)
unset box3d($id,lsid)
unset box3d($id,tlcid)
unset box3d($id,tsid)
unset box3d($id,trcid)
unset box3d($id,rsid)
unset box3d($id,brcid)
unset box3d($id,bsid)
}
# Seems best to always have all the parts of a rectangle exists, if the
# rectangle exists. Some of the parts may have the state "hidden".
# Otherwise, we have to create and delete things when the button pops up,
# or create things only when they are first called for, and keep track
# of whether the piece exists yet.
#
# I'll put this here arbitrarily. It seems unfortunate to calculate the
# adjusted height from the passed height of the rectangle in multiple
# different places. What if one calculates it slightly differently?
# Also, it seems silly to put the same code to handle an option like
# -state in each routine. If I were using something like XOTcl, I would
# handle the options the specialized object knows about, and then finish
# my routine in the parent object with the next command.
proc Draw3DBox {id dxname dyname} {
global box3d
set c $box3d($id,theCanvas)
set lx $box3d($id,lx)
set ty $box3d($id,ty)
set rx $box3d($id,rx)
set by $box3d($id,by)
set ah $box3d($id,adjustedHeight)
set osc $box3d($id,outSideColor)
set isc $box3d($id,inSideColor)
set tfc $box3d($id,topFillColor)
set toc $box3d($id,topOutlineColor)
set r $box3d($id,relief)
upvar $dxname dx
upvar $dyname dy
if {$r == "raised"} {
set ulstate normal
set lrstate hidden
} elseif {$r == "recessed"} {
set ulstate hidden
set lrstate normal
} else { ;# Flat
set ulstate hidden
set lrstate hidden
}
$c itemconfig $box3d($id,blcid) -state $ulstate
$c itemconfig $box3d($id,lsid) -state $ulstate
$c itemconfig $box3d($id,tlcid) -state $ulstate
$c itemconfig $box3d($id,tsid) -state $ulstate
$c itemconfig $box3d($id,trcid) -state $ulstate
$c itemconfig $box3d($id,rsid) -state $lrstate
$c itemconfig $box3d($id,brcid) -state $lrstate
$c itemconfig $box3d($id,bsid) -state $lrstate
if {$r == "raised"} {
$c coords $id [expr $lx + $ah] [expr $ty + $ah] [expr $rx + $ah] \
[expr $by + $ah]
$c lower $id box3d$id
# Probably could just lower below everything, but if sometime in
# the future the 3d box is part of a more complicated assemblage,
# it will be good to stay with my group.
#
# Lowered so that outline will only be visible where top meets
# background, not where it meets sides.
set dx $ah
set dy $ah
} elseif {$r == "recessed"} {
$c coords $id $lx $ty [expr $rx - $ah] [expr $by - $ah]
$c lower $id box3d$id
set dx -$ah
set dy -$ah
} else { ;# Flat
$c coords $id $lx $ty $rx $by
set dx 0
set dy 0
}
}
proc Set3DBoxRelief {id relief args} {
global box3d
if {![info exists box3d($id,theCanvas)]} {
tk_messageBox -message "Set3DBoxRelief: no such id: $id" -type ok
}
# I'm not going to check that the relief value is legal each time.
# The user may be waiting for his button to go down.
if {$relief == "sunken"} {set relief recessed}
if {$box3d($id,relief) == $relief} {
set ah $box3d($id,adjustedHeight)
if {$relief == "raised"} {
set localdx $ah
set localdy $ah
} elseif {$relief == "recessed"} {
set localdx -$ah
set localdy -$ah
} else {
set localdx 0
set localdy 0
}
} else {
set box3d($id,relief) $relief
Draw3DBox $id localdx localdy
}
# Set3DBoxRelief really shouldn't know things about drawing, like that
# if the relief is raised, any label on top of the button should be
# moved down and right by adjustedHeight amount. I could always call
# Draw3DBox. I guess I'll regard this knowledge on Set3DBoxRelief's
# part as an optimization.
set dxname ""
set dyname ""
foreach {option value} $args {
switch -- $option {
-dx {set dxname $value}
-dy {set dyname $value}
# Not checking for unrecognized option.
}
}
if {$dxname != ""} {
upvar $dxname dx
set dx $localdx
}
if {$dyname != ""} {
upvar $dyname dy
set dy $localdy
}
}
# It might be desired to bind to the whole box, not to each of its subparts.
# One way to accomplish this might be to put a polygon over the top of the box.
# You can give the polygon a fill color and outline color of the empty string.
proc Get3DBoxPolygon {id} {
global box3d
set coords {}
set ah $box3d($id,adjustedHeight)
set lx $box3d($id,lx)
set ty $box3d($id,ty)
set rx $box3d($id,rx)
set by $box3d($id,by)
lappend coords $lx $ty $rx $ty [expr $rx + $ah] [expr $ty + $ah]
lappend coords [expr $rx + $ah] [expr $by + $ah]
lappend coords [expr $lx + $ah] [expr $by + $ah] $lx $by
return $coords
}