##+##########################################################################
#
# psquare.tcl -- Illusion where rotating scales seemingly pulse
# by Keith Vetter, Oct 3, 2006
#
# http://mathworld.wolfram.com/RotatingSquareIllusion.html
 
package require Tk
package require tile
 
 array set S {title "Pulsing Squares" n 6 animate 1 delay 10 step 3 gap 10 dir 1}
 set PI [expr {acos(-1)}]
 
 proc DoDisplay {} {
     wm title . $::S(title)
 
     pack [frame .ctrl] -side bottom -fill x
     pack [canvas .c -bd 2 -relief ridge -bg yellow] -side top -fill both -exp 1
     bind .c <Configure> {ReCenter %W %h %w}
 
     ::ttk::button .anim -text "Stop"    -command StartStop
     ::ttk::button .rev  -text "Reverse" -command {set S(dir) [expr {-$S(dir)}]}
     ::ttk::labelframe .lp -text "Speed"
     ::ttk::scale .sp -from 1 -to 10 -variable ::S(step)
     image create photo ::img::question -width 6 -data {
         R0lGODlhBQAJALMAAAQCBOTe5BcAiAAAfIgACOkAABIApwAAAPgB0HAA+hcAFQAA
         AACgAHHqABcSAAAAACH5BAAAAAAALAAAAAAFAAkAAwQNMIApQaU0VJ2l/l+XRQA7}
     ::ttk::button .? -image ::img::question -command About
     grid .lp .anim -in .ctrl -pady 10
     grid ^ .rev -in .ctrl
     grid columnconfigure .ctrl {0 1} -weight 1
     grid rowconfigure .ctrl 100 -minsize 10
     grid config .lp -sticky ns
     pack .sp -in .lp -fill both -expand 1
     place .? -in .ctrl -relx 1 -rely 1 -anchor se
 
     DrawSquares
 }
 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]
 }
 proc DrawSquares {} {
     .c delete s
     set x0 [expr {$::S(gap) / 2}]
     for {set i 0} {$i < $::S(n)} {incr i} {
         roundRect .c -$x0 -$x0 $x0 $x0 $x0 -tag s -width $::S(gap) \
             -fill {} -outline black
         incr x0 $::S(gap)
         incr x0 $::S(gap)
     }
 }
 proc About {} {
     set msg "$::S(title)\nby Keith Vetter, October 2006\n"
     tk_messageBox -message $msg -title "About $::S(title)"
 }
 proc roundRect { w x0 y0 x3 y3 radius args } {
     # From https://wiki.tcl-lang.org/DrawingRoundedRectangles
     set r [winfo pixels $w $radius]
     set d [expr {2 * $r}]
 
     # Radius of the curve must be less than 3/8 size of box
     set maxr 0.75
     if {$d > $maxr * ($x3 - $x0)} {
         set d [expr {$maxr * ($x3 - $x0)}]
     }
     if {$d > $maxr * ($y3 - $y0)} {
         set d [expr {$maxr * ($y3 - $y0)}]
     }
 
     set x1 [expr {$x0 + $d}]
     set x2 [expr {$x3 - $d}]
     set y1 [expr {$y0 + $d}]
     set y2 [expr {$y3 - $d}]
 
     set cmd [list $w create polygon]
     lappend cmd $x0 $y0 $x1 $y0 $x2 $y0 $x3 $y0
     lappend cmd $x3 $y1 $x3 $y2 $x3 $y3 $x2 $y3 $x1 $y3
     lappend cmd $x0 $y3 $x0 $y2 $x0 $y1
     lappend cmd -smooth 1
     return [eval $cmd $args]
 }
 proc _RotateItem {w tagOrId Ox Oy angle} {
     # From https://wiki.tcl-lang.org/CanvasRotation
     set angle [expr {$angle * $::PI / 180.0}]   ;# Radians
     foreach id [$w find withtag $tagOrId] {     ;# Do each component separately
         set newXY {}
         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 newXY $xx $yy
         }
         $w coords $id $newXY
     }
 }
 proc StartStop {} {
     set ::S(animate) [expr {! $::S(animate)}]
     .anim config -text [expr {$::S(animate) ? "Stop" : "Start"}]
     Animate
 }
 proc Animate {} {
     foreach aid [after info] { after cancel $aid }
     if {! $::S(animate)} return
     _RotateItem .c s 0 0 [expr {$::S(dir) * $::S(step)}]
     after $::S(delay) Animate
 }
 ################################################################
 DoDisplay
 Animate
 return