[Keith Vetter] 2003-05-12 : drag, rotate and drop blocks to assemble
a bird or a boat.

[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]