Version 1 of Canvas dash lines

Updated 2005-01-25 15:19:06 by MM

# canvas_dashed_lines.tcl --

 # 
 # Part of: Useless Widgets Package
 # Contents: test script for dashed lines and marching ants
 # Date: Sun Jan 23, 2005
 # 
 # Abstract
 # 
 #        This does not use the "-dashoffset" canvas option, so it should
 #        work even on MS Windows(tm) where the option appears to have
 #        limitations; the author has not tested this, though: anyone?.
 #
 #          Drawing a line with a pattern is straightforward with no offset
 #        in the pattern: we just draw a sequence of segments and jumps
 #        taking the lengths from the pattern; while doing it: we cumpute
 #        the length of the line drawn so far and when it exceeds the
 #        requested length just stop, cutting a segment if required.
 #
 #          Example of pattern: { 10 3 5 2 },
 #
 #                            10      3   5  2
 #                        |----------   -----  |
 #                                   ...     ..
 #
 #                        |...pattern length...| 10+3+5+2=20
 #
 #        the pattern starts with a segment, not a jump.
 #
 #          The approach used to implement the offset in the pattern is to
 #        split the line in two: a "preline", that represents the fraction
 #        of the pattern that is requested; the "subline" that is a common
 #        line with no offset.
 #
 #          The preline is shorter in length than the pattern: to draw it
 #        we build a new special pattern whose length equals the length of
 #        the preline, with all the right segments in place, then we draw
 #        a common line with no offset but we use the special pattern.
 #
 #          Exmaple of special pattern: if the offset is 7 in the pattern
 #        { 10 3 5 2 }, the preline pattern is { 3 3 5 2 }; if the offset
 #        is 12, the preline pattern is { 1 5 2 }.
 #
 # Copyright (c) 2005 Marco Maggi
 # 
 # The author  hereby grant permission to use,  copy, modify, distribute,
 # and  license this  software  and its  documentation  for any  purpose,
 # provided that  existing copyright notices  are retained in  all copies
 # and that  this notice  is included verbatim  in any  distributions. No
 # written agreement, license, or royalty  fee is required for any of the
 # authorized uses.  Modifications to this software may be copyrighted by
 # their authors and need not  follow the licensing terms described here,
 # provided that the new terms are clearly indicated on the first page of
 # each file where they apply.
 # 
 # IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
 # FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
 # ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
 # DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
 # POSSIBILITY OF SUCH DAMAGE.
 # 
 # THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
 # INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
 # MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
 # NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
 # AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
 # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 # 
 #

 #page
 ## ------------------------------------------------------------
 ## Setup.
 ## ------------------------------------------------------------

 package require Tcl 8.4
 package require Tk  8.4

 #page
 ## ------------------------------------------------------------
 ## Widget options.
 ## ------------------------------------------------------------

 option add *borderWidth                1

 #page
 ## ------------------------------------------------------------
 ## Main.
 ## ------------------------------------------------------------

 proc main {} {
     global        exit_trigger

     wm title . "Canvas Pattern Lines and Marching Ants"
     wm geometry . +200+100

     canvas .c -width 500 -height 300 -background white
     grid .c -sticky news

     uwp_canvas_pattern_line .c {10 10 290 50} {10 5} { LineOne }
     uwp_canvas_pattern_line .c {10 20 290 60} {10 2 2 2} { LineTwo }
     uwp_canvas_pattern_line .c {10 30 290 70} {20 3 15 3 10 3 5 3} { LineThree }
     put_star
     uwp_canvas_pattern_poly .c {100 100  150 100  150 150 100 150} {10 5} { PolyTen }
     after 0 marching_ants_in_line_forward
     after 0 marching_ants_in_line_backward
     after 0 marching_ants_in_poly_forward
     after 0 marching_ants_in_poly_backward

     foreach {x y} [polygon_star_coords 50.0 70.0 8] {
         lappend coords [expr {$x+400.0}] [expr {$y+150.0}]
     }
     foreach {x y} [polygon_star_coords 30.0 40.0 5] {
         lappend coords [expr {$x+400.0}] [expr {$y+150.0}]
     }
     after 0 [list marching_ants_in_poly_star $coords]

     .c itemconfigure LineOne -fill red
     .c itemconfigure LineTwo -fill blue
     .c itemconfigure LineThree -fill green
     .c itemconfigure PolyTen -fill black

     grid [button .quit -text Exit -command main_exit]
     focus .quit
     bind .quit <Return> main_exit
     bind . <Escape> main_exit

     interp alias {} main_exit {} set exit_trigger 1
     vwait exit_trigger
     exit
 }
 #page
 proc put_star {} {
     for {set i 0} {$i < 16.0} {incr i} {
         set yaw [expr {double($i)*6.28318530718/16.0}]
         set coords [list 150.0 230.0 \
                         [expr {150.0+70.0*cos(double($yaw))}] \
                         [expr {230.0+70.0*sin(double($yaw))}]]
         uwp_canvas_pattern_line .c $coords {10 3 7 3 4 3} { Circle }
     }
 }
 proc marching_ants_in_line_forward { {offset 0.0} } {
     after 50 [list marching_ants_in_line_forward [expr {$offset+2.0}]]
     .c delete LineFour
     uwp_canvas_pattern_line .c {10 100 290 140} \
         {50 5 40 5 30 5 20 5 10 5} { LineFour } $offset
     .c itemconfigure LineFour -fill magenta
     .c itemconfigure UWPPatternLinePreline -fill green
 }
 proc marching_ants_in_line_backward { {offset 0.0} } {
     after 50 [list marching_ants_in_line_backward [expr {$offset-2.0}]]
     .c delete LineFive
     uwp_canvas_pattern_line .c {10 110 290 150} \
         {50 5 40 5 30 5 20 5 10 5} { LineFive } $offset
     .c itemconfigure LineFive -fill magenta
     .c itemconfigure UWPPatternLinePreline -fill green
 }
 proc marching_ants_in_poly_forward { {offset 0.0} } {
     after 50 [list marching_ants_in_poly_forward [expr {$offset+2.0}]]
     .c delete PolyOne
     uwp_canvas_pattern_poly .c {310 20  480 20  480 280  310 280} \
         {20 3} { PolyOne } $offset
     .c itemconfigure PolyOne -fill black
 #    .c itemconfigure UWPPatternLinePreline -fill green
 }
 proc marching_ants_in_poly_backward { {offset 0.0} } {
     after 50 [list marching_ants_in_poly_backward [expr {$offset-2.0}]]
     .c delete PolyTwo
     uwp_canvas_pattern_poly .c {320 30  470 30  470 270  320 270} \
         {20 3} { PolyTwo } $offset
     .c itemconfigure PolyTwo -fill black
 }
 #page
 proc marching_ants_in_poly_star { coords {offset 0.0} } {
     after 50 [list marching_ants_in_poly_star $coords [expr {$offset+2.0}]]
     .c delete PolyStar
     uwp_canvas_pattern_poly .c $coords {20 3} { PolyStar } $offset
     .c itemconfigure PolyStar -fill black
 }
 proc polygon_regular_coords { num radius {fraction 1.0} } {
     for {set i 0} {$i < $num} {incr i} {
         set angle [expr {6.28318530718/double($fraction)+
                          (6.28318530718*double($i)/double($num))}]
         lappend coords \
             [expr {double($radius)*cos($angle)}] [expr {double($radius)*sin($angle)}]
     }
     return $coords
 }
 proc polygon_star_coords { in_radius out_radius num } {
     set fraction [expr {double($num)*2.0}]
     foreach {x1 y1} [polygon_regular_coords $num $in_radius] \
         {x2 y2} [polygon_regular_coords $num $out_radius $fraction] {
             lappend result $x1 $y1 $x2 $y2
     }
     return $result
 }
 #page
 proc uwp_canvas_pattern_line {
     widget line_coords pattern tags {pattern_offset 0.0} {invert 0}
 } {
     # If you need a full line do not call this procedure, please.
     if { ! [llength $pattern] } {return}

     # We try to force the conversion to double so that in the code below
     # we can omit the  "double" operator: this increases the readability
     # of the  code. For some  reason I cannot  figure out, but  that TCL
     # figures perfectly,  I cannot use [expr  {double($num)}] to convert
     # to double; using [format %f  $num] appears to solve the problems I
     # had with [expr].
     set pattern_offset [format %f $pattern_offset]
     for {set i 0} {$i < [llength $pattern]} {incr i} {
         lset pattern $i [format %f [lindex $pattern $i]]
         if { [lindex $pattern $i] < 0.0 } {
             return -code error "negative pattern lengths are not allowed"
         }
     }
     for {set i 0} {$i < [llength $line_coords]} {incr i} {
         lset line_coords $i [format %f [lindex $line_coords $i]]
     }

     # We compute the lengths of the projections of the segments on the X
     # and Y  axis because they are used  again and again in  the loop at
     # the  end. While  we  are  looping: we  compute  the total  pattern
     # length, even if it is used only when the offset not null.

     set yaw [uwp_yaw_angle_from_line_coords $line_coords]
     set cos [expr {cos($yaw)}]
     set sin [expr {sin($yaw)}]
     set pattern_length 0.0
     foreach segment_length $pattern {
         lappend delta_segment \
             [expr {$segment_length*cos($yaw)}] [expr {$segment_length*sin($yaw)}]
         set pattern_length [expr {$pattern_length+$segment_length}]
     }

 #page
     # We  draw the  preline  only if  there  is an  offset,  else we  go
     # directly to the normal line drawing code.

     if { $pattern_offset != 0.0 } {
         # Normalise the offset so that  it is not greater than the total
         # pattern length. The preline is  meant to be only a fraction of
         # the pattern  length: "whole" patterns are drawn  by the normal
         # line code below.
         while { $pattern_offset > $pattern_length } {
             set pattern_offset [expr {$pattern_offset-$pattern_length}]
         }
         while { $pattern_offset < -($pattern_length) } {
             set pattern_offset [expr {$pattern_offset+$pattern_length}]
         }

         # Convert a  negative offset to the  equivalent positive offset.
         # It  is  easy to  do  this when  the  offset  has already  been
         # normalised; not so immediate before the normalisation.
         if {$pattern_offset < 0.0} {
             set pattern_offset [expr {$pattern_length+$pattern_offset}]
         }

         # virtual
         # pattern       whole line begin =                      preline end =
         # begin         preline begin                           subline begin
         # v             v                                       v
         # |-------------|-----------------------|---------------|------------
         #                                                     (x,y)
         #
         # |.............|pattern_offset (after normalisation, that is >0)
         #
         #       |.. [lindex $pattern $i] .......|
         #
         # |.....current_pattern_length..........|
         #            
         #               |.first_segment_length..|
         #
         # |....................pattern_length...................|
         #                 

         # Find the index of the segment that is cut by the offset.

         set current_pattern_length 0.0
         for {set i 0} {$i < [llength $pattern]} {incr i} {
             set current_pattern_length \
                 [expr {$current_pattern_length+[lindex $pattern $i]}]
             # Moving  this condition inside  the [if]  clause is  not so
             # immediate: by doing the  test here we have incremented the
             # "current_pattern_length",  but  not  incremented  the  "i"
             # counter yet.   This makes easy to code  the two statements
             # just outside of the loop.
             if {$current_pattern_length > $pattern_offset} {break}
         }

         # Build the  special pattern for the preline:  the first segment
         # is the ending portion of the  one cut by the offset; the other
         # segments are the ones that are part of the line.
         set prepattern \
             [concat [expr {$current_pattern_length-$pattern_offset}] \
                  [lrange $pattern [incr i] end]]

         # If the index  of the first segment is even:  it must be drawn,
         # it is not a jump; if the  index is odd: it is a jump. The code
         # that  draws the  subline/common  line assumes  that the  first
         # segment is not a jump, if the "invert" parameter is false.
         set preline_invert [expr { ($i % 2)? 0 : 1 }]

         # Compute the coordinates of the  end of the preline: this point
         # is one  with the  beginning of the  normal line.  The internal
         # subtraction  is computed twice:  I think  that this  is faster
         # than invoking [expr] and setting a variable.
         set x [expr {[lindex $line_coords 0]+($pattern_length-$pattern_offset)*$cos}]
         set y [expr {[lindex $line_coords 1]+($pattern_length-$pattern_offset)*$sin}]

         # Draw the preline:  the starting point is the  one requested by
         # the caller  as starting  point of the  whole line;  the ending
         # point has been computed in the code above.
         #
         # The  tag "UWPPatternLinePreline"  is here  only  for debugging
         # purposes: to configure the preline with a color different from
         # the rest of the line makes it visible.
         uwp_canvas_pattern_line $widget \
             [lreplace $line_coords 2 3 $x $y] $prepattern \
             [concat $tags UWPPatternLinePreline] 0.0 $preline_invert

         # Replace the original starting point  of the whole line so that
         # the code below will draw the subline.
         lset line_coords 0 $x
         lset line_coords 1 $y
     }
 #page
     # These are used to compute the  fraction of the pattern that is cut
     # at the  end of  the line: it  is required  to draw a  polygon (and
     # especially the marching ants).
     #
     # "restX" and "restY"  represent the projection on the  X and Y axis
     # of the portion  of the segment that  is cut out at the  end of the
     # line.
     set restX 0.0
     set restY 0.0

     # Select the  procedure to use to  test line end and  to compute the
     # rest and the  last fraction of segment to  draw.  By splitting all
     # the possible cases into  simple procedures simplifies the code and
     # may also make it more efficient; the end of line test is performed
     # again and again in the loop below.
     set x_forward [expr { [lindex $line_coords 0] <= [lindex $line_coords 2] }]
     set y_forward [expr { [lindex $line_coords 1] <= [lindex $line_coords 3] }]
     if { $x_forward && $y_forward } {
         set line_end_cmd uwp_p_canvas_pattern_line_ff
         set rest_x_cmd   uwp_p_canvas_pattern_line_rest_x_forward
         set rest_y_cmd   uwp_p_canvas_pattern_line_rest_y_forward
     } elseif { $x_forward } {
         set line_end_cmd uwp_p_canvas_pattern_line_fb
         set rest_x_cmd   uwp_p_canvas_pattern_line_rest_x_forward
         set rest_y_cmd   uwp_p_canvas_pattern_line_rest_y_backward
     } elseif { $y_forward } {
         set line_end_cmd uwp_p_canvas_pattern_line_bf
         set rest_x_cmd   uwp_p_canvas_pattern_line_rest_x_backward
         set rest_y_cmd   uwp_p_canvas_pattern_line_rest_y_forward
     } else {
         set line_end_cmd uwp_p_canvas_pattern_line_bb
         set rest_x_cmd   uwp_p_canvas_pattern_line_rest_x_backward
         set rest_y_cmd   uwp_p_canvas_pattern_line_rest_y_backward
     }

 #page
     # Example for the pattern: { 10 3 5 3 5 3 }
     #
     #       |......pattern_length......|......pattern_length.........|
     #
     #   starting point                              end point
     #       v                                          v
     #       O--------   -----   -----   ----------   --O--   -----   |
     #          10     3   5   3   5   3 ,   10     3   ^      ^
     #                                                  |      |
     #                                       this segment      this segment
     #                                       is cut in two     is completely
     #                                       by the end of     left out
     #                                       the line
     #
     #                                                  |.............|
     #                                    this is the "rest": the portion of
     #                                    pattern that's cut out of the line

     # Build the  list that will hold  the coordinates of  the segment to
     # draw or the jump to skip.
     set segment_coords \
         [list [expr {[lindex $line_coords 0]}] [expr {[lindex $line_coords 1]}] {} {}]

     while { 1 } {
         # "blank" is  a boolean that  controls whether the segment  is a
         # line  or a  jump:  if it  is false  we  draw a  line, else  we
         # skip. The default is to start with a line.
         set blank $invert

         # We need  this counter only to  keep track of  which segment we
         # are drawing in  the "pattern" list. We use it  only at the end
         # of the line to know which segments are cut out at the end.
         set i 0

         foreach {deltaX deltaY} $delta_segment {
             lset segment_coords 2 [expr {[lindex $segment_coords 0]+$deltaX}]
             lset segment_coords 3 [expr {[lindex $segment_coords 1]+$deltaY}]
             if { ! [$line_end_cmd] } {
                 $rest_x_cmd
                 $rest_y_cmd
             } else {
                 # Init  the rest  with  the length  of  the fraction  of
                 # segment that  is cut out.  "restX" and  "restY" may be
                 # zero. Thank You, Pitagora.
                 set rest_offset [expr {sqrt(pow($restX,2.0)+pow($restY,2.0))}]
                 # Add the length of all the segments that are completely
                 # left out.
                 for {} {$i < [llength $pattern]} {incr i} {
                     set rest_offset [expr {$rest_offset+[lindex $pattern $i]}]
                 }
                 # Return the rest so that the caller can use it.
                 return $rest_offset
             }
             incr i
             if { ! $blank } { $widget create line $segment_coords -tags $tags }
             # Invert the skip flag.
             set blank [expr {!$blank}]
             # Now:  the end  point of  this segment-or-jump  becomes the
             # starting point of the next segment-or-jump.
             lset segment_coords 0 [lindex $segment_coords 2]
             lset segment_coords 1 [lindex $segment_coords 3]
         }
     }
 }
 #page
 proc uwp_p_canvas_pattern_line_ff {} {
     upvar line_coords line_coords segment_coords segment_coords
     expr { ([lindex $segment_coords 0] >= [lindex $line_coords 2]) &&
            ([lindex $segment_coords 1] >= [lindex $line_coords 3]) }
 }
 proc uwp_p_canvas_pattern_line_bb {} {
     upvar line_coords line_coords segment_coords segment_coords
     expr { ([lindex $segment_coords 0] <= [lindex $line_coords 2]) &&
            ([lindex $segment_coords 1] <= [lindex $line_coords 3]) }
 }
 proc uwp_p_canvas_pattern_line_fb {} {
     upvar line_coords line_coords segment_coords segment_coords
     expr { ([lindex $segment_coords 0] >= [lindex $line_coords 2]) &&
            ([lindex $segment_coords 1] <= [lindex $line_coords 3]) }
 }
 proc uwp_p_canvas_pattern_line_bf {} {
     upvar line_coords line_coords segment_coords segment_coords
     expr { ([lindex $segment_coords 0] <= [lindex $line_coords 2]) &&
            ([lindex $segment_coords 1] >= [lindex $line_coords 3]) }
 }
 #page
 proc uwp_p_canvas_pattern_line_rest_x_forward {} {
     upvar line_coords line_coords segment_coords segment_coords restX restX

     if { [lindex $segment_coords 2] > [lindex $line_coords 2] } {
         set restX [expr {[lindex $segment_coords 2]-[lindex $line_coords 2]}]
         lset segment_coords 2 [lindex $line_coords 2]
     }
 }
 proc uwp_p_canvas_pattern_line_rest_x_backward {} {
     upvar line_coords line_coords segment_coords segment_coords restX restX

     if { [lindex $segment_coords 2] < [lindex $line_coords 2] } {
         set restX [expr {[lindex $line_coords 2]-[lindex $segment_coords 2]}]
         lset segment_coords 2 [lindex $line_coords 2]
     }
 }
 proc uwp_p_canvas_pattern_line_rest_y_forward {} {
     upvar line_coords line_coords segment_coords segment_coords restY restY

     if { [lindex $segment_coords 3] > [lindex $line_coords 3] } {
         set restY [expr {[lindex $segment_coords 3]-[lindex $line_coords 3]}]
         lset segment_coords 3 [lindex $line_coords 3]
     }
 }
 proc uwp_p_canvas_pattern_line_rest_y_backward {} {
     upvar line_coords line_coords segment_coords segment_coords restY restY

     if { [lindex $segment_coords 3] < [lindex $line_coords 3] } {
         set restY [expr {[lindex $line_coords 3]-[lindex $segment_coords 3]}]
         lset segment_coords 3 [lindex $line_coords 3]
     }
 }
 #page
 proc uwp_yaw_angle_from_line_coords { coords } {
     expr {atan2(double([lindex $coords 3])-double([lindex $coords 1]),
                 double([lindex $coords 2])-double([lindex $coords 0]))}
 }
 #page
 proc uwp_canvas_pattern_poly { widget coords pattern tags {offset 0.0} } {
     set line_coords [list [lindex $coords 0] [lindex $coords 1] {} {}]
     for {set i 2} {$i < [llength $coords]} {incr i} {
         lset line_coords 2 [lindex $coords $i]
         lset line_coords 3 [lindex $coords [incr i]]
         set offset [expr {-([uwp_canvas_pattern_line \
                                  $widget $line_coords $pattern $tags $offset])}]
         lset line_coords 0 [lindex $line_coords 2]
         lset line_coords 1 [lindex $line_coords 3]
     }
     lset line_coords 2 [lindex $coords 0]
     lset line_coords 3 [lindex $coords 1]
     uwp_canvas_pattern_line $widget $line_coords $pattern $tags $offset
 }
 #page
 ## ------------------------------------------------------------
 ## Let's go.
 ## ------------------------------------------------------------

 main

 ### end of file
 # Local Variables:
 # mode: tcl
 # End:

See also Canvas selection with marching ants.


[Category GUI]