##+##########################################################################
#
# Solomon's Knot.tcl -- Draws either Solomon Knot and Endless Knot with variable sizes
# by Keith Vetter 2018-03-27
#
#   https://en.wikipedia.org/wiki/Solomon%27s_knot
#   https://en.wikipedia.org/wiki/Endless_knot
#
# Terminology
#   The figure is described by a path and is drawn as a number of cages
#     path: position_segment segment [segment]*
#     segment: dir len [dir len]*
#     cage: connected set of cells
#     cell: single 1x1 box, drawn with sides of length Z(unit)

package require Tk

set Z(unit) 50
set Z(bg,color) yellow
set Z(edge,size) 5
set Z(edge,color) black
set Z(row,size) 2
set Z(col,size) 2
set Z(row,color,0) navy
set Z(row,color,1) turquoise
set Z(col,color,0) seagreen1
set Z(col,color,1) green3
set Z(type) "Solomon's Knot"
set Z(angle) 45

set S(title) "Solomon's and Endless Knot"
set S(colors) {purple red magenta yellow green blue cyan white black random}
set S(margin) 10

proc SolomonKnot {rows cols angle} {
    set unitRows [expr {3 + 4*$rows}]
    set unitCols [expr {3 + 4*$cols}]
    ComputeSize $unitRows $unitCols

    set rowColors [Gradient $::Z(row,color,0) $::Z(row,color,1) $rows]
    set colColors [Gradient $::Z(col,color,0) $::Z(col,color,1) $cols]

    .c delete all
    set paths [MakeSKPaths $rows $cols]
    for {set i 0} {$i < $rows} {incr i} {
        lassign [lrotate $rowColors] rowColor rowColors
        DrawPath [dict get $paths row,$i] knot $rowColor
    }
    for {set i 0} {$i < $cols} {incr i} {
        lassign [lrotate $colColors] colColor colColors
        DrawPath [dict get $paths col,$i] knot $colColor
    }
    RotateKnot $angle
}
proc EndlessKnot {rows cols angle} {
    set rows [expr {max(3, $rows)}]
    set cols [expr {max(3, $cols)}]

    set unitRows [expr {-3 + 4*$rows}]
    set unitCols [expr {-3 + 4*$cols}]
    ComputeSize $unitRows $unitCols

    set path [MakeEKPaths $rows $cols]
    set steps [expr {[llength $path] - 1}]
    set colors [Gradient3 $::Z(row,color,0) $::Z(row,color,1) $::Z(row,color,0) $steps]
    lappend colors {*}[lreverse $colors]

    .c delete all
    DrawPath $path knot $colors
    RotateKnot $angle
}

