##+##########################################################################
 #
 # 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 https://wiki.tcl-lang.org/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