... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... Welcome!!! Links: free ringtones : [http://www.ringtones-dir.com download ringtones] - [HTTP://www.ringtones-dir.com download ringtones] : [nokia ringtones|http://www.ringtones-dir.com] - [nokia ringtones|HTTP://www.ringtones-dir.com] : http://www.ringtones-dir.com/download/ : [[http://www.ringtones-dir.com ring tones]] : [[http://www.ringtones-dir.com | ringtones download]] : "samsung ringtones" http://www.ringtones-dir.com : [http://www.ringtones-dir.com|ringtones free] [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]
----
[http://mini.net/sdarchive/puzzleblocks.jpg]
----
##+##########################################################################
#
# 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 {console show}
bind .c {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 [list Mouse1 $who %x %y 0]
.c bind $who [list Mouse1 $who %x %y 1]
.c bind $who [list Mouse1 $who %x %y 2]
.c bind $who [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
----
[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
----
[Category Application] | [Category Whizzlet]