proc DoDisplay {} {
    image create bitmap ::img::star -data {
        #define plus_width  11
        #define plus_height 9
        static char plus_bits[] = {
            0x00,0x00, 0x24,0x01, 0xa8,0x00, 0x70,0x00, 0xfc,0x01,
            0x70,0x00, 0xa8,0x00, 0x24,0x01, 0x00,0x00 }}

    wm title . $::S(title)
    ::ttk::frame .cp -relief ridge -borderwidth 2
    label .title -textvariable ::Z(type) -font {Helvetica 36 bold}
    canvas .c -width 500 -height 500 -bd 0 -highlightthickness 0 -bg $::Z(bg,color)
    . config -bg [.c cget -bg]
    .title config -bg [.c cget -bg]

    pack .cp -side right -fill y
    pack .title -side top -fill y
    # NB. we create a margin around the canvas via pack's -padx and -pady
    pack .c -side bottom -fill both -expand 1 -padx $::S(margin) -pady $::S(margin)

    ::ttk::labelframe .cp.type -text "Knot Type"
    ::ttk::radiobutton .cp.type.solomon -text "Solomon's Knot" \
        -command Redraw -variable ::Z(type) -value "Solomon's Knot"
    ::ttk::radiobutton .cp.type.endless -text "Endless Knot" \
        -command Redraw -variable ::Z(type) -value "Endless Knot"
    grid .cp.type -sticky ew
    grid .cp.type.solomon -sticky w
    grid .cp.type.endless -sticky w -pady .1i

    ::ttk::labelframe .cp.row -text "Row Configuration"
    ::ttk::label .cp.row.slbl -text "Size:" -anchor e
    ::ttk::spinbox .cp.row.sbox -from 1 -to 10 -command Redraw -textvariable ::Z(row,size) \
        -width 4 -justify center -exportselection 0
    set row0 [ColorWidget "First Color:" .cp.row.col0 row,color,0]
    set row1 [ColorWidget "Second Color:" .cp.row.col1 row,color,1]

    grid .cp.row.slbl .cp.row.sbox -sticky ew
    grid config .cp.row.sbox -sticky w
    grid {*}$row0
    grid configure [lindex $row0 0] -sticky e
    grid {*}$row1
    grid configure [lindex $row1 0] -sticky e
    grid .cp.row -sticky ew -pady .1i

    ::ttk::labelframe .cp.col -text "Column Configuration"
    ::ttk::label .cp.col.slbl -text "Size:" -anchor e
    ::ttk::spinbox .cp.col.sbox -from 1 -to 10 -command Redraw -textvariable ::Z(col,size) \
        -width 4 -justify center -exportselection 0
    set row0 [ColorWidget "First Color:" .cp.col.col0 col,color,0]
    set row1 [ColorWidget "Second Color:" .cp.col.col1 col,color,1]

    grid .cp.col.slbl .cp.col.sbox -sticky ew
    grid config .cp.col.sbox -sticky w
    grid {*}$row0
    grid configure [lindex $row0 0] -sticky e
    grid {*}$row1
    grid configure [lindex $row1 0] -sticky e
    grid .cp.col -sticky ew -pady .1i


    ::ttk::labelframe .cp.bg -text "Background Configuration"
    set row [ColorWidget "Color:" .cp.bg.col bg,color]
    grid {*}$row
    grid .cp.bg -sticky ew -pady .1i

    ::ttk::labelframe .cp.edge -text "Edge Configuration"
    ::ttk::label .cp.edge.slbl -text "Size:" -anchor e
    ::ttk::spinbox .cp.edge.sbox -from 0 -to 20 -command {Redraw edge} \
        -textvariable ::Z(edge,size) -width 4 -justify center -exportselection 0
    set row [ColorWidget "Color:" .cp.edge.col edge,color]

    grid .cp.edge.slbl .cp.edge.sbox -sticky ew
    grid config .cp.edge.sbox -sticky w
    grid {*}$row
    grid .cp.edge -sticky ew -pady .1i

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

    ::ttk::button .cp.about -text About -command About
    grid rowconfigure .cp 100 -weight 1
    grid .cp.about -row 101 -pady .1i

    bind .c <Configure> {Configure %W %h %w}
}
proc ColorWidget {label f var} {
    ::ttk::label ${f}lbl -text $label -anchor e
    ::ttk::combobox ${f}cb -values $::S(colors) -state readonly \
        -textvariable ::Z($var) -justify center -width 10 -exportselection 0
    ::ttk::button ${f}btn -image ::img::star -command [list PickColor $var]
    UniqueTrace ::Z($var) NewColor
    return [list ${f}lbl ${f}cb ${f}btn]
}
proc Configure {W h w} {
    # Handle configure events, making 0,0 the center of the canvas
    set h [expr {$h / 2.0}]
    set w [expr {$w / 2.0}]
    $W config -scrollregion [list -$w -$h $w $h]
    Redraw
}
proc UniqueTrace {varName {function ""}} {
    # Adds a trace to a variable, removing any existing ones
    foreach tr [trace info variable $varName] {
        trace remove variable $varName {*}$tr
    }
    if {$function ne ""} {
        trace variable $varName w $function
    }
}
proc NewColor {var1 var2 op} {
    # Handle trace on combobox's variable (since it lacks a command option)
    if {$::Z($var2) eq "random"} {
        set ::Z($var2) [format "#%06x" [expr {int(rand() * 0xFFFFFF)}]]
    }
    if {$var2 eq "bg,color"} {
        .c config -bg $::Z(bg,color)
        . config -bg [.c cget -bg]
        .title config -bg [.c cget -bg]
    } elseif {$var2 eq "edge,color"} {
        if {$::Z(edge,size) > 0} {
            .c itemconfig knot -outline $::Z(edge,color)
        }
    } else {
        Redraw
    }
}
proc PickColor {var} {
    set color [tk_chooseColor -initialcolor $::Z($var)]
    if {$color eq ""} return
    set ::Z($var) $color
    # Redraw done by trace
}

