# 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.
 #
 #	  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]]]