The following code allows affine transforms of polygon items on a canvas. Other canvas items like rectangle, oval, text... cannot be transformed. Let's make the previous sentence less ambiguous; I think it should be, "the code offered here does not provide for transformation of rectangles, ovals, ..."
Derived from a post on comp.lang.tcl by Donal Fellows:
proc translation {dx dy} {list 1 0 0 1 $dx $dy}
proc reflect-x {} {list 1 0 0 -1 0 0}
proc reflect-y {} {list -1 0 0 1 0 0}
proc shear {sx sy} {list 1 $sx $sy 1 0 0}
set ::pi [expr {atan(1)*4}]
proc rotation {angle {units radians}} {
global pi
switch -- $units {
d - de - deg - degr - degre - degree - degrees {
set angle [expr {double($angle)/180*$pi}]
}
g - gr - gra - grad - gradi - gradie - gradien -
gradient - gradients { # I think I've spelt this one right...
set angle [expr {double($angle)/200*$pi}]
}
r - ra - rad - radi - radia - radian - radians {
# Do nothing
}
default {
return -code error "unknown angle unit \"$units\": must be\
one of degrees, gradients or radians"
}
}
list [expr {cos($angle)}] [expr {sin($angle)}] \
[expr {-sin($angle)}] [expr {cos($angle)}] 0 0
}
proc apply_affine {transform args} {
if {[llength $args]==1} {set args [lindex $args 0]}
set result [list]
lassign $transform a b c d e f
foreach {x y} $args {
lappend result [expr {$a*$x+$b*$y+$e}] [expr {$c*$x+$d*$y+$f}]
}
return $result
}
proc combine_affine {transform args} {
lassign $transform a b c d e f
foreach xform $args {
lassign $xform i j k l m n
# Next line does simultaneous assignment...
lassign [list \
[expr {$a*$i+$c*$j}] [expr {$b*$i+$d*$j}] \
[expr {$a*$k+$c*$l}] [expr {$b*$k+$d*$l}] \
[expr {$e*$i+$f*$j+$m}] [expr {$e*$k+$f*$l+$n}]] \
a b c d e f
}
list $a $b $c $d $e $f
}pack [canvas .c]
.c create polygon 50 50 80 60 90 90 60 80 \
-fill green -outline white -tag shape
bind .c <1> {rotate_about 10 %x %y}
bind .c <3> {rotate_about -10 %x %y}
proc rotate_about {d x y} {
# Rotates by $d degrees about the given point by applying the
# transforms "Translate to origin, rotate by $d, translate back"
set xform [combine_affine \
[translation -$x -$y] [rotation $d deg] [translation $x $y] ]
set coords [apply_affine $xform [.c coords shape]]
.c coords shape {*}$coords
}But how slow is all that? Lots of calls to expr, after all. Can this possibly be interactive? I (RWT) think so. Try this variation to see how fast the affine transformers can be on your system.
pack [canvas .c]
set numPoints 100
for {set i 0} {$i<$numPoints*2} {incr i} {
lappend points [expr {rand()*50+50}]
}
.c create polygon $points \
-outline blue -fill "" -tag shape
bind .c <ButtonPress-1> {start_drag +1}
bind .c <ButtonRelease-1> {stop_drag}
bind .c <ButtonPress-3> {start_drag -1}
bind .c <ButtonRelease-3> {stop_drag}
proc start_drag {amount} {bind .c <Motion> "rotate_about $amount %x %y"}
proc stop_drag {} {bind .c <Motion> {}}
proc rotate_about {d x y} {
# Rotates by $d degrees about the given point by applying the
# transforms "Translate to origin, rotate by $d, translate back"
set xform [combine_affine \
[translation -$x -$y] [rotation $d deg] [translation $x $y] ]
set coords [apply_affine $xform [.c coords shape]]
.c coords shape {*}$coords
}Affine Transforms (I've no idea where Affine comes from) [ CL believes, without certainty about the details, that it's an anglicization of the French "affiné", for "(close) relative" or "closely related"] are a general way of representing all sorts of planar transforms (they also have an obvious extension to 3D though computing the rotations can be much trickier there) and combining them to get single transforms that have the same effect as a series of individual transforms (this is where they gain of an ad-hoc mechanism.) They form a fundamental part of the imaging model of PostScript, PDF and Java2D. (SVG too?)
Arjen Markus: (Aside on the etymology of "affine": My Latin dictionary lists "affinis" (ad-finis) as a word meaning something like "akin", being related by marriage and so on. So, affine transforms transform some object into another object sufficiently alike to notice the likeness.)
They represent each transform as a six-tuple of values and each point or vector (the difference really is non-existent at this level) as a pair of values. But these representations are really short-hands for the full mathematical representation with all the constant terms factored out. Thus, the point {x y} is really the vector:
/ x \ | y | \ 1 /
The third term is a scaling factor, and if non-unit you should divide each value in the vector by it (incidentally making that value be 1 again.)
Similarly, the transform {a b c d e f} is really:
/ a b 0 \ | c d 0 | \ e f 1 /
(The third column would allow for sophisticated non-linear scaling if it had values other than above, but nobody seems to want that.)
Now, matrix algebra 101 tells us that when we multiply the above transform by the above vector, we get:
/ ax+cy+e \ | bx+dy+f | \ 1 /
And this is exactly what we want with linear transforms, as it allows us to let the previous x and y components of the vector influence what the new vector is (giving rotation, scaling, reflection, and shearing) while applying a simple translation at the same time. Perfect!
And if we multiply the matrices together, we can even combine these transforms (and yes, it works the obvious way with transforms being applied from left to right.)
/ a b 0 \ / i j 0 \ / ai+cj bi+dj 0 \ | c d 0 | * | k l 0 | = | ak+cl bk+dl 0 | \ e f 1 / \ m n 1 / \ ei+fj+m ek+fl+n 1 /
You can learn more about this from loads of different standard maths and graphics texts.
KPV: the octabug code uses affine transforms to do its rotations, etc. But since it's a 3-dimension image, it uses a 4x4 transformation matrix.
SDW: The TclMatrix3d extension implements rotations for TCL scripts in C.
Zarutian: links to Handy Mathematics Facts for Graphics
jbr 2010-12-02: Here is something in the same style.
This following is a cut-down version of the inverse [L1 ]. I've been using it in a C version for years, but corrections are welcome.
proc inverse { transform } {
foreach {a b c d e f} $transform {break}
set pos [expr $a * $d]
set neg [expr $b * $c]
set det [expr $pos - $neg]
puts $det
if { ( $det == 0.0) || (abs( $det / ($pos - $neg)) < 10e-15) } {
# should this be ($pos + $neg) ?? [jbr] - There is something wrong with the singularity test.
error "singular matrix"
}
foreach { a b c d } [list \
[expr $d / double($det)] [expr -($b) / double($det)] \
[expr -($c) / double($det)] [expr $a / double($det)]] break
foreach { e f } [list \
[expr -( $e * $a + $f * $b )] [expr -( $e * $c + $f * $d )]] break
list $a $b $c $d $e $f
}