proc bevelLine { canvas c0 c1 c2 c3 width x0 y0 x1 y1 } { set halfWidth [expr {$width/2}] set d [expr {$x1-$x0}] if {$d > 0} { set side UpperLeft } elseif {$d < 0} { set side LowerRight } else { set d [expr {$y1-$y0}] if {$d > 0} { set side LowerRight } else { set side UpperLeft } } switch -- $side { UpperLeft { set outside $c0 set inside $c1 } LowerRight { set inside $c2 set outside $c3 } } # The "main" line set id1 [$canvas create line $x0 $y0 $x1 $y1 \ -fill $inside -width $width] # The highlight line, half the width, slightly offset (moved below) set id2 [$canvas create line $x0 $y0 $x1 $y1 \ -fill $outside -width $halfWidth] # Figure out which way to move the accent line off the center of # the main line. # # We want to move perpendicular to the main line. Noting that Tk # uses a left-handed coordinate system (x to the right, y down), # the transformation matrix for a 90 degree counter-clockwise # rotation is: # / 0 -1 \ # \ 1 0 / # For example, a line from (0,0) down and right to (2,1) has a # perpendicular vector from (0,0) to (1,-2) because: # (2 1) * / 0 -1 \ = (2*0 + 1*1 2*-1 + 1*0) = (1 -2) # \ 1 0 / # Simplifying, we get: # xp = y # yp = -x # Get the vector perpendicular to this line segment set xp [expr {$y1 - $y0}] set yp [expr {$x0 - $x1}] # Get the offset for the accent line if {$xp == 0} { # Perpendicular has no X component, so the line is horizontal. # dx is 0, dy is 1/2 halfWidth set dx 0 set dy [expr {$halfWidth/2}] } elseif {$yp == 0} { # Perpendicular has no Y component, so the line is vertical. # dx is 1/2 halfWidth, dy is 0 set dx [expr {$halfWidth/2}] set dy 0 } else { # Line is neither horizontal nor vertical, # scale the perpendicular. # Get the length of the vector set l [expr {sqrt($xp*$xp + $yp*$yp)}] # Figure out how much to scale the perp. to get the offset set scale [expr {2*$l/$halfWidth}] set dx [expr {int($xp / $scale)}] set dy [expr {int($yp / $scale)}] } .c move $id2 $dx $dy # return [list $id1 $id2] } # bevelLine # WUZ - it might be nice if this returned a composit tag that could # be used to manipulate the whole polyline as a unit. proc bevelPolyLine { canvas c0 c1 c2 c3 width args } { if {[llength $args] < 4 || [llength $args]%2} { error "Must be an even number of coordinates, four or greater" } set x1 [lindex $args 0] set y1 [lindex $args 1] set args [lrange $args 2 end] while {[llength $args]} { set x0 $x1 set y0 $y1 set x1 [lindex $args 0] set y1 [lindex $args 1] set args [lrange $args 2 end] # WUZ - We need a way to get all the accent lines for a # polyline above the base lines. bevelLine $canvas $c0 $c1 $c2 $c3 $width $x0 $y0 $x1 $y1 } } # bevelPolyLine proc bevelRect { canvas c0 c1 c2 c3 width x1 y1 x2 y2 } { bevelPolyLine $canvas $c0 $c1 $c2 $c3 $width \ $x1 $y1 \ $x1 $y2 \ $x2 $y2 \ $x2 $y1 \ $x1 $y1 } # bevelRect # Need a canvas to work on pack [canvas .c] # A rectangle (e.g., a button) bevelRect .c white lightgray darkgray black 2 10 70 70 10 # An octagon bevelPolyLine .c white lightgray darkgray black 2 \ 20 44 20 30 30 20 44 20 \ 54 30 54 44 44 54 30 54 \ 20 44