The house of Santa Claus
if 0 {Richard Suchenwirth 2005-03-01 - The puzzle "Das Haus vom Nikolaus" used to be popular with German pre-schoolers, while at the same time having a little graph-theoretical interest.
The task is to draw the "house of Santa Claus" in one continuous stroke, without lifting the pen, or drawing a line twice. As nodes A and B are the only ones with an odd number of incident edges, it is obvious that you must start at either, and end at the other.
When drawing, it used to be habitual to say the eight-syllable phrase (because there are eight strokes to be drawn)
de: Das ist das Haus vom Ni- ko- laus
In other languages, these phrases might be used:
en: This is the house of San- ta Claus fr: C'est la mai-son de Saint Ni- cole it: La ca- sa di San Ni- co- la nl: Dat is het huis van Sin- ter- klaas zh: Sheng Ni- gu- la di xiao fang-zi
LES has never heard of it, but suggests a Brazilian version:
pt-BR: Ca-si-nha do Pa-pai No-el
}
package require Tk
#-- A usage message is a good start (and will be used on "?")
set about {House of Santa Claus
Powered by Tcl/Tk!
Richard Suchenwirth 2005
Draw the outlined house in one continuous move
by clicking on the edge circles.
Click "C" to reset.
Click "<-" to undo the last move.
Click "!" for a hint.
}#-- Build the UI
proc main {} {
global g
array set g {
edges {AB AC AD BC BD CD CE DE}
A {60 240} B {220 240} C {220 120} D {60 120} E {140 40}
}
pack [canvas .c -width 240 -height 260]
.c create window 20 20 -window [button .c.? -width 2 -text ? \
-command {tk_messageBox -message $::about}]
.c create window 20 50 -window [button .c.c -width 2 -text C \
-command {reset .c}]
.c create window 20 80 -window [button .c.<- -width 2 -text <- \
-command {undo .c}]
.c create window 20 110 -window [button .c.! -width 2 -text ! \
-command {hint .c}]
foreach edge $g(edges) {
foreach {from to} [split $edge ""] break
.c create line [concat $g($from) $g($to)] -width 2 -fill white
}
foreach node [array names g ?] {
node .c $node $g($node)
}
.c bind node <1> {clicknode .c}
reset .c
}#-- Back to square one :)
proc reset w {
global g
foreach i [array names g incides,?] {unset g($i)}
foreach edge $g(edges) {
foreach {from to} [split $edge ""] break
lappend g(incides,$from) $to
lappend g(incides,$to) $from
}
$w delete line
$w itemconfig node -fill yellow
set g(stack) {}
catch {unset g(last)}
foreach event [after info] {after cancel $event}
}#-- Draw a node as circle, with label
proc node {w name pos} {
foreach {x y} $pos break
$w create oval [expr $x-5] [expr $y-5] [expr $x+5] [expr $y+5] \
-outline black -tag [list node $name]
set tx [expr {$x<140? $x-12: $x>140? $x+12: $x}]
set ty [expr {$y<120? $y-12: $y>120? $y+12: $y}]
$w create text $tx $ty -text $name
}#-- Called when a node is selected, by user or [hint]
proc clicknode {w {node -}} {
global g
set id [$w find withtag [expr {$node eq "-"? "current": $node}]]
set name [lindex [$w gettags $id] 1]
if [info exists g(last)] {
set last $g(last)
if {$last eq "" || $last eq $name} {return 0}
if {[lsearch $g(incides,$last) $name]>=0} {
$w create line [concat $g($last) $g($name)] -width 5 \
-tag [list line $last$name]
lappend g(stack) $last$name $name
set g(last) $name
$w itemconfig $last -fill yellow
$w itemconfig $name -fill blue
$w raise node
lremove g(incides,$last) $name
lremove g(incides,$name) $last
if [done?] {
tk_messageBox -message "Made it!"
reset $w
return 1
}
}
} else {
set g(last) $name
$w itemconfig $name -fill blue
}
return 0
}#-- Undo the last move
proc undo w {
global g
$w itemconfig [lindex $g(stack) end] -fill yellow
set g(last) [lindex $g(stack) end-2]
$w itemconfig $g(last) -fill blue
set lastedge [lindex $g(stack) end-1]
$w delete $lastedge
foreach {from to} [split $lastedge ""] break
lappend g(incides,$from) $to
lappend g(incides,$to) $from
set g(stack) [lrange $g(stack) 0 end-2]
if {[llength $g(stack)]==0} {unset g(last)}
}#-- See if the puzzle is completed
proc done? {} {
foreach i [array names ::g incides,*] {
if {[llength $::g($i)]} {return 0}
}
return 1
}#-- Demonstrate a possible solution
proc hint w {
reset $w
set node [lpick {A B}]
while {![done?]} {
if [clicknode $w $node] break
update idletasks
after 1000
set node [lpick $::g(incides,$node)]
if {$node eq ""} {after idle hint $w; break}
}
}#-- Generally useful routines:
proc lremove {_list element} {
upvar 1 $_list list
set pos [lsearch $list $element]
set list [lreplace $list $pos $pos]
}
proc lpick list {
lindex $list [expr int(rand()*[llength $list])]
}#-- Let the show begin!
main
#-- Debugging helpers:
bind . <Escape> {exec wish $argv0 &; exit}
bind . <F1> {console show}if 0 {