proc ComputeSize {unitRows unitCols} {
    # Computes Z(unit) so image fits for all rotations
    set diag [expr {hypot($unitRows, $unitCols)}]
    set smallSide [expr {min([winfo height .c], [winfo width .c])}]
    set pixels [expr {$smallSide / $diag}]
    set ::Z(unit) [expr {int($pixels)}]
}

proc Redraw {args} {
    if {[lindex $args 0] eq "edge"} {
        set outline [expr {$::Z(edge,size) > 0 ? $::Z(edge,color) : ""}]
        .c itemconfig knot -width $::Z(edge,size) -outline $outline
        return
    }

    if {$::Z(type) eq "Solomon's Knot"} {
        SolomonKnot $::Z(row,size) $::Z(col,size) $::Z(angle)
    } else {
        set ::Z(row,size) [expr {max(3, $::Z(row,size))}]
        set ::Z(col,size) [expr {max(3, $::Z(col,size))}]

        EndlessKnot $::Z(row,size) $::Z(col,size) $::Z(angle)
    }
    .cp.rotate.rotate config -label "Angle: $::Z(angle)"
}
proc DrawPath {path tag colors} {
    # path is a list of segments; a segment is a list of dir len pairs
    # The first segment in path is to position from 0,0 and is not drawn

    set lastCell {0 0}
    set segments [lassign $path position]
    lassign [ProcessSegmentToPolygon $lastCell $position] . lastCell

    set outline [expr {$::Z(edge,size) > 0 ? $::Z(edge,color) : ""}]
    foreach segment $segments {
        lassign [ProcessSegmentToPolygon $lastCell $segment] xy lastCell
        lassign [lrotate $colors] color colors

        .c create poly $xy -fill $color -tag $tag -outline $outline -width $::Z(edge,size)
        # Move past the "underpass" cell
        set lastCell [MoveOneCell $lastCell [lindex $segment end-1]]
    }
}
proc ProcessSegmentToPolygon {lastCell segment} {
    # Converts segment into the XY coordinates of a polygon starting at lastCell
    # Builds up coordinates for the opposite sides of the polygon, then joins them
    # when done.
    set corners [CellToCorners {*}$lastCell]
    set lastDir [lindex $segment 0]
    set nextDir $lastDir
    set side1 {}
    set side2 {}
    lassign [ExtendCage $lastDir $nextDir $corners $side1 $side2] side1 side2

    foreach {nextDir len} $segment {
        set cage [SegmentToCage $lastCell $nextDir $len]
        set corners [CageCorners $cage]
        lassign [ExtendCage $lastDir $nextDir $corners $side1 $side2] side1 side2

        set lastDir $nextDir
        set lastCell [lindex $cage end]
    }
    set xy [concat {*}$side1 {*}[lreverse $side2] {*}[lindex $side1 0]]
    return [list $xy $lastCell]
}
array set EXTEND {
    n,n {{nw} {ne}} n,e {{ne} {ch sw se}} n,w {{ch se sw} {nw}}
    e,e {{ne} {se}} e,n {{ch sw nw} {ne}} e,s {{se} {ch nw sw}}
    s,s {{se} {sw}} s,e {{ch nw ne} {se}} s,w {{sw} {ch ne nw}}
    w,w {{sw} {nw}} w,n {{nw} {ch se ne}} w,s {{ch ne se} {sw}}
}
proc ExtendCage {lastDir nextDir corners side1 side2} {
    set sides(side1) $side1
    set sides(side2) $side2
    foreach steps $::EXTEND($lastDir,$nextDir) side {side1 side2} {
        foreach step $steps {
            if {$step eq "ch"} {
                set sides($side) [lrange $sides($side) 0 end-1]
            } else {
                lappend sides($side) [dict get $corners $step]
            }
        }
    }
    return [list $sides(side1) $sides(side2)]
}

