Keith Vetter 2006-09-08 : an optical illusion invented by Misha Pavel.
##+########################################################################## # # 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 return
uniquename 2013aug18
There 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 --- an example of drawing 'transparent' 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 transparent effect.
Another effect that is not clear from this static image is that the rotating 6-pointed star appears to be pulsating in-and-out (contracting and expanding) --- but when you click on the 'transparent' checkbutton and the triangles become transparent, it is seen the the 6-pointed star is simply rotating and not pulsating at all.