##+##########################################################################
 #
 # CelticBraid.tcl -- draws an intertwined latice pattern
 # by Keith Vetter, November 2007
 #
 
 package require Tk
 array set SZ {title "Celtic Braid" N 4 l 100 w 50 c 50 a 0 stepping 0 pos 0
    ready 0 clr,0 black clr,1 red width,0 2 width,1 4}
 array set LEN2RADIUS {
    3 0.57735026919  4 0.707106781187 5 0.850650808352 6 1.0
    7 1.15238243548  8 1.30656296488  9 1.46190220008 10 1.61803398875
    11 1.77473276644 12 1.93185165258 13 2.08929073443 14 2.24697960372
    15 2.40486717237 16 2.56291544774 17 2.72109557588 18 2.87938524157
    19 3.03776691049 20 3.19622661075 21 3.35475306990 22 3.51333709167
    23 3.67197109805 24 3.83064878777 25 3.98936487778 26 4.14811490528
    27 4.30689507424 28 4.46570213519 29 4.62453329015 30 4.78338611675
 }
 set LINES {
    {{1 0 0}} {{0 0 1}} {{1 1 2}}
    {{0 1 3} {1 3 5} {0 4 5}}
    {{0 2 7} {1 6 7} {0 2 6}}
 }
 set SZ(numSteps) [llength $LINES]
 
 proc DoDisplay {} {
    wm title . $::SZ(title)
    pack [frame .buttons] -side bottom
    pack [canvas .c -width 600 -height 600] -side top -fill both -expand 1
    .c create text 0 0 -anchor n -text $::SZ(title) -font {Helvetica 24 bold} -tag title
 
    scale .sN -var ::SZ(N) -orient h -relief ridge -command Config -from 3 -to 15 -label Sides
    scale .sL -var ::SZ(l) -orient h -relief ridge -command Config -from 1 -to 200 -label Length
    scale .sW -var ::SZ(w) -orient h -relief ridge -command Config -from 1 -to 100 -label Width
    scale .sC -var ::SZ(c) -orient h -relief ridge -command Config -from 0 -to 100 -label Gap
    scale .sA -var ::SZ(a) -orient h -relief ridge -command Config -from -180 -to 180 -label Rotation
 
    checkbutton .stepping -text "Single Step" -variable ::SZ(stepping) \
        -relief raised -command {DoStep toggle}
    button .step -text "Next Step" -command {DoStep step} -state disabled
    button .about -text "?" -font {Times 18 bold} -command About
 
    pack .sN .sL .sW .sC .sA -side left -in .buttons
    pack .about -side right -fill y -in .buttons
    pack .stepping .step -side top -in .buttons -fill x -expand 1 -padx 10
    bind .c <Configure> {ReCenter %W %h %w}
    update
 }
 proc ReCenter {W h w} {                         ;# Called by configure event
    set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}]
    $W config -scrollregion [list -$w2 -$h2 $w2 $h2]
    $W coords title 0 -$h2
 }
 proc VAdd {A B {scalar 1}} {
    foreach {ax ay} $A {bx by} $B break
    return [list [expr {$ax + $scalar * $bx}] [expr {$ay + $scalar * $by}]]
 }
 proc VRescale {A len} {
    foreach {x y} $A break
    set n [expr {hypot($x,$y)}]
    return [list [expr {$x * $len / $n}] [expr {$y * $len / $n}]]
 }
 proc About {} {
    set msg "$::SZ(title)\nby Keith Vetter, November 2007\n\n"
    append msg "These are some of my favorite doodling shapes for\n"
    append msg "boring meetings. Someone taught me a long time\n"
    append msg "ago how to draw the 4-sided version and I quickly\n"
    append msg "generalized it to any number of sides.\n\n"
    append msg "This seemingly complicated pattern is actually quite\n"
    append msg "easy to draw if you proceed by a series of simple\n"
    append msg "steps. The 'Single Step' option shows you those\n"
    append msg "simple steps.\n\n"
    append msg "For higher number of sides, you have to carefully\n"
    append msg "adjust the parameters to keep lines from overlapping."
    tk_messageBox -title "About $::SZ(title)" -message $msg
 }
 proc Debug {{filter *}} {
    foreach p [array names ::P $filter] {
        foreach {x y} $::P($p) break
        set xy [list [expr {$x-2}] [expr {$y-2}] [expr {$x+2}] [expr {$y+2}]]
        .c create oval $xy -fill yellow
        .c create text $x $y -text $p -anchor se
    }
 }
 proc GetCenterPoly {} {
    global SZ P
 
    set adj -90
    if {$SZ(N) == 4} { set adj -45 }
    if {$SZ(N) == 5} { set adj 18 }
    set a [expr {$SZ(a) + $adj}]
    set da [expr {360. / $SZ(N)}]
    set SZ(r) [expr {$SZ(l) * $::LEN2RADIUS($SZ(N))}]
    for {set i 0} {$i < $SZ(N)} {incr i} {
        set rad [expr {($a + $i*$da) * acos(-1) / 180}]
        set x [expr {$SZ(r) * cos($rad)}]
        set y [expr {$SZ(r) * sin($rad)}]
        set P($i,0) [list $x $y]
    }
 }
 proc GetPoints {} {
    global V P SZ
 
    GetCenterPoly
    for {set i 0} {$i < $SZ(N)} {incr i} {
        set V($i) [VRescale [VAdd $P($i,0) $P([expr {($i-1) % $SZ(N)}],0) -1] 1]
    }
    set V($SZ(N)) $V(0)
 
    for {set i 0} {$i < $SZ(N)} {incr i} {
        set i1 [expr {$i+1}]
        set P($i,1) [VAdd $P($i,0) $V($i) $SZ(w)]
        set P($i,2) [VAdd $P($i,1) $V($i1) -$SZ(w)]
        set P($i,3) [VAdd $P($i,1) $V($i) $SZ(c)]
        set P($i,4) [VAdd $P($i,0) $V($i1) -$SZ(w)]
        set P($i,5) [VAdd $P($i,4) $V($i1) -$SZ(c)]
        set P($i,6) [VAdd $P($i,2) $V($i) [expr {$SZ(c) + $SZ(w)}]]
        set P($i,7) [VAdd $P($i,2) $V($i1) [expr {-($SZ(c) + $SZ(w))}]]
    }
 }
 proc DoOneLine {lines} {
    foreach line $lines {
        foreach {di p1 p2} $line break
        for {set i 0} {$i < $::SZ(N)} {incr i} {
            set i2 [expr {($i + $di) % $::SZ(N)}]
            set xy [concat $::P($i,$p1) $::P($i2,$p2)]
            .c create line $xy -width $::SZ(width,$::SZ(stepping)) \
                -fill $::SZ(clr,$::SZ(stepping)) -tag line
        }
    }
 }
 proc DoLines {last} {
    .c itemconfig line -width $::SZ(width,0) -fill $::SZ(clr,0)
    for {set i $::SZ(pos)} {$i < $last} {incr i} {
        DoOneLine [lindex $::LINES $i]
    }
    set ::SZ(pos) $i
 }
 proc Clear {} { .c delete line ; set ::SZ(pos) 0 }
 
 proc DoStep {how} {
    if {$how eq "toggle"} {
        Clear
        DoLines [expr {$::SZ(stepping) ? 1 : $::SZ(numSteps)}]
        .step config -state [expr {$::SZ(stepping) ? "normal" : "disabled"}]
    } else {
        set last [expr {$::SZ(pos) + 1}]
        if {$last > 1+$::SZ(numSteps)} {
            Clear
            set last 1
        }
        DoLines $last
    }
 }
 proc Config {args} {
    if {! $::SZ(ready)} return
 
    set pos $::SZ(pos)
    Clear
    GetPoints
    if {$::SZ(stepping)} {
        DoLines [expr {$pos-1}]
        DoLines $pos
    } else {
        DoLines $::SZ(numSteps)
    }
 }
 
 DoDisplay
 set SZ(ready) 1
 Config
 return