Version 5 of The Montana, Utah & Texas

if 0 {Richard Suchenwirth 2005-04-30 - The M.U. & Tex. Railroad is a simple visualisation of mutex, or mutually exclusive semaphores (nl: seinpalen [L1 ]) that control the works of concurrent processes, which are here displayed as "trains" (longish rectangles, rather).

The railway has two semaphores, A and B. A train may only pass a semaphore if given the green light. To make sure there's always at most one train on the line between A and B, a semaphore is turned to red when a train passes it - it "obtains a mutex lock" on the semaphore. This operation is called P (nl: passeren, "pass"; or "prolaag" which I can't explain) in mutex theory.

When the train leaves the protected block, at semaphore B, it "releases the lock" on A, so that is turned green again - the V operation (nl: vrijgeven, "release"; or "verhoog"). And of course it obtains a lock on B to prevent collisions :) }

 proc main {} {
    set w [canvas .c -width 700 -height 100]
    pack $w -fill both -expand 1
    $w create line 0 80 700 80
    semaphore A $w 100 80
    turn A red
    $w create text 120 90 -text "P(A)"
    semaphore B $w 600 80
    turn B green
    $w create text 630 90 -text "P(B); V(A)"
    train $w 200 80
    train $w -500 80
    every 100 [list animate $w]
 }
 proc semaphore {name w x y} {
    global g
    $w create line $x $y $x [- $y 30] -width 2
    $w create rect [- $x 5] [- $y 30] [+ $x 5] [- $y 50] -fill black
    set g($name,top) [lamp $w $x [- $y 45]]
    set g($name,bot) [lamp $w $x [- $y 35]]
    set g($name,x) $x
    lappend g(semaphores) $name
    $w create rect [- $x 5] [- $y 10] [+ $x 5] [- $y 25] -fill white
    $w create text $x [- $y 18] -text $name
    set g(w) $w
 }
 proc lamp {w x y} {
    $w create oval [- $x 4] [- $y 4] [+ $x 4] [+ $y 4]
 }
 proc train {w x y} {
    set color [lpick {brown gray50 orange bisque}]
    $w create rect $x $y [+ $x 250] [- $y 30] -fill $color -tag train
    $w lower train
 }

if 0 {This routine is called in fixed time intervals}

 proc animate w {
    foreach train [$w find withtag train] {
        set xmax [lindex [$w bbox $train] 2]
        if {$xmax > 1200} {
            $w delete $train
            train $w -200 80 
            V B
        }
        if [semaphoreAhead $xmax name] {
            if {$::g($name,state) eq "red"} continue
            after 500 [list P $name]
            if {$name eq "B"} {after 2500 {V A}}
        }
        $w move $train [expr {rand()*5+10}] 0
    }
 }

#-- Returns 1 if a semaphore is ahead, and gives its name in a variable

 proc semaphoreAhead {xmax _var} {
    upvar 1 $_var var
    foreach sema $::g(semaphores) {
        set dx [- $::g($sema,x) $xmax]
        if {$dx > 0 && $dx < 30} {set var $sema; return 1}
    }
    return 0
 }

#-- Dijkstra's classic mutex operations are very simple here:

 proc P name {turn $name red}

 proc V name {turn $name green}

 proc turn {name color} {
    if {$color eq "red"} {
        set c1 red; set c2 black
    } else {
        set c1 black; set c2 green
    }
    $::g(w) itemconfig $::g($name,top) -fill $c1
    $::g(w) itemconfig $::g($name,bot) -fill $c2
    set ::g($name,state) $color
 }

#-- Generally useful routines: prefix math, etc.

 foreach op {+ - * /} {proc $op {a b} "expr {\$a $op \$b}"}
 proc every {ms body} {eval $body; after $ms [info level 0]}
 proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}

#-- Let's go!

 main

#-- Very useful development helper:

 bind . <Escape> {exec wish $argv0 &; exit}

if 0 {

Category Toys - Arts and crafts of Tcl-Tk programming }