Updated 2013-02-08 02:02:39 by RLE

MG Jan 25th 2005 - Tested on Windows XP. The majority of the lines do move for me; the two rectangles at the right, along with the shapes inside them all move, and the two lines to the left which disect the square move (the square itself does not). The red/green/blue lines in the top left and the star at the bottom left are static, though.

MM Thank you for testing it! Yes, some of the lines are static to test different patterns: only the ones that are created from [main] as scripts for [after 0] are meant to be marching ants, the others (the little square, the star, and the three lines in the upper left corner of the canvas) are static.

PWQ On my Linux box, wish hangs and does not ever update. I changed one of the after 50, to after 60 and the display appeared and all the ant's march. There must be some weirdness in tcl's event processing that pushed the idle callback for the display to the back of the list.

MM Yes: the updating of the widgets is queued, at the C language level, with a call to Tcl_DoWhenIdle(). I am also on GNU+Linux (1.3 GHz processor), and see no delay, so I do not know what to tell. I do not know the internals of the canvas widget, but I think that drawing lines that way results in many events appended to the idle queue and maybe this slows down the app, especially if one has a busy CPU.

PWQ For me the critical issue is , should tcl defer an idle call back forever infavour of later posted after events?. Some of the calls were 'after 0' which seems to have heighest priority, but even changing them to after idle, we still don't see tcl even displaying the toplevel, let alone processing the canvas events.

MM You can start by inserting [tkwait visibility .] before putting the lines on the canvas: that way the window will be drawn; then you can invoke [update] to force the queued events to be processed. On this Wiki there are many pages dealing with the usage of [update].
 # 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.