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
