[Keith Vetter] 2006-09-08 : an optical illusion invented by Misha Pavel. [WikiDbImage BulgingSquare.jpg] ---- ##+########################################################################## # # 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 {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. [vetter_BulgingSquareIllusion_wiki16687_transluscentTriangles_screenshot_580x352.jpg] 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) --- when the star is rotating under the SOLID triangles. 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. [[ [Category Graphics] | [Category optical illusion] ]]