http://invention.smithsonian.org/centerpieces/iap/playhouse_puzzle.html

##+##########################################################################
#
# 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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References