Beveled lines

Wondering why the buttons in a BWidgets SpinBox looked different from a native spinbox on Win32, I found the button in the SpinBox was just a rectangle drawn on a canvas but the Win32 button had a "beveled" edge with a 2-step shadow. One solution to making the BWidgets SpinBox look better was to make the lines beveled. This draft code draws beveled lines on a canvas. Feedback welcome... -- CLN -

  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