Updated 2013-08-03 12:52:02 by RLE

Keith Vetter 2003-05-12 : drag, rotate and drop blocks to assemble a bird or a boat.

escargo 12 May 2003 - Wonderful fun. However, I noticed that only particular pieces that matched seemed to make noise and change color when they were put in the right place. Shouldn't equivalent pieces be treated the same way? Or are no two pieces geometrically identical?

Also, on the bird puzzle, when I put the piece that goes for the right side of the bird's head in place, the bottom line has a step in it, as if it were not a straight line. Is that the way it's supposed to be?

KPV - Yes, you're right--identical pieces should be able to go into any appropriate spot. It's on the to-do list but to be honest it probably won't get done. As to the step in some lines, it's round-off error. The pieces start off very small, get scaled up and possibly rotated numerous times. After a while, the round off error accumulates giving you the unwanted stair step.

See also Tangram


HJG Added "Done"-Message when puzzle is completed. The website seems to have been "reorganized", the puzzle is now at http://invention.smithsonian.org/centerpieces/iap/playhouse_puzzle.html

uniquename 2013aug01

Here is an image of the GUI starting with the pieces for the boat puzzle. The bird is above.


##+##########################################################################
#
# Puzzle Blocks
# by Keith Vetter, May 9, 2003
# see http://invention.smithsonian.org/centerpieces/iap/playhouse_puzzle.html
#
# TODO
#  allow identical pieces to go into any identical spot

package require Tk
set S(title) "Puzzle Blocks"
set S(msg) ""
set S(snap) 10                                  ;# "Close enough" distance

