[Richard Suchenwirth] 2002-10-12 - 
This weekend fun project led to yet
another Tcltoy for pre-school toddlers (we have to win the young
generation for Tcl ;-). On the left of the canvas, you have a "mould" with
various building blocks ("bricks"); click on one to get a copy, and drag
it to the right, place it where you like. The laws of gravity don't apply
(yet). Right-clicking on a "brick" mirrors it in x direction (which
currently makes sense with ''slope'' and ''flag'' objects).
Middle-clicking on a "brick" allows you to change its color (use "Cancel"
for transparent). If you change a mould objects's color, it will persist for
the next derived objects. The buttons on the top clear all moved "bricks" (C),
resp. zoom in (+) or out (-).

 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
 }