[Richard Suchenwirth] - 2002-09-22 - A sluice (a.k.a. locks) is a rather
large device to bridge elevation differences in waterways - rivers or
channels. Here is a educational Tcltoy where you can control the valves
and gates of a little sluice (by just clicking on them) - they either react,
or the reason why they don't is displayed at bottom. 
For instance, gates can only be opened if the water level is equal on both sides; 
valves can only be opened if gates are closed.

[http://mini.net/files/sluice.jpg]

Little freight boats, heavily laden with sand, ply the river's waves up and
down. The (for adults, not very challenging) task is to help them go
up- resp. downriver. - This (delayed) weekend fun project let me learn
more about Tk, mostly about the ''-stipple'' attribute (which gives
nice semi-transparency), but also how difficult it can be to get a
simple idea implemented in a sort of robust way...
}
----
 wm title . "sluice simulator"
 pack [label .info -textvar info -anchor w] -side bottom -fill x
 set info "Welcome to the sluice simulation! (Hint: open the right valve)"
 pack [canvas .c -width 600 -height 280 -bg lightblue]
 .c create polygon 0 300  0 90  450 90  600 120  600 300 -fill green3
 .c create polygon 140 300 140 80 460 80 460 300 -fill grey
 .c create polygon 150 250 150 80 450 80 450 250 -fill grey60
 .c create rect 150 80 153 150 -fill brown -tag gate1
 set isOpen(gate1) 0
 .c bind gate1 <1> {toggleGate .c gate1}
 .c create rect 450 80 453 250 -fill brown -tag gate2
 set isOpen(gate2) 0
 .c bind gate2 <1> {toggleGate .c gate2}
 .c create polygon 0 152 0 100 150 100 150 152 -fill blue1\
    -tag {water upriver} -stipple gray50
 .c create polygon 452 250 452 200 600 200 600 250 -fill blue1 \
    -stipple gray50 -tag {water downriver}
 .c create polygon 150 100 150 250 452 250 452 100 -fill blue1 \
    -tag {water sluicewater sluiced} -stipple gray50
 .c create line 90 150 90 160 100 170 150 170 -width 5 -fill blue1 \
    -smooth 1 -tag water
 .c create polygon 140 290 140 250 460 250 460 290 -fill grey -tag water
 .c create oval 110 160 130 180 -fill white -tag {valve1 water}
 .c create rect 118 160 122 180 -fill grey -tag {valve1 valve1r water}
 set isOpen(valve1r) 0
 .c bind valve1 <1> {toggleValve .c valve1r}
 .c create line 420 250 420 260 430 270 480 270 490 265 490 250 \
    -width 5 -fill blue1 -smooth 1 -tag fg
 .c create oval 450 260 470 280 -fill white -tag valve2
 .c create rect 458 260 462 280 -fill grey -tag {valve2 valve2r}
 set isOpen(valve2r) 0
 .c bind valve2 <1> {toggleValve .c valve2r}
 
 proc boat {w} {
    $w create poly 10 90 10 77 50 77 50 90 -fill red -tag boat
    $w create rect 8 78 52 75  -fill grey -tag boat
    $w create rect 13 86 23 79 -fill white -tag boat
    $w create rect 28 86 38 79 -fill white -tag boat
    $w create poly 0 90  0 95  203 95  205 90 -fill white -tag boat
    $w create poly 0 95  0 125  5 130  200 130  203 95 \
        -fill black -tag boat
    $w create poly 50 90 90 80 130 90 160 80 200 90\
        -fill bisque -outline black -tag boat
    $w move boat 160 0
    $w lower boat water
    set ::moveBoat 0
    set ::boatDirection 1
 }
 boat .c
 proc toggleGate {w tag} {
    global info isOpen moveBoat boatDirection
    if { $tag=="gate1" && [maxy $w sluicewater]>[maxy $w upriver] \
       ||$tag=="gate2" && [maxy $w sluicewater]<[maxy $w downriver]} {
           set info "Can't open gate - water not level"
           return
    }
    foreach {x0 y0 x1 y1} [$w coords $tag] break
    set x0 [expr {$x0 + ($isOpen($tag)? 50 : -50)}]
    $w coords $tag $x0 $y0 $x1 $y1
    set isOpen($tag) [expr {1-$isOpen($tag)}]
    set info "$tag [expr {$isOpen($tag)? {opened} : {closed}}]"
    foreach {bx0 by0 bx1 by1} [$w bbox boat] break
    if {$bx1<100*$boatDirection || $bx0<460*$boatDirection} {
        set moveBoat 0
    }
    if {$isOpen($tag)} {set moveBoat [expr $boatDirection*2]}
 }
 proc toggleValve {w tag} {
    global isOpen
    if {!$isOpen($tag) && ($isOpen(gate1) || $isOpen(gate2))} {
        set ::info "Can't open valve when gate still open"
        return
    }
    foreach {x0 y0 x1 y1} [$w coords $tag] break
    set dx2 [expr {($x1-$x0)/2.}]
    set mx  [expr {($x0+$x1)/2}]
    set dy2 [expr {($y1-$y0)/2.}]
    set my  [expr {($y0+$y1)/2}]
    set isOpen($tag) [expr {$dx2<$dy2}]
    $w itemconfig $tag -fill [expr {$isOpen($tag)? "blue1": "grey"}] 
    $w coords $tag [expr {$mx-$dy2}] [expr {$my-$dx2}] \
                 [expr {$mx+$dy2}] [expr {$my+$dx2}]
    set ::info "$tag [expr {$::isOpen($tag)? {opened} : {closed}}]"
 }
 proc every {ms body} {eval $body; after $ms [info level 0]}
 proc maxy {w tag} {lindex [$w bbox $tag] 1}
 proc animate {w} {
    global moveBoat isOpen
    foreach {bx0 by0 bx1 by1} [$w bbox boat]        break
    foreach {sx0 top sx1 sy1} [$w bbox sluicewater] break
    if {$bx0 > $sx0 && $bx1 < $sx1} {
        $w addtag sluiced withtag boat
        if {$bx1>390 && $bx0<460 && $moveBoat>0 && !$isOpen(gate2)} {
            set moveBoat 0
        }
        if {$bx0<160 && $bx1>90 && $moveBoat<0 && !$isOpen(gate1)} {
            set moveBoat 0
        }
    } else {
        $w dtag boat sluiced
        if {$bx0<470 && $bx0>150 && $moveBoat<0 && !$isOpen(gate2) \
          || $bx1>100 && $bx1<450 && $moveBoat>0 && !$isOpen(gate1)} {
            set moveBoat 0
        }
    }
    if {$top<[maxy $w downriver] && $isOpen(valve2r)} {
        $w move sluiced 0 1
        set moveBoat 0
    }
    if {$top>[maxy $w upriver] && $isOpen(valve1r)} {
        $w move sluiced 0 -1
        set moveBoat 0
    }
    $w move boat $moveBoat 0
    if {$bx0>700} {
        if {rand()>0.5} {
            $w scale boat [expr {($bx0+$bx1)/2}] $by0 -1 1
            set moveBoat -2; set ::boatDirection -1
        } else {$w move boat -1000 -100}
    }
    if {$bx0<-300} {
        if {rand()>0.5} {
            $w scale boat [expr {($bx0+$bx1)/2}] $by0 -1 1
            set moveBoat 2; set ::boatDirection 1
        } else {$w move boat 1000 100}
    }
 }
 every 100 {animate .c}
 wm resizable . 0 0
----
[HJG] I noticed that the gates can be opened / closed when the ship is only halfway in.

----
[Category Animation] | [Category Toys] | [Model railroading with Tcl] | [Arts and crafts of Tcl-Tk programming]