##+##########################################################################
#
# impossible_triangle.tcl -- Draws the Impossible Triangle and Impossible Square
# see https://en.wikipedia.org/wiki/Penrose_triangle
# by Keith Vetter 2018-05-23
#

package require Tk

set Z(dimensions) 3
set Z(tsize) 30
set Z(esize) 70

set Z(title) "Impossible Triangle"
set Z(angle) 0
set Z(gradient) 1
set Z(color,0) yellow
set Z(color,1) green
set Z(color,2) cyan
set Z(color,3) orange

set S(gradient,darkPercent) 30
set S(bg) dodgerblue
set S(colors) {purple red orange magenta yellow green blue cyan white black random}

proc DoDisplay {} {
    global Z S

    frame .ctrl
    label .title -bg $S(bg) -textvariable Z(title) -font {Times 42 bold}
    canvas .c -bd 0 -highlightthickness 0 -width 500 -height 500 -bg $::S(bg)
    pack .ctrl -side right -fill y
    pack .title .c -side top -fill x
    pack config .c -fill both -expand 1

    labelframe .ctrl.shape -text "Shape"
    radiobutton .ctrl.shape.t -text "Triangle" -variable ::Z(dimensions) -value 3 \
        -command {Redim 3}
    radiobutton .ctrl.shape.s -text "Square" -variable ::Z(dimensions) -value 4 \
        -command {Redim 4}
    pack .ctrl.shape -fill x -pady 10
    pack .ctrl.shape.t .ctrl.shape.s -side top -fill both


    labelframe .ctrl.sizes -text "Sizes"
    scale .ctrl.tsize -from 1 -to 200 -variable ::Z(tsize) -orient h \
        -showvalue 0 -label "Inner: $::Z(tsize)" \
        -command {apply {{value} { .ctrl.tsize config -label "Inner: $value" ; Redraw}}}
    scale .ctrl.esize -from 1 -to 200 -variable ::Z(esize) -orient h \
        -showvalue 0 -label "Outer: $::Z(esize)" \
        -command {apply {{value} { .ctrl.esize config -label "Outer: $value" ; Redraw}}}
    pack .ctrl.tsize .ctrl.esize -side top -fill x -in .ctrl.sizes
    pack .ctrl.sizes -side top -fill x

    labelframe .ctrl.rotate -text "Rotation"
    scale .ctrl.rotate.rotate -from -180 -to 180 -command {Redraw rotate} \
        -variable ::Z(angle) -orient horizontal -showvalue 0 -relief ridge
    pack .ctrl.rotate.rotate -side top
    pack .ctrl.rotate -fill x -pady .1i

    labelframe .ctrl.colors -text "Colors"
    ColorButton .ctrl.color0 ::Z(color,0)
    ColorButton .ctrl.color1 ::Z(color,1)
    ColorButton .ctrl.color2 ::Z(color,2)
    ColorButton .ctrl.color3 ::Z(color,3)
    pack .ctrl.color0 .ctrl.color1 .ctrl.color2 .ctrl.color3 -fill x -in .ctrl.colors -padx 5 -pady 5
    pack .ctrl.colors -fill x

    labelframe .ctrl.grad -text "Shading"
    checkbutton .ctrl.grad.cb -text "Shading on" -variable ::Z(gradient) -command Redraw
    pack .ctrl.grad -fill x -pady 10
    pack .ctrl.grad.cb -side left -fill both

    bind .c <Configure> {apply {{W h w} {
        set h [expr {$h / 2.0}]
        set w [expr {$w / 2.0}]
        $W config -scrollregion [list -$w -$h $w $h]
    }} %W %h %w}
}
proc GetPoints {dims triangleSize edgeSize} {
    global V P POLY
    unset -nocomplain POLY

    set toRadians [expr {acos(-1) / 180}]
    set offset [expr {$dims == 3 ? 0 : -45}]

    # Vertices of the polygon
    for {set i 0} {$i < $dims} {incr i} {
        set angle [expr {$toRadians * ($offset + 360 * $i / $dims)}]
        set P($i) [VRescale [list [expr {cos($angle)}] [expr {sin($angle)}]] $triangleSize]
        set P($i,p) [VRescale [list [expr {cos($angle)}] [expr {sin($angle)}]] $triangleSize]
    }

    # Vectors along polygon sides
    for {set i 0} {$i < $dims} {incr i} {
        set next [expr {($i + 1) % $dims}]
        set V($i) [VRescale [VSub $P($i) $P($next)] $edgeSize]
        set V([expr {$i+$dims}]) $V($i)
    }

    # Key points for drawing the shape
    for {set i 0} {$i < $dims} {incr i} {
        set idxNext [expr {($i + 1) % $dims}]
        set idxPrev [expr {($i - 1) % $dims}]
        set P($i,a) [VAdd $P($i) $V($i)]
        set P($i,b) [VAdd $P($i,a) $V($i)]
        set P($i,c) [VSub $P($i,b) $V($idxPrev)]
        set P($i,d) [VAdd $P($i,c) $V($idxNext)]
        if {$dims == 4} {
            set P($i,d) [VAdd $P($i,d) $V($i) -2.5]
        }
    }

    # Vertices for the region to shade
    for {set i 0} {$i < $dims} {incr i} {
        set idxNext [expr {($i + 1) % $dims}]
        set idxPrev [expr {($i - 1) % $dims}]

        set br $P($i)
        set bl $P($idxPrev,a)
        set tl [VAdd $P($idxPrev,c) $V($idxPrev) -1]
        set tr $P($i,a)
        set P($i,shading) [list $br $bl $tl $tr]
    }

    for {set i 0} {$i < $dims} {incr i} {
        set POLY($i) [GetXY $dims $i,a $i+1,p $i+1,a $i,c $i-1,d $i-1,c $i,a]
    }
}
proc GetXY {dims args} {
    global P
    set xy {}
    foreach arg $args {
        set n [regexp {^(\d+[+-]\d+)(,.)$} $arg . value letter]
        if {$n} {
            set arg [expr ($value) % $dims]$letter
        }
        lappend xy {*}$P($arg)
    }
    return $xy
}
proc ColorButton {w varName} {
    set menu [tk_optionMenu $w $varName {*}$::S(colors)]
    for {set i 0} {$i <= [[$w cget -menu] index end]} {incr i} {
        [$w cget -menu] entryconfig $i -command Redraw
    }
}
proc RotateItem {w tagOrId Ox Oy angle} {
    set angle [expr {$angle * atan(1) * 4 / 180.0}] ;# Radians
    set cos [expr {cos($angle)}]
    set sin [expr {sin($angle)}]

    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 - $y * $sin}] ;# Rotate
            set yy [expr {$x * $sin + $y * $cos}]

            set xx [expr {$xx + $Ox}]           ;# Shift back
            set yy [expr {$yy + $Oy}]
            lappend xy $xx $yy
        }
        $w coords $id $xy
    }
}
proc GradientSides {} {
    # Draws the gradient shading for all the sides
    .c itemconfig side -outline {}
    for {set who 0} {$who < $::Z(dimensions)} {incr who} {
        set last [expr {($who - 1) % $::Z(dimensions)}]
        _GradientQuad $::Z(color,$last) {*}$::P($who,shading)
    }
}
proc _GradientQuad {clr P0 P1 P2 P3} {
    # Draw gradient along quadrilateral with sides P0->P1  AND P3->P2
    # with dark color at P0,P1 gradient to $clr at P3,P2

    set V0 [VSub $P1 $P0]
    set V1 [VSub $P2 $P3]
    set len0 [VLength $V0]
    set len1 [VLength $V1]
    set steps [expr {min($len0, $len1)}]
    set gradientRange [expr {100 - $::S(gradient,darkPercent)}]

    set lastP $P0
    set lastQ $P3

    set stepSize 1
    for {set idx $stepSize} {$idx <= $steps} {incr idx $stepSize} {
        set percent [expr {$idx / double($steps)}]
        set gperc [expr {int($::S(gradient,darkPercent) + $gradientRange * $percent)}]
        set gcolor [::tk::Darken $clr $gperc]

        set p [VAdd $P0 $V0 $percent]
        set q [VAdd $P3 $V1 $percent]
        set xy [concat $lastP $p $q $lastQ]
        .c create poly $xy -fill $gcolor -outline $gcolor -tag grad
        set lastP $p
        set lastQ $q
    }
}
proc NewColor {} {
    global Z

    .c delete grad
    for {set i 0} {$i < $Z(dimensions)} {incr i} {
        if {! [info exists ::Z(color,$i)]} {
            set Z(color,$i) [lrandom $::S(colors)]
        }
        if {$Z(color,$i) eq "random"} {
            set Z(color,$i) [format "#%06x" [expr {int(rand() * 0xFFFFFF)}]]
        }
        .c itemconfig p$i -fill $Z(color,$i)
    }
    if {$Z(gradient)} {
        GradientSides
    }
}
proc VAdd {v1 v2 {scaling 1}} {
    foreach {x1 y1} $v1 {x2 y2} $v2 break
    return [VClean [list [expr {$x1 + $scaling*$x2}] [expr {$y1 + $scaling*$y2}]]]
}
proc VSub {v1 v2} { return [VAdd $v1 $v2 -1] }
proc VScale {v scaling} {
    lassign $v x y
    return [VClean [list [expr {$x * $scaling}] [expr {$y * $scaling}]]]
}
proc VRescale {v scaling} {
    lassign $v x y
    set len [expr {hypot($x,$y)}]
    return [VClean [list [expr {$x * $scaling / $len}] [expr {$y * $scaling / $len}]]]
}
proc VClean {v} {
    lassign $v x y
    if {abs($x - round($x)) < .001} { set x [expr {round($x)}] }
    if {abs($y - round($y)) < .001} { set y [expr {round($y)}] }
    return [list $x $y]
}
proc VLength {v} {
    lassign $v x y
    return [expr {hypot($x,$y)}]
}

proc lrandom {l} {
    return [lindex $l [expr {int(rand() * [llength $l])}]]
}
proc Redim {dims} {
    global Z

    set Z(title) [expr {$dims == 3 ? "Impossible Triangle" : "Impossible Square"}]
    wm title . $Z(title)
    set Z(dimensions) $dims
    set Z(tsize) 30
    set Z(esize) 70
    set Z(angle) 0

    if {$Z(dimensions) == 4} {
        set Z(tsize) 110
        set Z(esize) 25
        set Z(angle) -45
    }

    Redraw
}
proc Redraw {args} {
    DrawIt $::Z(dimensions) $::Z(tsize) $::Z(esize)
    if {$::Z(angle) != 0} {
        RotateItem .c all 0 0 $::Z(angle)
    }
}
proc DrawIt {dims triangleSize edgeSize} {
    global POLY Z

    GetPoints $Z(dimensions) $triangleSize $edgeSize
    .c delete all
    for {set i 0} {$i < $dims} {incr i} {
        .c create poly $POLY($i) -tag [list side p$i] -outline black
    }
    NewColor
}

################################################################
DoDisplay
Redim $Z(dimensions)
return