package require Tk
namespace eval brix {variable version 0.1}
proc brix::ui {w} {
pack [canvas $w -bg grey90] -expand 1 -fill both
$w create rect 0 0 100 1000 -fill grey85
$w create text 110 0 -anchor nw -text Tcl\nBrix \
-font {Helvetica 96} -fill grey95
shape $w lrect turquoise3 50 10
shape $w window lightblue 55 70
shape $w cube yellow 50 40
shape $w door brown 85 40
shape $w roof red 25 75
shape $w slope green3 50 90
shape $w flag blue 15 40
shape $w arch orange 50 135
shape $w man bisque 85 135
shape $w woman purple 15 135
shape $w wheel black 15 170
shape $w bush darkgreen 50 170
$w bind mould <1> {brix::copy %W %x %y}
$w bind mould <2> {brix::paint %W}
$w bind mv <1> {brix::pick %W %x %y}
$w bind mv <2> {brix::paint %W}
$w bind mv <3> {brix::flip %W %x %y}
$w bind mv <B1-Motion> {brix::move %W %x %y}
}
proc brix::shape {w name color x y} {
array set shape {
arch {poly -18 -18 -18 18 -12 18 -12 -5 0 -10 12 -5 12 18 18 18 18 -18}
bush {oval -15 -15 15 15}
cube {rect -18 -18 18 18}
door {rect -6 -14 6 14}
flag {poly -1 15 -1 -15 14 -12 14 -3 1 -5 1 15}
lrect {rect -36 -5 36 5}
man {poly 0 3 -3 12 -7 12 -4 2 -4 -3 -10 3 -12 1
-5 -7 -3 -7 -4 -12 -2 -15 2 -15 4 -12 3 -7
5 -7 12 1 10 3 4 -3 4 2 7 12 3 12}
roof {poly -20 10 0 -10 20 10}
slope {poly -36 18 36 18 36 -18}
wheel {oval -8 -8 8 8}
window {rect -6 -8 6 8}
woman {poly -7 12 -4 2 -4 -3 -10 3 -12 1
-5 -7 -3 -7 -4 -12 -2 -15 2 -15 4 -12 3 -7
5 -7 12 1 10 3 4 -3 4 2 7 12}
}
set id [eval $w create [join $shape($name)] -fill $color \
-outline black -tag mould]
$w move $id $x $y
}
proc brix::copy {w x y} {
$w addtag mv withtag current
$w create [$w type current] [$w coords current] \
-fill [$w itemcget current -fill] -outline black -tag mould
pick $w $x $y
}
proc brix::flip {w x y} {
foreach {x0 y0 x1 y1} [$w bbox current] break
$w scale current [expr ($x0+$x1)/2.] [expr ($y0+$y1)/2.] -1 1
}
proc brix::move {w x y} {
$w dtag current mould
$w move current [expr {$x-$::X}] [expr {$y-$::Y}]
set ::X $x; set ::Y $y
}
proc brix::paint {w} {
set current [$w find withtag current]
$w itemconfig $current -fill [tk_chooseColor]
}
proc brix::pick {w x y} {
$w raise current
set ::X $x; set ::Y $y
}#------------------------------------------------
if {[file tail [info script]] == [file tail $argv0]} { frame .f
button .f.c -text " C " -pady 0 -command {.c delete mv}
button .f.p -text " + " -pady 0 -command {.c scale all 0 0 1.25 1.25}
button .f.m -text " - " -pady 0 -command {.c scale all 0 0 0.8 0.8}
eval pack [winfo children .f] -side left
pack .f -anchor w ;# -fill x
brix::ui .c}
Category Toys - Category Application
