[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://tcl.tk/starkits/puzzleblocks.jpg] ---- [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. [vetter_PuzzleBlocks_boat_screenshot_635x550.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 ====== <> Application | Whizzlet