if 0 {[Richard Suchenwirth] 2004-09-29 - Yet another educational
Tcltoy: here's a balance simulation on a [canvas].
A ''beam balance'' is a tool for measuring weight:
on a "rig" lays a crossbar, from which two "plates" are suspended.
When one plate carries more weight than the other, it goes down;
only if both plates are equally weighed, the crossbar is horizontal
(and the pointer attached to it is vertical).
(Please correct my terms - I'm just making them up... ;)
[SRIV] The crossbar is called the ''beam'', the plates are called (and are in fact) ''pans''.
Speaking as a licensed scale technician, your rendering of the scale is quite accurate.
Looks like I found a secret anti-gravity mode http://server.linuxsys.net/images/scale.png.

[http://mini.net/files/balance.gif]

On the left you have some colorful objects, on the right a set of
weights of supposedly 100, 50, or 10 grams, to be told apart by their
size. When you drag an object or weight over a plate of the balance, it
drops down. By adding weights left or right, you can try to "balance the
balance". Not very challenging for adults (especially as the weight sums
are displayed at the bottom), but maybe fun for young kids. Hit <Escape>
to reset the whole thing.
}
 package require Tk

 proc balance'ui {} {
    global wt
     set width 100
    .c create poly [mirror'x {0 0 -5 5 -15 140 -60 150 -62 160}] \
        -fill green4 -outline darkgreen ;# rig
    .c create poly -$width 0 -$width -5 $width -5 $width 0 \
        -tag {cross bar} -fill green3 -outline green4
    .c create line 0 -10 0 140 -width 3 -fill yellow \
        -arrow last -tag bar ;# pointer
    .c create poly 0 142 -5 150 5 150 -fill yellow
    set w2 35
    ctextvar .c -100 180 wt(left)
    ctextvar .c  100 180 wt(right)
    #-- lines and plates
    foreach tag {left right} x [list -$width $width] {
        set wt($tag) 0
        .c create line $x 0 $x 80 -tag [list $tag @$tag]
        .c create line [+ $x -$w2] 130 $x 80 [+ $x $w2] 130 -tag $tag
        .c create rect [+ $x -$w2] 130 [+ $x $w2] 136 \
            -tag [list $tag plate-$tag] -fill yellow 
    }
    set wt(angle) 0.0
    set wt([.c create rect -170 -20 -140 0 -fill red -tag mv]) 130
    set wt([.c create rect -165 20 -145 40 -fill green -tag mv]) 90
    set wt([.c create rect -170 50 -150 80 -fill blue -tag mv]) 100
    foreach x {120 150 180} {weight .c 100 $x 20 -tag mv}
    foreach x {120 140 160 180} {weight .c 50 $x 50 -tag mv}
    foreach x {120 135 150 165 180} {weight .c 10 $x 70 -tag mv}
     .c bind mv <1>               {move'start %W %x %y}
     .c bind mv <B1-Motion>       {move %W %x %y}
     .c bind mv <ButtonRelease-1> {balance'drop %W}
     .c config -scrollregion {-180 -50 180 50}
 }
 proc balance'move {w angle maxy} {
    foreach {x0 y0 - - - - x1 y1} [$w coords cross] break
    if {($angle>0 && $y0>=$maxy) || ($angle<0 && $y1>=$maxy)} {
        return 0
    }
    rotate $w bar $angle
    foreach {x0 y0 - - - - x1 y1} [$w coords cross] break
    foreach {x y} [$w coords @left] break
    $w move left [- $x0 $x] [- $y0 $y]
    foreach {x y} [$w coords @right] break
    $w move right [- $x1 $x] [- $y1 $y]
    return 1
 }
 proc rebalance w {
    global wt
    set difference [- $wt(left) $wt(right)]
    if $difference {
        #set delta [expr {[sgn $difference]*0.05}]
        set delta [expr {$difference/1000.}]
        while {[balance'move $w $delta 24]} {
            after 100
            update
            set wt(angle) [+ $wt(angle) $delta]
        }
    } else {
        #set delta [expr {[sgn $wt(angle)]*-0.05}]
        set delta [expr {$wt(angle)/-20.}]
        while {abs($wt(angle))>0.0000001} {
            balance'move $w $delta 24
            after 100
            update
            set wt(angle) [+ $wt(angle) $delta]
        }
    }
 }
if 0 {This routine is called when the mouse button is released after
dragging an object - if applicable, it moves it to the plate it is over,
and recomputes the balance:}
 proc balance'drop w {
    global wt
    set item [$w find withtag current]
    if {$item eq ""} return
    foreach tag {left right} {$w dtag $item $tag}
    foreach {x0 y0 x1 y1} [$w bbox $item] break
    set found 0
    foreach side {left right} {
        foreach {px0 py0 px1 py1} [$w bbox plate-$side] break
        if {$x0>=$px0 && $x1<=$px1 && $y1>$py0-30} {
            $w move $item 0 [+ [- $py0 $y1] 2]
            $w addtag $side withtag $item
            incr wt($side) $wt($item)
            set wt(@$item) $side
            rebalance $w
            set found 1
            break
        }
    }
    if !$found {rebalance $w}
 }
if 0 {Construct a weight-like polygon, given its weight in grammes:}
 proc weight {w weight x y args} {
    set sqw [expr {pow($weight,1/3.)}]
    set y1 [expr {$y-$sqw*3}]
    set y3 [expr {$y-$sqw*5}]
    set y2 [expr {($y1+$y3)/2.}]
    set dx [expr {$sqw*2}]
    set x0 [+ $x $dx]
    set x1 [expr $x+$dx/3.]
    set x2 [expr $x+$dx*2/3.]
    set c [mirror'x [list $x0 $y $x0 $y1 $x1 $y1 $x2 $y2 $x1 $y3] $x]
    set id [eval [list $w create poly $c] $args]
    set ::wt($id) $weight
 }

#-- Generically useful canvas routines:
 proc rotate {w tag angle {xm 0} {ym 0}} {
    foreach item [$w find withtag $tag] {
        set coords {}
        foreach {x y} [$w coords $item] {
            set r [expr {hypot($y-$ym,$x-$xm)}]
            set a [expr {atan2($y-$ym,$x-$xm)-$angle}]
            lappend coords [expr {$xm+$r*cos($a)}] \
                [expr {$ym+$r*sin($a)}]
        }
        $w coords $item $coords
    }
 }
 proc move'start {w x y} {
    global X Y wt
    set X [$w canvasx $x]
    set Y [$w canvasy $y]
    set item [$w find withtag current]
    if [info exists wt(@$item)] {
        incr wt($wt(@$item)) -$wt($item)
        unset wt(@$item)
    }
 }
 proc move {w x y} {
    set dx [- [$w canvasx $x] $::X]
    set dy [- [$w canvasy $y] $::Y]
    $w move current $dx $dy
    set ::X [+ $::X $dx]
    set ::Y [+ $::Y $dy]
 }
if 0 {This routine makes design of symmetric polygons easier - given a
half contour, it adds the corresponding coordinates mirrored parallel to
the x axis:}
 proc mirror'x {coords {xm 0}} {
    set last [- [llength $coords] 2]
    for {set i $last} {$i>=0} {incr i -2} {
        set x [lindex $coords $i]
        set dx [- $xm $x]
        set y [lindex $coords [+ $i 1]]
        lappend coords [+ $xm $dx] $y
    }
    set coords
 }
if 0 {Create a text item on a canvas, whose text reflects the value of a
given global variable:}
 proc ctextvar {w x y var} {
    set item [$w create text $x $y -text ?]
    trace var ::$var w "$w itemconfig $item -text \$::$var ;#"
 }
 
#-- Little math helpers: 
 proc + {a b} {expr {$a + $b}}
 proc - {a b} {expr {$a - $b}}
 proc sgn x {expr {($x>0)-($x<0)}}
 
#-- Now for the UI proper: 
 if ![winfo exists .c] {
     pack [canvas .c -width 380 -height 270] -expand 1
 } else {.c delete all}
 balance'ui

#-- Little dev helpers (optional)
 bind . <Escape>  [list source [info script]]
 bind . <F1>      {console show}
 bind . <F2> {
    package req Img
    [image create photo -data .c] write balance.gif
 }
if 0 {
----
[SS] 30Sep2004: Great Richard! That's the best toy on the Wiki IMHO,
and children not yet able to read can play trying to figure what's the weight of colored objects.
It may be cool if the movement speed is proportional to the difference of the weights, I'll try to do it if
I found some spare time and inspiration. Maybe some oscillation before the stabilization can also be interesting :)

[RS]: Proportional speed is now implemented, see the new "set delta ..." lines in proc rebalance. Oscillation still missing.
----
[Category Toys] | [Arts and crafts of Tcl-Tk programming]
}