Updated 2012-10-11 10:06:12 by RLE

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.

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
  .c create rect 151  80  152  60 -fill black  -tag gate1
  .c create rect 135  60  168  40 -fill yellow -tag gate1
  .c create text 151  50  -text "Gate1"        -tag {gate1 txt}
  set isOpen(gate1) 0
  .c bind gate1 <1>  {toggleGate .c gate1}
  bind    .     <F5> {toggleGate .c gate1}

  .c create rect 450  80  453 250 -fill brown  -tag gate2
  .c create rect 451  80  452  60 -fill black  -tag gate2
  .c create rect 435  60  468  40 -fill yellow -tag gate2
  .c create text 451  50  -text "Gate2"        -tag {gate2 txt}
  set isOpen(gate2) 0
  .c bind gate2 <1>  {toggleGate .c gate2}
  bind    .     <F8> {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}
  bind    .      <F6> {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}
  bind    .      <F7> {toggleValve .c valve2r}

  proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}
  proc Cabin {} {
    set c [lpick {red yellow green blue SteelBlue1 magenta}] 
  }
  proc Cargo {} {
    set c [lpick {wheat bisque sienna4 chocolate3 "indian red" goldenrod1 PaleVioletRed1}]
  }

  proc boat {w} {
    $w create poly 10 90 10 77 50 77 50 90    -fill [Cabin] -tag {boat cabin}
    $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 create poly 50 90 90 80 130 90 160 80 200 90\
        -fill [Cargo] -outline black -tag {boat cargo}
    $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
    }
    set T "$tag && txt"
    $w itemconfig $T -text [expr {$isOpen($tag)? "Open": "Close"}]

    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

    # Check if boat has left our view:
    if {$bx0>700} {
        bell  ;# 'New' boat
        .c itemconfig cabin  -fill [Cabin]
        .c itemconfig cargo  -fill [Cargo]
        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} {
        bell  ;# 'New' boat
        .c itemconfig cabin  -fill [Cabin]
        .c itemconfig cargo  -fill [Cargo]
        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
  focus -force .c

  # Test:
  bind . <F1> { wm title . [.c bbox boat] }
  bind . <F2> { console show }

HJG Added more colors for cabin and cargo, signs as pushbuttons above the gates, and some keybindings F5..F8 for operating the gates and valves.

I noticed that the gates can be opened / closed when the ship is only halfway in, and sometimes the boat stops moving just outside the view, which looks like the program hangs.