Version 3 of Puzzle Blocks

Updated 2003-05-13 03:29:03

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?


http://mini.net/sdarchive/puzzleblocks.jpg


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

Category Application | Category Whizzlet