Celtic Knot
Keith Vetter 2013-05-15 : Celtic Knots are an ornamental design of interlacing lines[L1 ].
I was inspired by Celtic Knot Thingy but I wanted an interactive version that displayed the knot as you designed it, and that did not rely on postscript for its display. That web page links to a good description on how to create the knots, which ultimately derives from the paper Celtic Knotwork: Mathematical Art by Peter Cromwell [L2 ].
One cool feature unique to this program is how the lines are drawn. The standard method is to do a tiling of five basic line segment images (with 21 more images when you count rotations and reflections).
This program, instead, draws each line as a one continuous line, with coordinates of the corners of the cells it traverses. The secret is to turn on TK's parabolic splines. This makes the line bend just right to get the effect we want. As a bonus, if you set -splinesteps to 1 or 2 you get a nice square or jagged look.
There are two drawbacks to my line drawing methods. First is that lines that exit out of the grid are not clipped nicely--they project off the edge. Second, you don't get the correct interlacing. I had to come up with a kludge to achieve correct interlacing (see proc FakeCrossing for details).
Jeff Smith 2020-08-26 : Below is an online demo using CloudTk. This demo runs "Celtic Knot" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + Celtic-Knot.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
##+##########################################################################
#
# CelticKnot -- My version of Celtic Knot Thingy
# (see http://isotropic.org/celticknot/)
# by Keith Vetter 2013-05-10
#
package require Tk
set S(title) "Celtic Knot"
set S(w) 12
set S(h) 10
set S(boxSize) 100
set S(margin) 30
set S(center,left) 0
set S(center,top) 0
set S(lineWidth,off) 2
set S(lineWidth,on) 6
set S(color,bg) gray95
set S(color,even) red
set S(color,odd) green
set S(color,edge) black
set S(color,salt) .5
set S(cursor) iron_cross
set B(breaks) {}
set B(hiddenCells) {}
set B(braidWidth,perc) 40
set B(solid) 0
set B(monochrome) 0
set B(show,marker) 1
set B(show,break) 1
set B(show,line) 1
set B(show,braid) 1
set B(show,hidden) 1
set B(corners) 12
set B(sym,hor) 1
set B(sym,ver) 1
proc DoDisplay {} {
global S
wm title . $S(title)
set cw [expr {2*$S(margin) + $S(w)*$S(boxSize)}]
set cw [expr {max(500,$cw)}]
set ch [expr {2*$S(margin) + $S(h)*$S(boxSize)}]
canvas .c -width $cw -height $ch -bd 0 -highlightthickness 0 \
-bg $S(color,bg)
bind .c <Configure> {ResizeCanvas %w %h}
frame .ctrl -bd 2 -relief ridge
frame .ctrl.buttons
::ttk::button .ctrl.buttons.reset -text Reset -command Reset
::ttk::button .ctrl.buttons.resize -text Resize -command NewSize
::ttk::button .ctrl.buttons.screen -text "Screen Shot" -command ScreenShot
::ttk::button .ctrl.buttons.about -text "About" -command About
::ttk::labelframe .ctrl.hide -text Show
set who {line Cells break Breaks braid Braid}
foreach {var lbl} $who {
set W .ctrl.hide.$var
::ttk::checkbutton $W -text $lbl -variable ::B(show,$var) -command Hide
pack $W -side top -fill x -padx .1i
}
::ttk::labelframe .ctrl.corners -text Corners
::ttk::radiobutton .ctrl.corners.round -text Round -variable ::B(corners) \
-value 12 -command Hide
::ttk::radiobutton .ctrl.corners.jagged -text Jagged \
-variable ::B(corners) -value 2 -command Hide
::ttk::radiobutton .ctrl.corners.square -text Square \
-variable ::B(corners) -value 1 -command Hide
pack .ctrl.corners.round .ctrl.corners.jagged .ctrl.corners.square \
-side top -fill x -padx .1i
::ttk::labelframe .ctrl.colors -text Colors
set who {solid "Solid Colors" monochrome Monochrome}
foreach {var lbl} $who {
set W .ctrl.colors.$var
::ttk::checkbutton $W -text $lbl -variable ::B($var) -command DrawBraid
pack $W -side top -fill x -padx .1i
}
::ttk::button .ctrl.colors.new -text "New Colors" -command NewColorSalt
pack .ctrl.colors.new -side top -fill x -padx .1i
::ttk::labelframe .ctrl.symmetry -text Symmetry
set who {sym,hor "Left-Right" sym,ver "Top-Bottom"}
foreach {var lbl} $who {
set W .ctrl.symmetry.$var
::ttk::checkbutton $W -text $lbl -variable ::B($var)
pack $W -side top -fill x -padx .1i
}
::ttk::labelframe .ctrl.fat -text "Line Width"
scale .ctrl.fat.s -from 10 -to 100 -variable B(braidWidth,perc) \
-orient h -length 80 -command {apply {{val} {DrawBraid}}}
pack .ctrl.fat.s -side top -fill x -pady .1i -padx .05i
pack .ctrl.hide -side left -fill y
pack .ctrl.corners -side left -fill y
pack .ctrl.colors -side left -fill y
pack .ctrl.symmetry -side left -fill y
pack .ctrl.fat -side left -fill y
pack .ctrl.buttons -side top -expand 1
grid forget .ctrl.buttons.resize .ctrl.buttons.screen \
.ctrl.buttons.reset .ctrl.buttons.about
grid .ctrl.buttons.reset .ctrl.buttons.screen -padx .1i -pady .05i
grid .ctrl.buttons.resize .ctrl.buttons.about -padx .1i -pady .05i
pack .ctrl -side bottom -fill x
pack .c -side top -fill both -expand 1
SetWallBreaks
# canvas will get drawn on <Configure> event
}
##+##########################################################################
#
# DoCanvas -- Draws all the knoxel stuff on a canvas
#
proc DoCanvas {} {
global S
set S(dotSize) [expr {max($S(boxSize) / 6, 10)}]
.c delete all
.c create rect 0 0 999999 999999 -fill $S(color,bg) -width 0 -tag bg
for {set row 0} {$row < $S(h)} {incr row} {
for {set col 0} {$col < $S(w)} {incr col} {
set xy [CellToXY $row $col]
set tag hidden,$row,$col
.c create rect $xy -tag [list $tag hidden] -fill $S(color,bg) \
-stipple gray75 -width 0
.c bind $tag <1> [list HideCell $tag]
}
}
for {set row 0} {$row <= $S(h)} {incr row} {
for {set col [expr {$row % 2}]} {$col <= $S(w)} {incr col 2} {
DrawKnoxel $row $col
}
}
ShowAllBreaks
ShowAllHiddenCells
}
##+##########################################################################
#
# HideKnoxel -- Hide or unhide the 4 cells around a marker
#
proc HideKnoxel {row1 col1} {
if {$row1 == 0 || $row1 == $::S(h) || $col1 == 0 || $col1 == $::S(w)} return
set row0 [expr {$row1-1}]
set col0 [expr {$col1-1}]
set row2 [expr {$row1+1}]
set col2 [expr {$col1+1}]
set cells [list $row0 $col0 $row0 $col1 $row1 $col0 $row1 $col1]
set alreadyHidden 0
foreach {r c} $cells {
set tag hidden,$r,$c
set n [lsearch $::B(hiddenCells) $tag]
incr alreadyHidden [expr {$n == -1 ? 0 : 1}]
}
if {$alreadyHidden == 4} {
foreach {r c} $cells {
set tag hidden,$r,$c
set n [lsearch $::B(hiddenCells) $tag]
set ::B(hiddenCells) [lreplace $::B(hiddenCells) $n $n]
}
if {$row0 > 0} {
AddRemoveBreak off $row0 $col0 $row0 $col2
ShowBreak $row0 $col0 $row0 $col2
}
if {$col0 > 0} {
AddRemoveBreak off $row0 $col0 $row2 $col0
ShowBreak $row0 $col0 $row2 $col0
}
if {$row2 < $::S(h)} {
AddRemoveBreak off $row2 $col0 $row2 $col2
ShowBreak $row2 $col0 $row2 $col2
}
if {$col2 < $::S(w)} {
AddRemoveBreak off $row0 $col2 $row2 $col2
ShowBreak $row0 $col2 $row2 $col2
}
} else {
foreach {r c} $cells {
set tag hidden,$r,$c
set n [lsearch $::B(hiddenCells) $tag]
if {$n == -1} {
lappend ::B(hiddenCells) $tag
}
}
AddRemoveBreak on $row0 $col0 $row0 $col2
AddRemoveBreak on $row0 $col0 $row2 $col0
AddRemoveBreak on $row2 $col0 $row2 $col2
AddRemoveBreak on $row0 $col2 $row2 $col2
}
ShowAllBreaks
ShowAllHiddenCells
DrawBraid
}
##+##########################################################################
#
# HideCell -- Called when user clicks to toggle a cell's visibility
#
proc HideCell {tag} {
global B S
set n [lsearch $B(hiddenCells) $tag]
if {$n > -1} {
set B(hiddenCells) [lreplace $B(hiddenCells) $n $n]
.c itemconfig $tag -fill $S(color,bg)
} else {
lappend B(hiddenCells) $tag
.c itemconfig $tag -fill black
}
DrawBraid
}
##+##########################################################################
#
# ResizeCanvas -- Resize knoxel to best fit window, and computes centering info
#
proc ResizeCanvas {w h} {
global S
set dx [expr {($w - 2*$S(margin)) / $S(w)}]
set dy [expr {($h - 2*$S(margin)) / $S(h)}]
set S(boxSize) [expr {max(10,min($dx,$dy))}]
set S(center,left) [expr {($w - 2*$S(margin) - $S(w)*$S(boxSize))/2}]
set S(center,top) [expr {($h - 2*$S(margin) - $S(h)*$S(boxSize))/2}]
DoCanvas
DrawBraid
}
##+##########################################################################
#
# CellToXY -- Converts from row,col knoxel address to 2 pairs of x,y
# values: top left, bottom right
#
proc CellToXY {row col} {
global S
set x0 [expr {$S(margin) + $S(center,left) + $col * $S(boxSize)}]
set y0 [expr {$S(margin) + $S(center,top) + $row * $S(boxSize)}]
set x1 [expr {$x0 + $S(boxSize)}]
set y1 [expr {$y0 + $S(boxSize)}]
return [list $x0 $y0 $x1 $y1]
}
##+##########################################################################
#
# DrawKnoxel -- Draws all the compenents of a knoxel: the knots and the lines
#
proc DrawKnoxel {row col} {
global S
lassign [CellToXY $row $col] x0 y0 x1 y1
lassign [CellToXY [expr {$row+1}] [expr {$col+1}]] . . x2 y2
lassign [CellToXY [expr {$row-1}] [expr {$col-1}]] x3 y3
set type [expr {($row % 2) == 0 ? "even" : "odd"}]
set row1 [expr {$row+2}]
set col1 [expr {$col+2}]
# Top bar
if {$col == $S(w)-1} {
.c create line $x0 $y0 $x1 $y0 -fill gray80 \
-width $S(lineWidth,off) -tag line
} elseif {$col < $S(w)-1} {
.c create line $x0 $y0 $x2 $y0 -fill $S(color,$type) \
-width $S(lineWidth,off) \
-tag [list line top$row,$col]
.c bind top$row,$col <Enter> [list .c config -cursor $S(cursor)]
.c bind top$row,$col <Leave> [list .c config -cursor {}]
.c bind top$row,$col <1> [list DoClick toggle $row $col $row $col1]
}
if {$col == 1} {
.c create line $x0 $y0 $x3 $y0 -fill gray80 -width $S(lineWidth,off) \
-tag line
}
# Left bar
if {$row == $S(h)-1} {
.c create line $x0 $y0 $x0 $y1 -fill gray80 -width $S(lineWidth,off) \
-tag line
} elseif {$row < $S(h)-1} {
.c create line $x0 $y0 $x0 $y2 -fill $S(color,$type) \
-width $S(lineWidth,off) \
-tag [list line left$row,$col]
.c bind left$row,$col <Enter> [list .c config -cursor $S(cursor)]
.c bind left$row,$col <Leave> [list .c config -cursor {}]
.c bind left$row,$col <1> [list DoClick toggle $row $col $row1 $col]
}
if {$row == 1} {
.c create line $x0 $y0 $x0 $y3 -fill gray80 -width $S(lineWidth,off) \
-tag line
}
Marker $row $col
}
##+##########################################################################
#
# Diamond -- Returns xy of a diamond around a point
#
proc Diamond {x y d} {
set r [expr {$d/2}]
set x0 $x
set y0 [expr {$y - $r}]
set x1 [expr {$x + $r}]
set y1 $y
set x2 $x
set y2 [expr {$y + $r}]
set x3 [expr {$x - $r}]
set y3 $y
return [list $x0 $y0 $x1 $y1 $x2 $y2 $x3 $y3 $x0 $y0]
}
##+##########################################################################
#
# Marker -- Draws a marker at the top left of a given knoxel
#
proc Marker {row col} {
set type [expr {($row % 2) == 0 ? "even" : "odd"}]
lassign [CellToXY $row $col] x y
set xy [Diamond $x $y $::S(dotSize)]
set id [.c create poly $xy -fill $::S(color,$type) -outline black -width 2 \
-tag marker]
.c bind $id <1> [list HideKnoxel $row $col]
}
##+##########################################################################
#
# Reset -- Resets back to starting configuration
#
proc Reset {} {
set ::B(braidWidth,perc) 40
set ::B(show,marker) 1
set ::B(show,break) 1
set ::B(show,line) 1
set ::B(show,braid) 1
set ::B(show,hidden) 1
ResetBreaks
ShowAllBreaks
ResetHiddenCells
ShowAllHiddenCells
DrawBraid
}
##+##########################################################################
#
# ResetBreaks -- Removes all but the outside breaks
#
proc ResetBreaks {} {
global B S
foreach break $B(breaks) {
lassign [split $break ","] row0 col0 row1 col1
DoClick off $row0 $col0 $row1 $col1
}
SetWallBreaks
}
##+##########################################################################
#
# SetWallBreaks -- Add breaks along the outer walls
#
proc SetWallBreaks {} {
global S
foreach row [list 0 $S(h)] {
for {set col [expr {$row % 2}]} {$col < $S(w)} {incr col 2} {
AddRemoveBreak on $row $col $row [expr {$col+2}]
}
}
foreach col [list 0 $S(w)] {
for {set row [expr {$col % 2}]} {$row < $S(h)} {incr row 2} {
AddRemoveBreak on $row $col [expr {$row+2}] $col
}
}
}
##+##########################################################################
#
# ShowAllBreaks -- Displays all breaks in $B(breaks)
#
proc ShowAllBreaks {} {
foreach break $::B(breaks) {
lassign [split $break ","] row0 col0 row1 col1
ShowBreak $row0 $col0 $row1 $col1
}
}
##+##########################################################################
#
# ResetHiddenCells -- Removes all hidden cells
#
proc ResetHiddenCells {} {
set ::B(hiddenCells) {}
}
##+##########################################################################
#
# ShowAllHiddenCells -- Hides all cells in $B(hiddenCells)
#
proc ShowAllHiddenCells {} {
global B S
.c itemconfig hidden -fill $S(color,bg)
foreach tag $B(hiddenCells) {
.c itemconfig $tag -fill black
}
}
##+##########################################################################
#
# DoClick -- Handles clicking to create or remove a break
# NB. how == "toggle" is for user initiated events
#
proc DoClick {how row0 col0 row1 col1} {
set showBraid 0
if {$how eq "toggle"} {
set how [expr {[BreakExists $row0 $col0 $row1 $col1] ? "off" : "on"}]
set showBraid 1
}
AddRemoveBreak $how $row0 $col0 $row1 $col1
ShowBreak $row0 $col0 $row1 $col1
if {! $showBraid} return
set h [expr {2 * int(($::S(h)+1)/2)}]
set xrow0 [expr {$h - $row0}]
set xrow1 [expr {$h - $row1}]
lassign [lsort -integer [list $xrow0 $xrow1]] xrow0 xrow1
set w [expr {2 * int(($::S(w)+1)/2)}]
set xcol0 [expr {$w - $col0}]
set xcol1 [expr {$w - $col1}]
lassign [lsort -integer [list $xcol0 $xcol1]] xcol0 xcol1
if {$::B(sym,hor)} {
DoClick $how $row0 $xcol0 $row1 $xcol1
}
if {$::B(sym,ver)} {
DoClick $how $xrow0 $col0 $xrow1 $col1
}
if {$::B(sym,hor) && $::B(sym,ver)} {
DoClick $how $xrow0 $xcol0 $xrow1 $xcol1
}
DrawBraid
}
##+##########################################################################
#
# AddRemoveBreak -- Adds or removes a break, checking for crossing an
# existing break
#
proc AddRemoveBreak {action row0 col0 row1 col1} {
global B
set break "$row0,$col0,$row1,$col1"
set n [lsearch $B(breaks) $break]
if {$action eq "on"} {
if {$n == -1} {
lappend B(breaks) $break
}
RemoveCrossingBreak $row0 $col0 $row1 $col1
} else {
if {$n != -1} {
set B(breaks) [lreplace $B(breaks) $n $n]
}
}
}
##+##########################################################################
#
# RemoveCrossingBreak -- Removes a crossing break if it exists
#
proc RemoveCrossingBreak {row0 col0 row1 col1} {
global B
if {$row0 == $row1} {
set xrow0 [expr {$row0-1}]
set xcol0 [expr {$col0+1}]
set xrow1 [expr {$row0+1}]
set xcol1 $xcol0
} else {
set xrow0 [expr {$row0+1}]
set xcol0 [expr {$col0-1}]
set xrow1 $xrow0
set xcol1 [expr {$col0+1}]
}
set xbreak "$xrow0,$xcol0,$xrow1,$xcol1"
set n [lsearch $B(breaks) $xbreak]
if {$n > -1} {
set B(breaks) [lreplace $B(breaks) $n $n]
ShowBreak $xrow0 $xcol0 $xrow1 $xcol1
}
}
##+##########################################################################
#
# BreakExists -- true if a given break exists
#
proc BreakExists {row0 col0 row1 col1} {
global B
set break "$row0,$col0,$row1,$col1"
set n [lsearch $B(breaks) $break]
return [expr {$n > -1}]
}
##+##########################################################################
#
# ShowBreak -- Draws a given break on the screen
#
proc ShowBreak {row0 col0 row1 col1} {
global B
set break "$row0,$col0,$row1,$col1"
set n [lsearch $B(breaks) $break]
set how [expr {$n > -1 ? "on" : "off"}]
set which [expr {$row0 == $row1 ? "top" : "left"}]
set type [expr {($row0 % 2) == 0 ? "even" : "odd"}]
set clr [expr {$how == "on" ? "black" : $::S(color,$type)}]
set tag $which$row0,$col0
.c itemconfig $tag -fill $clr -width $::S(lineWidth,$how)
if {$how eq "on"} {
.c addtag break withtag $tag
.c dtag $tag line
} else {
.c dtag $tag break
.c addtag line withtag $tag
}
.c raise $tag line
.c raise marker
}
##+##########################################################################
#############################################################################
#
# Color stuff
#
##+##########################################################################
#
# GetNColors -- Returns n colors evenly spaced around the HLS color model
#
proc GetNColors {n} {
set inc [expr {1.0/$n}]
set s 1.0
set l 1.0
set colors {}
for {set i 0} {$i < $n} {incr i} {
set h [expr {$::S(color,salt) + $i*$inc}]
set h [expr {$h - int($h)}] ;# Normalize
set rgb [hls2tk $h $l $s]
lappend colors $rgb
}
return $colors
}
##+##########################################################################
#
# hls2rgb -- converts hls to float rgb
#
proc hls2rgb {h l s} {
# h, l and s are floats between 0.0 and 1.0, ditto for r, g and b
# h = 0 => red
# h = 1/3 => green
# h = 2/3 => blue
set h6 [expr {($h-floor($h))*6}]
set r [expr { $h6 <= 3 ? 2-$h6
: $h6-4}]
set g [expr { $h6 <= 2 ? $h6
: $h6 <= 5 ? 4-$h6
: $h6-6}]
set b [expr { $h6 <= 1 ? -$h6
: $h6 <= 4 ? $h6-2
: 6-$h6}]
set r [expr {$r < 0.0 ? 0.0 : $r > 1.0 ? 1.0 : double($r)}]
set g [expr {$g < 0.0 ? 0.0 : $g > 1.0 ? 1.0 : double($g)}]
set b [expr {$b < 0.0 ? 0.0 : $b > 1.0 ? 1.0 : double($b)}]
set r [expr {(($r-1)*$s+1)*$l}]
set g [expr {(($g-1)*$s+1)*$l}]
set b [expr {(($b-1)*$s+1)*$l}]
return [list $r $g $b]
}
##+##########################################################################
#
# hls2tk -- Converts hls to rgb format that tk understands
#
proc hls2tk {h l s} {
set rgb [hls2rgb $h $l $s]
set init "#"
foreach c $rgb {
set intc [expr {int($c * 256)}]
if {$intc == 256} { set intc 255 }
set c1 [format %02X $intc]
append init $c1
}
return $init
}
##+##########################################################################
#
# NewColorSalt -- changes our color salt randomly for a new color scheme
#
proc NewColorSalt {} {
set ::S(color,salt) [expr {$::S(color,salt) + .2 + .6*rand()}]
set ::S(color,salt) [expr {$::S(color,salt) - int($::S(color,salt))}]
DrawBraid
}
##+##########################################################################
#############################################################################
#
# Drawing Braid code
#
##+##########################################################################
#
# DrawBraid -- Draws all the braids
#
proc DrawBraid {} {
.c delete braid
InitKnoxels
set paths {}
while {1} {
set start [FindAStart]
if {$start eq ""} break
set path [Walk $start]
lappend paths $path
}
if {$::B(monochrome)} {
set clr [lindex [GetNColors 1] 0]
set colors [lrepeat [llength $paths] $clr]
} else {
set colors [GetNColors [llength $paths]]
}
set braidWidth [expr {$::S(boxSize) * $::B(braidWidth,perc) / 100}]
set innerWidth [expr {$braidWidth/2}]
foreach path $paths clr $colors {
lassign $path xy vlist
SaveKnoxelColor $vlist $clr
if {! $::B(solid)} {
.c create line $xy -tag braid -fill $::S(color,edge) \
-width $braidWidth -smooth 1 -capstyle round
.c create line $xy -tag braid -fill $clr \
-width $innerWidth -smooth 1 -capstyle round
} else {
.c create line $xy -tag braid -fill $clr \
-width $braidWidth -smooth 1 -capstyle projecting
}
}
FixCrossings
Hide
}
##+##########################################################################
#
# Walk -- Walks our knoxels from a given starting point. Handles braid
# leaving the board
#
proc Walk {start} {
array set OPP {nw se ne sw sw ne se nw}
lassign [Walk2 $start] xy vlist
lassign [lindex $vlist end] row col dir
# See if off the board. If so, reverse from last good position and
# double the first and last spline control points
#if {$row < 0 || $row >= $::S(h) || $col < 0 || $col >= $::S(w)} {}
if {$::K($row,$col,visited) == 2} {
Unvisit $vlist
lassign [lindex $vlist end-1] row col dir
set newStart [list $row $col $OPP($dir)]
lassign [Walk2 $newStart] xy vlist
set pre [lrange $xy 0 1]
set post [lrange $xy end-1 end]
set xy [concat $pre $xy $post]
}
return [list $xy $vlist]
}
##+##########################################################################
#
# Walk2 -- Walks our knoxels from a given starting point
#
proc Walk2 {start} {
global K
set vector $start
set xy [Visit $vector]
set vlist [list $vector]
while {1} {
set next [NextKnoxel $vector]
lappend vlist $next
if {! [OkToVisit $next]} {
break
}
lassign [Visit $next] x0 y0 x1 y1
lappend xy $x1 $y1
set vector $next
}
return [list $xy $vlist]
}
##+##########################################################################
#
# OkToVisit -- true if knoxel hasn't been visited yet. NB, outside K
# will be undefined
#
proc OkToVisit {vector} {
global K
lassign $vector row col
if {! [info exists K($row,$col,visited)] || $K($row,$col,visited) > 0} {
return false
}
return true
}
##+##########################################################################
#
# NextKnoxel -- walks to next knoxel cell bouncing off breaks as needed
#
proc NextKnoxel {vector} {
global K
array set DELTA {
nw {-1 -1}
ne {-1 1}
sw {1 -1}
se {1 1}
}
lassign $vector row col dir
lassign $DELTA($dir) drow dcol
set newDir $dir
if {$dir in {nw ne} && ($K($row,$col) & 2)} { ;# Upper wall
set drow 0
set newDir [string replace $dir 0 0 "s"]
}
if {$dir in {sw se} && ($K($row,$col) & 8)} { ;# Lower wall
set drow 0
set newDir [string replace $dir 0 0 "n"]
}
if {$dir in {nw sw} && ($K($row,$col) & 1)} { ;# Left wall
set dcol 0
set newDir [string replace $dir 1 1 "e"]
}
if {$dir in {ne se} && ($K($row,$col) & 4)} { ;# Right wall
set dcol 0
set newDir [string replace $dir 1 1 "w"]
}
set row1 [expr {$row + $drow}]
set col1 [expr {$col + $dcol}]
return [list $row1 $col1 $newDir]
}
##+##########################################################################
#
# Visit -- Mark knoxel visited and return xy path through it
#
proc Visit {vector} {
global K
lassign $vector row col dir
set K($row,$col,visited) 1
lassign [CellToXY $row $col] x0 y0 x1 y1
if {$dir eq "nw"} {
set xy [list $x1 $y1 $x0 $y0]
} elseif {$dir eq "ne"} {
set xy [list $x0 $y1 $x1 $y0]
} elseif {$dir eq "sw"} {
set xy [list $x1 $y0 $x0 $y1]
} elseif {$dir eq "se"} {
set xy [list $x0 $y0 $x1 $y1]
} else {
puts stderr "bad dir: $dir"
return
}
return $xy
}
##+##########################################################################
#
# Unvisit -- Removes visited bit for all cells on a path
#
proc Unvisit {vlist} {
foreach knoxel $vlist {
lassign $knoxel row col .
if {[info exists ::K($row,$col,visited)] \
&& $::K($row,$col,visited) != 2} {
set ::K($row,$col,visited) 0
}
}
}
##+##########################################################################
#
# FindAStart -- Find an unvisited knoxel as a starting point
#
proc FindAStart {} {
global K S
foreach knoxel [array names K *,visited] {
if {$K($knoxel)} continue
lassign [split $knoxel ","] row col
set dir [expr {(($row+$col) % 2) == 0 ? "ne" : "nw"}]
return [list $row $col $dir]
}
return [list]
}
##+##########################################################################
#
# SaveKnoxelColor -- Save color of braid through cell for later fake crossing
#
proc SaveKnoxelColor {vlist clr} {
foreach cell $vlist {
lassign $cell row col
set ::K($row,$col,color) $clr
}
}
##+##########################################################################
#
# InitKnoxels -- Initializes the K (knoxel) array needed for braid walking
#
proc InitKnoxels {} {
global S B K
unset -nocomplain K
for {set row 0} {$row < $S(h)} {incr row} {
for {set col 0} {$col < $S(w)} {incr col} {
set K($row,$col) 0
set K($row,$col,visited) 0
}
}
# Mark outside boxes
foreach row [list -1 $S(h)] {
for {set col -1} {$col <= $S(w)} {incr col} {
set K($row,$col,visited) 2
}
}
foreach col [list -1 $S(w)] {
for {set row -1} {$row <= $S(h)} {incr row} {
set K($row,$col,visited) 2
}
}
foreach hidden $B(hiddenCells) {
lassign [split $hidden ","] . row col
set K($row,$col,visited) 2
}
foreach break $B(breaks) {
lassign [split $break ","] row0 col0 row1 col1
if {$row0 == $row1} {
set above [expr {$row0 - 1}]
set below $row0
set left $col0
set right [expr {$col0 + 1}]
incr K($above,$left) 8
incr K($below,$left) 2
incr K($above,$right) 8
incr K($below,$right) 2
} else {
set above $row0
set below [expr {$row0 + 1}]
set left [expr {$col0 - 1}]
set right $col0
incr K($above,$left) 4
incr K($below,$left) 4
incr K($above,$right) 1
incr K($below,$right) 1
}
}
}
##+##########################################################################
#
# Hide -- Hides or shows various knoxel elements
#
proc Hide {} {
global B
set B(show,marker) $B(show,line)
set B(show,hidden) $B(show,break)
set who {hidden line break marker braid}
.c raise bg
foreach type $who {
if {$B(show,$type)} {
.c raise $type
}
}
.c itemconfig braid -splinesteps $B(corners)
}
##+##########################################################################
#
# FixCrossings -- Fix up interleave line crossings
#
proc FixCrossings {} {
global S K
for {set row 0} {$row < $S(h)-1} {incr row} {
set row1 [expr {$row+1}]
for {set col [expr {($row+1) % 2}]} {$col < $S(w)-1} {incr col 2} {
# Check if this cell has no right or bottom walls
if {($K($row,$col) & (4 + 8)) == 0} {
FakeCrossing $row $col
}
}
}
}
##+##########################################################################
#
# FakeCrossing -- Draw the crossing from this cell to the one down and
# right. We fake it by overlaying a short line segment in the correct
# color and direction.
#
proc FakeCrossing {row col} {
lassign [CellToXY $row $col] . . x y
set braidWidth [expr {$::S(boxSize) * $::B(braidWidth,perc) / 100}]
set innerWidth [expr {$braidWidth/2}]
set delta [expr {($braidWidth+1)/2}]
set x0 [expr {$x - $delta}]
set y0 [expr {$y - $delta}]
set x1 [expr {$x + $delta}]
set y1 [expr {$y + $delta}]
set row1 [expr {$row+1}]
set col1 [expr {$col+1}]
if {($col % 2) == 0} {
# NE crossing
set xy [list $x0 $y1 $x1 $y0]
set row1 [expr {$row+1}]
set cells [list $row1 $col $row $col1]
} else {
# NW crossing
set xy [list $x0 $y0 $x1 $y1]
set cells [list $row $col $row1 $col1]
}
foreach {r c} $cells {
if {$::K($r,$c,visited) == 2} {
return
}
}
foreach {r c} $cells {
if {[info exists ::K($r,$c,color)]} {
set clr $::K($r,$c,color)
break
}
}
if {$clr eq ""} {
puts stderr "ERROR: no color found for crossing $row,$col ($cells)"
return
}
if {! $::B(solid)} {
.c create line $xy -tag {braid crossing} -fill $::S(color,edge) \
-width $braidWidth
.c create line $xy -tag {braid crossing} -fill $clr -width $innerWidth
} else {
.c create line $xy -tag {braid crossing} -fill $clr -width $braidWidth
}
}
#############################################################################
#############################################################################
##+##########################################################################
#
# NewSize -- Displays a dialog to resize the grid
#
proc NewSize {} {
if {[winfo exists .sizer]} return
set ::S(new,width) $::S(w)
set ::S(new,height) $::S(h)
::ttk::labelframe .sizer -text Resize
::ttk::labelframe .sizer.w -text "Width" -relief flat
scale .sizer.w.s -from 2 -to 30 -variable ::S(new,width) -orient h \
-showvalue 0 \
-command {apply {{val} { .sizer.w config -text "Width: $val" }}}
pack .sizer.w.s -fill both -expand 1
::ttk::labelframe .sizer.h -text "Height" -relief flat
scale .sizer.h.s -from 2 -to 30 -variable ::S(new,height) -orient h \
-showvalue 0 \
-command {apply {{val} { .sizer.h config -text "Height: $val" }}}
pack .sizer.h.s -fill both -expand 1
pack .sizer.w .sizer.h -side top -fill x
::ttk::button .sizer.ok -text "Go" -command [list NewSizeDone .sizer 1]
::ttk::button .sizer.cancel -text "Cancel" \
-command [list NewSizeDone .sizer 0]
pack .sizer.ok .sizer.cancel -side left -pady .2i -expand 1
place .sizer -in . -relx 1 -rely 1 -anchor se
button .sizer.kill -image ::img::chi -command [list NewSizeDone .sizer 0]
place .sizer.kill -relx 1 -rely 0 -anchor ne -bordermode outside
}
##+##########################################################################
#
# NewSizeDone -- Called when user is done with the resize dialog
#
proc NewSizeDone {w how} {
destroy $w
if {$how} {
set ::S(w) $::S(new,width)
set ::S(h) $::S(new,height)
ResetBreaks
ResetHiddenCells
ResizeCanvas [winfo width .c] [winfo height .c]
.ctrl.symmetry.sym,hor config -state \
[expr {($::S(w) % 2) == 0 ? "normal" : "disabled"}]
.ctrl.symmetry.sym,ver config -state \
[expr {($::S(h) % 2) == 0 ? "normal" : "disabled"}]
set ::B(sym,hor) [expr {$::B(sym,hor) && ($::S(w) % 2) == 0}]
set ::B(sym,ver) [expr {$::B(sym,ver) && ($::S(h) % 2) == 0}]
}
}
##+##########################################################################
#
# ScreenShot -- Takes and saves a screenshot of the braid
#
proc ScreenShot {} {
catch {image delete ::img::screen}
image create photo ::img::screen -data .c
set fname [tk_getSaveFile -defaultextension .png \
-title "Save $::S(title) As" \
-filetypes {{"PNG Files" .png} {"All Files" .*}}]
if {$fname ne ""} {
::img::screen write $fname -format png
}
image delete ::img::screen
}
if {[lsearch [image names] ::img::chi] == -1} {
image create bitmap ::img::chi -data {
#define x_width 7
#define x_height 7
static char x_bits = {
0x63, 0x77, 0x3e, 0x1c, 0x3e, 0x77, 0x63
}
}
}
proc About {} {
set title "$::S(title)\n"
append title "by Keith Vetter, May, 2013\n"
append title "\n"
set msg ""
append msg "This program draws a web of interlacing lines forming a\n"
append Msg "Celtic Knot.\N"
append msg "\n"
append msg "To create a new Celtic Knot, click on a red or green line\n"
append msg "to create breaks. The breaks alter the paths of the lines\n"
append msg "forming the knot\n"
append msg "\n"
append msg "You can also click in a cell to exclude it from the Celtic\n"
append msg "Knot. Visually this works best if you surround excluded cells\n"
append msg "with breaks. Clicking again restores it.\n"
append msg "\n"
append msg "For details for how the knot is created, checkout\n"
append msg "http://isotropic.org/celticknot/."
if {$::tcl_platform(platform) eq "unix"} {
set msg [string map {\n\n \x01} $msg]
regsub -all { *\n *} $msg " " msg
set msg [string map {\x01 \n\n} $msg]
}
tk_messageBox -title $::S(title) -icon info -message "$title$msg"
}
################################################################
DoDisplay
return