Version 1 of Puzzle Blocks
Updated 2003-05-13 01:00:54Keith Vetter 2003-05-12 : drag, rotate and drop blocks to assemble a bird or a boat.
##+##########################################################################
#
# Puzzle Blocks
# by Keith Vetter, May 9, 2003
# see http://www.si.edu/lemelson/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) "Drag and drop the pieces; right click to rotate"
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 -message "$::S(title)\nby 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} {
.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
}
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