proc CellToCorners {row col} {
    # Returns a dictionary of the four corners of a cell
    set x0 [expr {$col * $::Z(unit) - $::Z(unit)/2}]
    set y0 [expr {$row * $::Z(unit) - $::Z(unit)/2}]
    set x1 [expr {$x0 + $::Z(unit)}]
    set y1 [expr {$y0 + $::Z(unit)}]
    set d [dict create \
               nw [list $x0 $y0] \
               ne [list $x1 $y0] \
               sw [list $x0 $y1] \
               se [list $x1 $y1]]
    return $d
}
proc SegmentToCage {lastCell dir len} {
    lassign $lastCell row col
    if {$dir eq "n"} { set box [list -1  0] }
    if {$dir eq "s"} { set box [list +1  0] }
    if {$dir eq "e"} { set box [list  0 +1] }
    if {$dir eq "w"} { set box [list  0 -1] }
    set row0 [expr {$row + [lindex $box 0]}]
    set col0 [expr {$col + [lindex $box 1]}]

    set result {}
    for {set i 0} {$i < $len} {incr i} {
        incr row [lindex $box 0]
        incr col [lindex $box 1]
        lappend result [list $row $col]
    }
    return $result
}
proc MoveOneCell {lastCell dir} {
    return [lindex [SegmentToCage $lastCell $dir 1] 0]
}
proc CageCorners {cage} {
    lassign [Cage2XY $cage] x0 y0 x1 y1
    set d [dict create \
               nw [list $x0 $y0] \
               ne [list $x1 $y0] \
               sw [list $x0 $y1] \
               se [list $x1 $y1]]
    return $d
}
proc Cage2XY {cage} {
    lassign [Cell2XY [lindex $cage 0]] x0 y0 x1 y1
    foreach cell [lrange $cage 1 end] {
        lassign [Cell2XY $cell] x_0 y_0 x_1 y_1
        set x0 [expr {min($x0, $x_0)}]
        set x1 [expr {max($x1, $x_1)}]
        set y0 [expr {min($y0, $y_0)}]
        set y1 [expr {max($y1, $y_1)}]
    }
    return [list $x0 $y0 $x1 $y1]
}
proc Cell2XY {cell} {
    set corners [CellToCorners {*}$cell]
    return [concat [dict get $corners nw] [dict get $corners se]]
}
proc MakeSKPaths {rows cols} {
    # Create a dictionary of paths for the Solomon's Knot
    global paths
    unset -nocomplain paths
    set rows1 [expr {$rows - 1}]
    set cols1 [expr {$cols - 1}]

    set midRows [expr {(3 + 4*$rows)/2}]
    set midCols [expr {(3 + 4*$cols)/2}]
    set toNWcol [list n $midRows w $midCols]
    set toNWrow [list w $midCols n $midRows]

    set topCap {n 2 e 2 s 3}
    set bottomCap {s 2 w 2 n 3}
    set leftCap {w 2 n 2 e 3}
    set rightCap {e 2 s 2 w 3}
    set down [lrepeat $rows1 {s 3}]
    set up [lrepeat $rows1 {n 3}]
    set right [lrepeat $cols1 {e 3}]
    set left [lrepeat $cols1 {w 3}]

    for {set i 0} {$i < $cols} {incr i} {
        # Column weave
        set offset [expr {2 + $i * 4}]
        set position [list {*}$toNWcol s 2 e $offset]
        set path [list $position $topCap {*}$down $bottomCap {*}$up]
        lappend paths col,$i $path
    }
    for {set i 0} {$i < $rows} {incr i} {
        # Row weave
        set offset [expr {4 + $i * 4}]
        set position [list {*}$toNWrow e 2 s $offset]
        set path [list $position $leftCap {*}$right $rightCap {*}$left]
        lappend paths row,$i $path
    }
    return $paths
}
proc MakeEKPaths {rows cols} {
    # Create the path for the Endless Knot
    global path
    set midRows [expr {(-3 + 4*$rows)/2}]
    set midCols [expr {(-3 + 4*$cols)/2}]
    set toNW [list w $midCols n $midRows]

    set position [list {*}$toNW e 2 s 2]
    set topLeft {n 2 w 2 s 2 e 3}
    set hAdjust [lrepeat [expr {$cols-3}] {e 3}]
    set horizontal [list {*}$hAdjust {e 4 s 2 w 1} \
                        {*}[lrepeat [expr {$cols-2}] {w 3}] \
                        {w 2 s 2 e 3}]
    set bottomRight {e 4 s 2 w 2 n 1}
    set vAdjust [lrepeat [expr {$rows-3}] {s 3}]
    set vertical [list {*}[lrepeat [expr {$rows-2}] {n 3}] \
                      {n 2 w 2 s 3} \
                      {*}$vAdjust \
                      {s 4 w 2 n 1}]

    set path {}
    lappend path $position
    lappend path $topLeft
    for {set row 2} {$row < $rows} {incr row} {
        lappend path {*}$horizontal
    }
    lappend path {*}$hAdjust
    lappend path $bottomRight

    for {set col 2} {$col < $cols} {incr col} {
        lappend path {*}$vertical
    }
    lappend path {*}[lrepeat [expr {$rows-2}] {n 3}]
    return $path
}
proc Gradient {fromColor toColor steps} {
    # Creates gradient fromColor -> toColor
    lassign [winfo rgb . $fromColor] r1 g1 b1
    lassign [winfo rgb . $toColor] r2 g2 b2

    set steps [expr {$steps <= 1 ? 1 : double($steps - 1)}]
    set gradient {}
    for {set step 0} {$step <= $steps} {incr step} {
        set r [expr {int(($r2 - $r1) * $step / $steps + $r1) * 255 / 65535}]
        set g [expr {int(($g2 - $g1) * $step / $steps + $g1) * 255 / 65535}]
        set b [expr {int(($b2 - $b1) * $step / $steps + $b1) * 255 / 65535}]
        lappend gradient [format "#%.2x%.2x%.2x" $r $g $b]
    }

    return $gradient
}
proc Gradient3 {color0 color1 color2 steps} {
    # Creates gradient from color0 -> color1 -> color2
    set first [expr {($steps + 1) / 2}]
    set second [expr {$steps - $first + 2}]
    set gradient1 [Gradient $color0 $color1 $first]
    set gradient2 [Gradient $color1 $color2 $second]
    set gradient [concat $gradient1 [lrange $gradient2 1 end-1]]
    return $gradient
}
proc lrotate {l} {
    set rest [lassign $l first]
    return [list $first [concat $rest $first]]
}
proc About {} {
    set msg "Solomon's and Endless Knot\nby Keith Vetter\nApril, 2018\n\n"
    append msg "The Solomon's Knot is also known as sigillum Salomis, Foundation Knot, Imbolo "
    append msg "or Nodo di Salomone. "
    append msg "It has been found in ancient Roman mosaics, on central Asian prayer rugs, "
    append msg "and on textiles of the Kuba people of Congo.\n\n"

    append msg "The Endless Knot or eternal knot is a symbolic knot and one of the Eight "
    append msg "Auspicious Symbols. It is an important cultural marker in places influenzed by "
    append msg "Tibetan Buddhism, such as Tibet, Mongolia, Tuva, Kalmykia. Technically it is a "
    append msg "7\u2084 knot."

    tk_messageBox -message $msg
}

proc RotateKnot {angle} {
    if {($angle % 360) != 0} {
        RotateItem .c knot 0 0 $angle
    }
}
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
    }
}


DoDisplay
update
Redraw
return