Updated 2018-04-29 07:16:19 by dbohdan

Keith Vetter 2003-Feb-09 - another weekend whizzlet project, this one drawing the Hilbert plane-filling curve. Discovered in 1891 by mathematician David Hilbert, it was the second such curves ever discovered (Guiseppe Peano discovered the first in 1890).

One classical application of plane-filling curves is the "Peano method" of Mathematical Big Game Hunting [1].
``` ##+##########################################################################
#
# 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 {
-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

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

}
##+##########################################################################
#
# 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 {}
foreach {l t r b} [ShrinkBox \$box] break
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} {
foreach {l t r b} \$box break

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} {
foreach {l t r b} \$box break
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]}
}