##+##########################################################################
 #
 # hilbert.tcl -- draws the Hilbert Curve
 # by Keith Vetter
 #
 package require Tk
 
 array set S {lvl 0 color black connect 1}
 array set DIRS {E {S E E N} N {W N N E} S {E S S W} W {N W W S}}
 array set QTRS {E {1 2 3 4} N {3 2 1 4} S {1 4 3 2} W {3 4 1 2}}
 array set XY   {E {l t r t r b l b} N {r b r t l t l b}
                W {r b l b l t r t} S {l t l b r b r t}}
 
 proc DoDisplay {} {
    global S
 
    wm title . TkHilbert
    pack [frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5] \
        -side right -fill both -ipady 5
    pack [frame .top -relief raised -bd 2] -side top -fill x
    pack [frame .screen -bd 2 -relief raised] -side top -fill both -expand 1
    canvas .c -relief raised -borderwidth 0 -height 500 -width 500 -bg cyan
    label .msg -textvariable S(msg) -bd 2 -bg white -relief ridge
    pack .msg -side bottom -fill both -in .screen 
    pack .c -side top -expand 1 -fill both -in .screen
 
    set colors {red orange yellow green blue cyan purple violet white}
    lappend colors [lindex [.c config -bg] 3] black
    foreach color $colors {
        radiobutton .top.b$color -width 1 -padx 0 -pady 0 -bg $color \
            -variable S(color) -value $color -command ReColor
        bind .top.b$color <3> [list .c config -bg $color]
    }
    eval pack [winfo children .top] -side left -fill y
 
    DoCtrlFrame
    ReColor
    update
    trace variable S(draw) w Tracer
    bind .sLevel <ButtonRelease-1> {if {! $S(draw)} DrawHilbertA}
 }
 proc DoCtrlFrame {} {
    frame .ctrl.top
    scale .sLevel -from 0 -to 7 -label Level -variable S(lvl) -relief ridge \
        -orient horizontal -highlightthickness 0
    .sLevel configure -font "[font actual [.sLevel cget -font]] -weight bold"
 
    button .draw -text "Redraw Curve" -command DrawHilbertA -bd 4
    button .clear -text "Clear Curve" -command {.c delete all} -bd 4
    button .stop -text "Stop Drawing" -command {set S(draw) 0} -bd 4
    .draw configure -font "[font actual [.draw cget -font]] -weight bold"
    .clear configure -font [.draw cget -font]
    .stop configure -font [.draw cget -font]
    
    image create bitmap ::img::up -data {
        #define up_width 11
        #define up_height 9
        static char up_bits = {
            0x00, 0x00, 0x20, 0x00, 0x70, 0x00, 0xf8, 0x00, 0xfc, 0x01, 0xfe,
            0x03, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00
        }}
    image create bitmap ::img::down -data {
        #define down_width 11
        #define down_height 9
        static char down_bits = {
            0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0xfe, 0x03, 0xfc, 0x01, 0xf8,
            0x00,0x70, 0x00, 0x20, 0x00, 0x00, 0x00
        }}
 
    button .up -image ::img::up -command {UpDown 1}
    button .down -image ::img::down -command {UpDown -1}
    checkbutton .connect -text "Show Connections" -variable S(connect) \
        -relief raised -command ShowConnectors
    button .about -text About -command About
 
 
    grid .ctrl.top     -in .ctrl -row 0 -sticky news
     grid .sLevel .up   -in .ctrl.top -row 0 -sticky news
     grid ^       .down -in .ctrl.top -row 1 -sticky news
    grid .draw    -in .ctrl -row 21 -sticky ew
    grid .clear   -in .ctrl -row 22 -sticky ew
    grid .stop    -in .ctrl -row 23 -sticky ew -pady 10
    grid .connect -in .ctrl -row 101 -sticky ew
    grid .about   -in .ctrl -row 102 -sticky ew
 
    grid rowconfigure .ctrl 10 -minsize 10
    grid rowconfigure .ctrl 20 -minsize 10
    grid rowconfigure .ctrl 50 -weight 1
 
    grid configure .up -ipadx 5
    grid configure .down -ipadx 5
 }
 ##+##########################################################################
 # 
 # Tracer -- traces the S(draw) variable and activates widgets accordingly
 # 
 proc Tracer {var1 var2 op} {
    global S
    set ww {.up .down .connect .draw .clear}
 
    if {$S(draw) == 0} {                        ;# Turning off drawing
        .stop config -state disabled
        .sLevel config -state normal -fg [lindex [.sLevel config -fg] 3]
        foreach w $ww { $w config -state normal}
    } else {
        .stop config -state normal
        .sLevel config -state disabled -fg [.up cget -disabledforeground]
        foreach w $ww { $w config -state disabled}
    }
 }
 
 ##+##########################################################################
 # 
 # DrawHilbert -- sets up the state and draws the Hilbert curve
 #
 proc DrawHilbertA {} {after 1 DrawHilbert}
 proc DrawHilbert {{lvl {}}} {
    global S
 
    if {$lvl == {}} { set lvl $S(lvl) } else { set S(lvl) $lvl }
    .c delete all
    set S(draw) 1
    set S(first) {}
    set S(ccolor) [expr {$S(connect) ? $S(color) : [.c cget -bg]}]
 
    set S(width) [expr {$lvl <= 4 ? (25 - 5*$lvl) : 8 - $lvl}]
    
    set n [expr {int(pow(4,$lvl+1) - 1)}]
    set S(msg) "Hilbert Curve Level $lvl ($n edges)"
    Hilbert [GetStartBox] E $lvl
    set S(draw) 0
    set S(first) {}
    if {! $::S(connect)} {.c lower connect}
 }
 ##+##########################################################################
 # 
 # UpDown -- draws the curve one level up or down from current
 # 
 proc UpDown {dlvl} {
    global S
 
    if {$dlvl < 0 && $S(lvl) == 0} return
    if {$dlvl > 0 && $S(lvl) >= [.sLevel cget -to]} return
 
    incr S(lvl) $dlvl
    DrawHilbert
 }
 ##+##########################################################################
 # 
 # Hilbert -- draws a specified level Hilbert curve
 # 
 proc Hilbert {box dir lvl} {
    global S DIRS QTRS
 
    if {! $S(draw)} return
    
    if {$lvl == 0} {
        Hilbert0 $box $dir
        return
    }
 
    set lvl2 [expr {$lvl - 1}]
    foreach quarter $QTRS($dir) newDir $DIRS($dir) {
        set b2 [QuarterBox $box $quarter]
        Hilbert $b2 $newDir $lvl2
    }
    if {$lvl >= 4} update
 }
 ##+##########################################################################
 # 
 # Hilbert0 -- draws the most basic hilbert curve inside $box facing $dir
 # 
 proc Hilbert0 {box dir} {
    global S XY
 
    set xy $S(first)                            ;# Possibly connect to last
    set xy {}
    lassign [ShrinkBox $box] l t r b
    foreach i $XY($dir) {                       ;# Walk coord list for this dir
        lappend xy [set $i]
    }
    if {$S(first) != ""} {
        .c create line [concat $S(first) [lrange $xy 0 1]] -width $S(width) \
            -tag {hilbert connect} -fill $S(ccolor)
    }
            
    .c create line $xy -tag hilbert -width $S(width) -fill $S(color) \
        -capstyle round
    set S(first) [lrange $xy end-1 end]         ;# So next connects w/ this one
 }
 ##+##########################################################################
 # 
 # GetStartBox -- returns coordinates of the area to draw our shape in
 # 
 proc GetStartBox {} {
    return [list 9 9 [expr {[winfo width .c]-9}] [expr {[winfo height .c]-9}]]
 }
 ##+##########################################################################
 # 
 # ShrinkBox -- shrinks a box to 1/4 of it's size
 # 
 proc ShrinkBox {box} {
    lassign $box l t r b
    
    set dx [expr {($r - $l) / 4.0}]
    set dy [expr {($b - $t) / 4.0}]
    set l [expr {$l + $dx}]     ; set r [expr {$r - $dx}]
    set t [expr {$t + $dy}]     ; set b [expr {$b - $dy}]
    return [list $l $t $r $b]
 }
 ##+##########################################################################
 # 
 # QuarterBox -- Returns coordinates of 1 of the 4 quadrants of BOX.
 # 1 = up/left, 2 = up/right, 3 = lower/right, 4 = lower/left
 # 
 proc QuarterBox {box corner} {
    lassign $box l t r b
    set hx [expr {($r - $l) / 2.0}]
    set hy [expr {($b - $t) / 2.0}]
 
    if {$corner == 1} {                         ;# Upper left
        set r [expr {$r - $hx}]
        set b [expr {$b - $hy}]
    } elseif {$corner == 2} {                   ;# Upper right
        set l [expr {$l + $hx}]
        set b [expr {$b - $hy}]
    } elseif {$corner == 3} {                   ;# Lower right
        set l [expr {$l + $hx}]
        set t [expr {$t + $hy}]
    } elseif {$corner == 4} {                   ;# Lower left
        set r [expr {$r - $hx}]
        set t [expr {$t + $hy}]
    }
    return [list $l $t $r $b]
 }
 proc ShowConnectors {} {
    if {$::S(connect)} {
        .c itemconfig connect -fill $::S(color)
    } else {
        .c itemconfig connect -fill [.c cget -bg]
        .c lower connect
    }
 }
 proc ReColor {} {
    global S
    .c itemconfig hilbert -fill $::S(color)
    if {! $::S(connect)} {.c itemconfig connect -fill [.c cget -bg]}
 }
 proc About {} {
    set msg "TkHilbert\nby Keith Vetter, Feb 2003\n\n"
    append msg "Draws the Hilbert Curve.\n\n"
    append msg "This curve was discovered by David Hilbert in 1891 and\n"
    append msg "was one of the first plane-filling curves ever found."
    tk_messageBox -title "About TkHilbert" -message $msg
 }
 
 ################################################################
 DoDisplay
 DrawHilbert