Updated 2018-04-07 22:01:44 by LarrySmith

Keith Vetter 2017-04-07 : Here's an updated version of my Celtic Braid page. That one demonstrated how to draw an interlocking figure which I later learned is called Solomon's Knot.

This page extends that one in allowing larger sized knots with more interlocking loops. It also draws a related knot called an Endless Knot.

This isn't PC - it should be called SoloPERSON's Knot!

```##+##########################################################################
#
# 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
```