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 {

Category Toys | Arts and crafts of Tcl-Tk programming}