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