##+##########################################################################
#
# Bulging Squares.tcl -- Optical illusion by Misha Pavel
# by Keith Vetter, September 2006
# http://www.cut-the-knot.org/SimpleGames/CommonThing.shtml
package require Tk
catch {package require tile} ;# Brute force in tile
catch {namespace import -force ::ttk::*}
array set S {title "Bulging Squares" occlusion Squares object Square
opacity 0 delay 20 step 2 r 40 r2 80 r3 74}
set PI [expr {acos(-1)}]
proc DoDisplay {} {
wm title . $::S(title)
frame .ctrl
canvas .c -bd 2 -relief ridge
bind .c <Configure> {ReCenter %W %h %w}
labelframe .object -text "Object"
foreach what {Square Triangle Pentagon Star "Hex Star"} {
set w ".object.[string tolower $what]"
radiobutton $w -text $what -variable S(object) -value $what \
-command {Go object}
pack $w -side top -anchor w
}
labelframe .occlusion -text "Occlusion"
foreach what {Squares "5 Triangles" "6 Triangles"} {
set w ".occlusion.[string tolower $what]"
radiobutton $w -text $what -variable S(occlusion) -value $what \
-command {Go occlusion}
pack $w -side top -anchor w
}
checkbutton .opacity -text "Translucent" -variable S(opacity) -command DoOpacity
button .about -text About -command About
pack .ctrl -side right -fill y -padx 5 -pady 5
pack .c -side top -fill both -expand 1
pack .object .occlusion -in .ctrl -side top -fill x
pack .opacity -side top -in .ctrl -fill x -pady 10
pack .about -side bottom -in .ctrl -fill x -pady 10
}
proc ReCenter {W h w} { ;# Called by configure event
set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}]
$W config -scrollregion [list -$w2 -$h2 $w2 $h2]
Resize
}
proc Go {who} {
DrawObject
DrawOcclusion
.c raise occ
Resize
DoOpacity
}
proc DrawObject {} {
global S
.c delete obj
set skip 1
if {$S(object) eq "Square"} { set n 4}
if {$S(object) eq "Triangle"} { set n 3}
if {$S(object) eq "Pentagon"} { set n 5}
if {$S(object) eq "Star"} { set n 5; set skip 2}
if {$S(object) eq "Hex Star"} { set n 3}
set xy {}
set xy2 {}
for {set i 0} {$i < $n} {incr i} {
set x [expr {$S(r) * cos($i * $skip * 2 * $::PI / $n)}]
set x2 [expr {-$S(r) * cos($i * $skip * 2 * $::PI / $n)}]
set y [expr {$S(r) * sin($i * $skip * 2 * $::PI / $n)}]
set y2 [expr {-$S(r) * sin($i * $skip * 2 * $::PI / $n)}]
lappend xy $x $y
lappend xy2 $x2 $y2
}
.c create poly $xy -fill \#04B204 -width 0 -tag obj
if {$S(object) eq "Hex Star"} {
.c create poly $xy2 -fill \#04B204 -width 0 -tag obj
}
}
proc DrawOcclusion {} {
global S
.c delete occ
if {[string match {[56] Triangles} $S(occlusion)]} {
set n [lindex $S(occlusion) 0]
DrawOccludintTriangles $n
return
}
set a $S(r2)
set b [expr {$S(r2) - $S(r3)}]
set xy [list -$a -$a -$b -$b]
.c create rect $xy -fill red -width 0 -tag occ
set xy [list $a -$a $b -$b]
.c create rect $xy -fill red -width 0 -tag occ
set xy [list -$a $a -$b $b]
.c create rect $xy -fill red -width 0 -tag occ
set xy [list $a $a $b $b]
.c create rect $xy -fill red -width 0 -tag occ
}
proc DrawOccludintTriangles {n} {
global S
for {set i 0} {$i < $n} {incr i} {
set a0 [expr {$i * 2 * $::PI / $n}]
set a1 [expr {($i+1) * 2 * $::PI / $n}]
set a2 [expr {($i+.5) * 2 * $::PI / $n}]
set x0 [expr {$S(r2) * cos($a0)}]
set y0 [expr {$S(r2) * sin($a0)}]
set x1 [expr {$S(r2) * cos($a1)}]
set y1 [expr {$S(r2) * sin($a1)}]
set xy [list 0 0 $x0 $y0 $x1 $y1]
set id [.c create poly $xy -fill red -width 0 -tag occ ]
set dx [expr {10 * cos($a2)}]
set dy [expr {10 * sin($a2)}]
.c move $id $dx $dy
}
}
# From http://wiki.tcl.tk/CanvasRotation
proc _RotateItem {w tagOrId Ox Oy angle} {
set angle [expr {$angle * atan(1) * 4 / 180.0}] ;# Radians
foreach id [$w find withtag $tagOrId] { ;# Do each component separately
set xy {}
foreach {x y} [$w coords $id] {
# rotates vector (Ox,Oy)->(x,y) by angle clockwise
set x [expr {$x - $Ox}] ;# Shift to origin
set y [expr {$y - $Oy}]
set xx [expr {$x * cos($angle) - $y * sin($angle)}] ;# Rotate
set yy [expr {$x * sin($angle) + $y * cos($angle)}]
set xx [expr {$xx + $Ox}] ;# Shift back
set yy [expr {$yy + $Oy}]
lappend xy $xx $yy
}
$w coords $id $xy
}
}
proc DoRotate {} {
foreach aid [after info] { after cancel $aid }
after $::S(delay) DoRotate
_RotateItem .c obj 0 0 $::S(step)
}
proc DoOpacity {args} {
.c itemconfig occ -stipple [expr {$::S(opacity) ? "gray50" : ""}]
}
proc Resize {} {
set w [winfo width .c]
set h [winfo height .c]
foreach {x0 y0 x1 y1} [.c bbox all] break
set sx [expr {($w-40)/2.0 / $x1}]
set sy [expr {($h-40)/2.0 / $y1}]
set sc [expr {$sx > $sy ? $sy : $sx}]
.c scale all 0 0 $sc $sc
}
proc About {} {
set msg "$::S(title)\nby Keith Vetter, September 2006\n\n"
append msg "Optical illusion by Misha Pavel"
tk_messageBox -message $msg -title "About $::S(title)"
}
################################################################
DoDisplay
DoRotate
Go all
returnuniquename 2013aug18There is one of aspect of this code that is not conveyed by the image above --- namely, the (green) polygon under the upper (red) polygons is animated --- the lower polygon is rotating. So people looking for code that performs a rotation of objects on the Tk canvas may find this code of interest.Another feature of this code is shown in the following image --- this is an example of drawing 'translucent' versions of polygons. That technique of making objects on the canvas semi-transparent may be a nice trick to know about --- that is to say, it may be handy to know that this code provides an example of how to achieve that semi-transparent effect.
