## 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
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 ? \
.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?] {
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
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 {