Updated 2008-10-29 06:25:03 by Stu

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 (-).
 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