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.}]
        if {[balance'move $w $delta 24]} {
            set wt(angle) [+ $wt(angle) $delta]
            after 100 [list after idle [list rebalance $w]]
        }
    } else {
        #set delta [expr {[sgn $wt(angle)]*-0.05}]
        set delta [expr {$wt(angle)/-20.}]
        if {abs($wt(angle))>0.0000001} {
            balance'move $w $delta 24
            set wt(angle) [+ $wt(angle) $delta]
            after 100 [list after idle [list rebalance $w]]
        }
    }
}

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 add variable ::$var write "$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
}