[Keith Vetter] 2013-05-15 : Celtic Knots are an ornamental design of interlacing lines[http://en.wikipedia.org/wiki/Celtic_knot]. I was inspired by [Celtic Knot Thingy] but I wanted an iteractive 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 [http://myweb.lmu.edu/bmellor/celticknots.pdf]. 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 continous 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 affect 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). ---- [http://wiki.tcl.tk/_repo/images/CelticKnot.png] ---- ====== ##+########################################################################## # # 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 {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 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 [list .c config -cursor $S(cursor)] .c bind top$row,$col [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 [list .c config -cursor $S(cursor)] .c bind left$row,$col [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 ====== <> Category Graphics|Category Toys