proc DoDisplay {} {
    wm title . $::S(title)
    pack [frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5] \
-side right -fill both -ipady 5
    pack [frame .screen -bd 2 -relief raised] -side top -fill both -expand 1

    canvas .c -relief raised -borderwidth 0 -height 500 -width 500
    button .bird -text "Bird Puzzle" -command {GoPuzzle Bird} -bd 4
    .bird configure  -font "[font actual [.bird cget -font]] -weight bold"
    option add *font [.bird cget -font]
    button .boat  -text "Boat Puzzle" -command {GoPuzzle Boat} -bd 4
    button .about -text About -command [list tk_messageBox -title About -message "$::S(title) \
by Keith Vetter, May 2003"]
    label .msg -textvariable S(msg) -bd 2 -bg white -relief ridge

    pack .msg   -in .screen -side bottom -fill both
    pack .c     -in .screen -side top    -fill both -expand 1
    grid .bird  -in .ctrl -sticky ew -row 0
    grid .boat  -in .ctrl -sticky ew
    grid rowconfigure .ctrl 50 -weight 1
    grid .about -in .ctrl -row 100 -sticky ew

    bind all <Alt-c>     {console show}
    bind .c  <Configure> {ReCenter %W %h %w}
    update
}
proc ReCenter {W h w} {                         ;# Called by configure event
    set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}]
    $W config -scrollregion [list -$w2 -$h2 $w2 $h2]
}
proc RotateItem {id Oxy angle} {
    foreach {Ox Oy} $Oxy break
    set rangle [expr {$angle * atan(1) * 4 / 180.0}] ;# Radians

    set xy {}
    foreach {x y} [.c coords $id] {
        # rotates vector (Ox,Oy)->(x,y) by angle degrees clockwise
        set x  [expr {$x - $Ox}]                ;# Shift to origin
        set y  [expr {$y - $Oy}]
        set xx [expr {$x * cos($rangle) - $y * sin($rangle)}] ;# Rotate
        set yy [expr {$x * sin($rangle) + $y * cos($rangle)}]
        set xx [expr {$xx + $Ox}]               ;# Shift back
        set yy [expr {$yy + $Oy}]
        lappend xy $xx $yy
    }
    .c coords $id $xy
    set ::C(rotate,$id) [expr {($::C(rotate,$id)+$angle) % 360}]
}
proc MoveItem {who x y} {
    foreach {cx cy} [Centroid $who] break
    .c move $who [expr {$x - $cx}] [expr {$y - $cy}]
}
proc GoPuzzle {who} {
    set ::S(msg) "Drag and drop the pieces; right click to rotate"
    .c delete all
    $who
    DrawBoard
    DrawBlocks
}
proc DrawBlocks {} {
    global C S Y

    catch {unset Y}
    foreach {x0 y0 x1 y1} [.c cget -scrollregion] break
    set maxx [expr {$x1 - 30}]
    set maxy [expr {$y1 - 30}]
    foreach b [array names C coords,*] {
        foreach {_ who} [split $b ,] break
        .c create poly $C($b) -tag $who -fill yellow -outline black
        set C(rotate,$who) 0
        set Y($who) 1
        .c scale $who 0 0 $C(scale) $C(scale)
        .c bind $who <Button-1>        [list Mouse1 $who %x %y 0]
        .c bind $who <B1-Motion>       [list Mouse1 $who %x %y 1]
        .c bind $who <ButtonRelease-1> [list Mouse1 $who %x %y 2]
        .c bind $who <Button-3>        [list Mouse3 $who]

        MoveItem   $who [Random -$maxx $maxx] [Random -$maxy $maxy]
        RotateItem $who [Centroid $who] [expr {int(rand()*8)*45}]
    }
}
proc DrawBoard {} {
    .c create poly $::C(board) -tag board -outline black -fill blue4 -dash 1
    .c scale board 0 0 $::C(scale) $::C(scale)
    MoveItem board 0 0
    .c lower board
    set ::C(board2) [.c coords board]
}
proc Mouse1 {who x y what} {
    global S C Y

    set x [.c canvasx $x]
    set y [.c canvasy $y]

    if {$what == 0} {                           ;# Button down
.c itemconfig $who -width 3 -fill yellow
set Y($who) 1                           ;# Mark as out of position
.c raise $who
    } elseif {$what == 2} {                     ;# Button up
.c itemconfig $who -width 1
OkaySnap $who                           ;# See if it in correct position
    } else {                                    ;# Button move
set dx [expr {$x - $S(down,x)}]
set dy [expr {$y - $S(down,y)}]
.c move $who $dx $dy
    }
    set S(down,x) $x                            ;# Remember last position
    set S(down,y) $y
}
proc Mouse3 {who} {
    .c itemconfig $who -fill yellow
    set ::Y($who) 1                             ;# Mark as out of position
    RotateItem $who [Centroid $who] 45
    OkaySnap $who
}
proc Random {min max} {return [expr {$min + rand() * ($max - $min)}]}
proc Centroid {who} {
    foreach {x0 y0 x1 y1} [.c bbox $who] break
    return [list [expr {($x0 + $x1) / 2.0}] [expr {($y0 + $y1) / 2.0}]]
}
proc OkaySnap {who} {                           ;# See if close enough
    global C S Y

    foreach {p angles} $C(end,$who) break
    set n [lsearch $angles "a$C(rotate,$who)"]
    if {$n == -1} return
    set c [lindex $angles [expr {$n + 1}]]

    foreach {x1 y1} [lrange $C(board2)       [expr {2*$p}] [expr {2*$p+1}]] break
    foreach {x0 y0} [lrange [.c coords $who] [expr {2*$c}] [expr {2*$c+1}]] break
    set dx [expr {$x1 - $x0}]
    set dy [expr {$y1 - $y0}]
    set dist [expr {sqrt($dx*$dx + $dy*$dy)}]
    if {$dist > $S(snap)} return
    .c move $who $dx $dy
    .c itemconfig $who -fill green
    .c lower $who
    .c lower board
    snd_click play

    set Y($who) 0                               ;# Mark as in place
    foreach a [array names Y] {                 ;# Are we done?
if {$Y($a)} return
    }
    .c raise board
    .c itemconfig board -width 5 -dash {} -fill green
    set S(msg) "Done !"
}
proc DoSounds {} {
    proc snd_click {play} {}                    ;# Stub
    if {[catch {package require base64}]} return
    if {[catch {package require snack}]} return
    set sdata {UklGRkACAABXQVZFZm10IBAAAAABAAEAESsAABErAAABAAgAZGF0YRwCAACAgId0Z
HZbU5aMj7/MsIZ6UX6nWIiITWiIRUGUlZesvrGCiKiKTl96Fit3YF5emrGHqcqhlJuAdWxgW
01EbWSHubW1uJ2MkqGPYFVSamtvgHmEh5ybraWLkHp5Xm5oWGRvb3WSlYqMi4+JhY6Ac25xd
Xp5jYR/hoODdIN8e356goCHgoqGgIV/g35/d3N2eHZ6gIOIgouHioaNioGAfHpycHp2dH2Hi
ouNiYiKhIF9enZzd3l+dX2BgYKIjoaJhIJ/fX6AfHl8fICAgICEgISFhYF/gH+AfIJ/gH6Af
X6AfICAfYB+gn2DfoGAgIOAgYB8e3x9gIKChYCDgIN/g32Afn+BgIF+gH+BgIOAgX2CfYGAg
IB/gH9/fIB/gICBgH+Df4KAgIB9gHuBfYKAgoCAhICDgIN+gH+Af4CAgIGAg4CFgIOAgICAg
H9/f32AfoF/gn+BgICAf4B/gICAgICAgIKAgYCAgH+AfYB8f4CAgoGBgIKBgHt0cnqEi4yIh
oKHioOBeoF+gHRvbW10eYSHhoyMmI+PhIF5dm9tbW92fICJjpKRkY6JhHx5b2xlbnWAhYeOj
pSQkIiAe3R1cnNzdnx/gomLj4yJhICAfHp3d3d6fYKDhoKGgIeAhX1/eXt9foCAg4GCg4CDf
YF6gHmAfYCBgIR/h4CEf4B9fn98gHuEfYV/g4CAgn6Fe4R6gn1/gHuDe4V+g4CAgn8=}
    regsub -all {s} $sdata {} sdata            ;# Bug in base64 package
    sound snd_click
    snd_click data [::base64::decode $sdata]
}
proc Bird {} {
    global C

    set 2r2 [expr {2 * sqrt(2)}]
    catch {unset C}
    set C(board) [list 0 0 1 0 3 2 5 2 7 0 6 0 8 -2 5 -2 3 0 2 0 2 -1.5 1 -1.5]
    set C(scale) 60

    set C(coords,b1) {0 0 1 -1.5 2 -1.5 1 0}
    set C(end,b1) {0 {a0 0 a180 2}}
    set C(coords,b2) {0 0 1 -1.5 1 0}
    set C(end,b2) {1 {a0 0}}
    set C(coords,b3) {0 0 -2 -2 0 -2 2 0}
    set C(end,b3) {2 {a0 0 a180 2}}
    set C(coords,b4) [list $2r2 0 0 0 0 -$2r2]
    set C(end,b4) {3 {a45 0}}
    set C(coords,b5) {2 0 0 0 0 -2}
    set C(end,b5) {5 {a90 0}}
    set C(coords,b6) {2 0 0 0 0 -2}
    set C(end,b6) {3 {a90 0}}
    set C(coords,b7) {0 -1 1 -1 1 0 0 0}
    set C(end,b7) {7 {a0 0 a90 3 a180 2 a270 1}}
    set C(coords,b8) {1 0 0 0 0 -1 1 -1}
    set C(end,b8) {5 {a0 0 a90 3 a180 2 a270 1}}
}
proc Boat {} {
    global C

    set r2    [expr {sqrt(2)}]
    set r22   [expr {sqrt(2)/2}]
    set r22_1 [expr {sqrt(2)/2 + 1}]
    set r24   [expr {sqrt(2)/4}]
    catch {unset C}
    set C(scale) 110

    set C(board) {0 0}                          ;# P0
    AppendBoard -$r22 -$r22                     ;# P1
    AppendBoard [expr {$r22 + $r24/2}] 0        ;# P2
    AppendBoard 0 -$r24                         ;# P3
    AppendBoard 0 -$r22_1                       ;# P4
    AppendBoard $r22_1 $r22_1                   ;# P5
    AppendBoard [expr {-$r22_1 + $r24}] 0       ;# P6
    AppendBoard 0 $r24                          ;# P7
    AppendBoard [expr {$r24/2 + $r2 + $r22}] 0  ;# P8
    AppendBoard -$r22 $r22                      ;# P9
    AppendBoard -$r22 0                         ;# P10

    set C(coords,b1) [list 0 0 0 -$r22 $r22 0]
    set C(end,b1) {3 {a0 0}}
    set C(coords,b2) [list 0 0 0 -$r22 $r22 0]
    set C(end,b2) {0 {a180 1}}
    set C(coords,b3) [list 0 0 0 -$r22 $r22 0]
    set C(end,b3) {10 {a0 2}}
    set C(coords,b4) [list 0 0 0 -1 1 0]
    set C(end,b4) {10 {a315 0}}
    set C(coords,b5) [list 0 0 0 -1 1 0]
    set C(end,b5) {5 {a0 2}}
    set C(coords,b6) [list 0 0 $r22 $r22 $r22 $r22_1 0 1]
    set C(end,b6) {4 {a0 0 a180 2}}
    set C(coords,b7) [list 0 0 $r22 -$r22 [expr {$r22+$r22}] -$r22 $r22 0]
    set C(end,b7) {10 {a0 0 a180 2}}
    set C(coords,b8) [list 0 0 0 -$r22 $r22 -$r22 $r22 0]
    set C(end,b8) {0 {a0 0 a90 3 a180 2 a270 1}}
    set C(coords,b9) [list 0 0 0 -$r24 $r24 -$r24 $r24 0]
    set C(end,b9) {3 {a0 1 a90 0 a180 3 a270 2}}
}
proc AppendBoard {dx dy} {
    foreach {x y} [lrange $::C(board) end-1 end] break ;# Last point in list
    set x [expr {round(10000 * ($x + $dx)) / 10000.0}]
    set y [expr {round(10000 * ($y + $dy)) / 10000.0}]
    lappend ::C(board) $x $y
}
DoDisplay
DoSounds
if {[expr {rand()}] > .5} { set what Bird } else { set what Boat }
GoPuzzle $what