Updated 2014-01-22 18:19:44 by AK

* A Toy Pump Controller *

A toy "device control" application

Summary  edit

A little demo to illustrate controlling of several "pumps" by concurrent programming, making use of Tcl's event loop. The pumps are included in the package.

Pics  edit

... or it didn't happen. Mmh -- OK, here's one of the contraption in action:

A Standard Model pump:

A Grizzly Model pump:

The Controller

The standard pump is stopped, the Grizzly is running. I resisted the temptation to upload animated GIFs ;-)

Global operation  edit

The whole package consists of two separate programs: the pump and the controller.

The Pump  edit

The pump simulates a stylized pump with some blades, and listens to a network connection at some configurable port. You can start one like so:
./pump standard p003 10000

The first argument is a model name for the pump. We support three models: standard grizzly and squirrel. The second is an identifier (an arbitrary string with no whitespace in it) and the third a TCP port to listen on.

Once someone connects to the pump, it can send commands. The pumps support three commands: START starts the pump, STOP stops it, and STATUS answers with three words: the identifier, the model and either RUNNING or STOPPED, depending on which state the pump is in.

Commands to the pump are always in capital letters (call that nostalgia, if you wish).

You can try it by telnetting to the above port, like so:
[email protected]:~/tcltk/control$ ./pump standard p003 10000 &
[1] 4231
[email protected]:~/tcltk/control$ telnet localhost 10000
Connected to localhost.
Escape character is '^]'.
p003 standard  STOPPED
p003 standard  RUNNING
telnet> quit
Connection closed.

After closing the connection the pump stays in the last state and you can re-connect and send more commands. While connected to the pump, it won't accept more connections.

The Controller  edit

This one doesn't take arguments. If you start it by itself, it just shows a blank window.

In the background, though, it tries to connect to pumps at localhost in a given port range (fixed in the program, from 10000 to 10009). Whenever it gets a connection, it request the pump's state, and if successful, it opens a new row showing the model, identifier and port, and also a radio button to start and stop the pump (pre-set corresponding to the result of the STATUS inquiry).

You can start new pump instances (listening to a port within range) and the corresponding lines in the controller will appear. Likewise, if you terminate a pump instance (by closing its window), the corresponding line in the controller will disappear.

If you start two controller instances they will fight for the available pumps. Since a pump only will accept one connection (modulo bugs?), only one controller will get hold of a given pump.

If you terminate a controller, "its" pumps will stay in their last state, waiting for a new controller to pick them up.

* The Code * Here it goes. Enjoy.

As a general note, there are many global variables around. In a Real World Application (TM), we would strive to tuck them away (either in namespaces or by using some OO framework (itcl, TclOO, there are many excellent ones to choose from). Otherwise the code will tend to evolve into an unmaintainable mess.

The Pump  edit

# usage pump <model name> <id> <port>

if {[llength $argv] != 3} {
  puts stderr "usage: pump <model name> <id> <port>"
  exit 1

lassign $argv model id port

switch -exact -- $model {
  grizzly {
    set size 100.0 ;# pixels
    set nblades 4 ;# ideally a divisor of nsteps
    set nbsteps 20 ;# steps per blade
    set dir 1 ;# 1: clockwise; -1 counter-clockwise
    set tick 100 ;# ms/step
    set color blue
  squirrel {
    set size 40.0 ;# pixels
    set nblades 2 ;# ideally a divisor of nsteps
    set nbsteps 8 ;# steps per blade
    set dir -1 ;# 1: clockwise; -1 counter-clockwise
    set tick 75 ;# ms/step
    set color red
  standard {
    set size 60.0 ;# pixels
    set nblades 3 ;# ideally a divisor of nsteps
    set nbsteps 12 ;# steps per blade
    set dir 1 ;# 1: clockwise; -1 counter-clockwise
    set tick 80 ;# ms/step
    set color black
  default {
    puts stderr "bad model: must be one of \
                  grizzly squirrel standard"
    exit 1;

set nsteps [expr {$nblades * $nbsteps}]
set radius [expr {$size / 2}]
set twopi [expr {2 * 3.14159265378979323}]
# angle steps in radians:
set astep [expr {$twopi / $nsteps}]
# blade tip coords for all positions:
for {set alpha 0} {$alpha < $twopi} {set alpha [expr {$alpha + $astep}]} {
  lappend posn [list [expr {$radius * (1.0 + cos($alpha))}] \
                     [expr {$radius * (1.0 + $dir*sin($alpha))}]]

set canv [canvas .c -width $size -height $size]
pack $canv
$canv create oval 0 0 $size $size

set pos 0 ;# start

proc draw {} {
  global pos canv posn radius nsteps nbsteps color
  set i $pos
  $canv delete blade
  for {set i $pos} {$i < $nsteps} {incr i $nbsteps} {
    $canv create line [concat $radius $radius [lindex $posn $i]] -fill $color -width 3 -tag blade

proc spin {} {
  global pos nbsteps tick spinner
  # pos goes from 0 to $nbsteps - 1 then starts over at 0:
  set pos [expr {[incr pos] % $nbsteps}] ;# next "tick"
  # schedule next step after $tick ms, keep timer id around
  set spinner [after $tick spin]

proc listen {} {
  global listener port
  set listener [socket -server serve $port]

proc serve {chan cli port} {
  global listener
  close $listener ;# don't accept more connections
  fconfigure $chan -blocking 0
  fileevent $chan readable [list readsome $chan]

proc readsome {chan} {
  global id model spinner
  # data available
  if {[eof $chan]} {
    catch {close $chan}
    listen ;# ready for new connections
  set cmd [gets $chan] ;# gets never blocks, gets us whole line
  switch -exact -- $cmd {
    START -
    STOP {
      if {[info exists spinner]} {
        after cancel $spinner
        unset spinner
      if {$cmd eq "START"} spin
    STATUS {
      puts $chan "$id $model \
                   [expr {[info exists spinner] ? {RUNNING} : {STOPPED}}]"
      flush $chan


How it works

At start the switch sets some parameters depending on the model -- those will determine the appearance (size, number of blades, rotation speed etc.).

For convenience, the rotational positions of the blade tips are pre-calculated in the list $posn. The global variable $pos tracks at which position the rotation of the pump currently is.

The procedure [draw] draws the pump blades at the position $pos. It deletes the blades at the old position, which have been tagged with the tag blade at draw time, so they can be addressed collectively by this name.

The procedure spin advances this position and invokes a redraw. Then it schedules itself to run after the time given by the global variable $tick. It notes the timer id in the global variable $spinner, which makes us able to stop the pending timer and thus stop the rotation.

This is already an example of concurrency: while rotation is going on (which only needs our attention for one redraw every $tick milliseconds) the whole channel machinery is listening, accepting and carrying out commands.

The three procedures [listen], [serve] and [readsome] handle incoming connections. Note that [serve] closes the listening channel, thus disabling new connections whenever one has been accepted (there might be a race condition here). Whenever the current connection is closed on us ([eof $chan]), we listen again.

See also A Simple Fan Animation for a more fancy ummm... fan.

The Controller  edit


# range of TCP ports to look for pumps (on $host)
# including first, excluding last
set host localhost ;# watch out for blocking DNS!
set portrange {10000 10010}
set scantime 50 ;# scan next port after $scantime ms

set activeports [dict create] ;# indexed by port number

proc bgerror {err} {puts "BGERROR: $err"}

proc scanport {} {
  global activeports portrange host scantime thisport
  # try thisport; connect if there
  if {![info exists thisport] || $thisport >= [lindex $portrange 1]} {
    set thisport [lindex $portrange 0]

  if {![dict exists $activeports $thisport]} {
    # not active: poke at it
    if {![catch {
      set sock [socket -async $host $thisport]
    }]} {
      # readable will be called also on failure: we handle this there:
      fileevent $sock writable [list newpump $sock $thisport]
      dict set activeports $thisport 1 ;# tentatively
  incr thisport
  after $scantime scanport

proc newpump {sock port} {
  global activeports
  # possibly a new pump at $sock?
  if {[fconfigure $sock -error] ne {}} {
    # FIXME: handle "other" errors. We assume here "connection refused",
    # i.e. "nobody there"
    dict unset activeports $port
    close $sock
  fileevent $sock writable [list init1pump $sock $port]

proc init1pump {sock port} {
  ctrlpump $sock $port STATUS
  fileevent $sock readable [list init2pump $sock $port]
  fileevent $sock writable {}

proc init2pump {sock port} {
  lassign [regexp -all -inline {\w+} [gets $sock]] id model status
  puts "new pump: $id $model $status"
  fileevent $sock readable [list rdready $sock $port]
  pumpwidget_create $sock $port $id $model $status

proc rdready {sock port} {
  global activeports
  # our pumps don't talk much; but they might go away,
  # that puts us here too
  set err [fconfigure $sock -error]
  # FIXME: handle "other" errors.
  #  We just assume here $sock went away, i.e. "nobody there"
  if {$err ne {} || [eof $sock]} {
    dict unset activeports $port
    close $sock
    pumpwidget_delete $sock $port
  # Unexpected: pump is yelling at us:
  puts "pump at $port says [gets $sock]"

proc ctrlpump {sock port command} {
  # we can write right away to sock; Tcl buffers for us
  # downside: we don't know when things succeed
  puts $sock $command
  flush $sock

proc pumpwidget_create {sock port id model status} {
  # create a "pump widget"
  # to avoid collissions: name each frame after the port attached to it
  switch -exact -- $status {
      set curstate START
      set curstate STOP
    default {
      # Any other value causes *both* buttons to be pushable:
      set curstate UNKNOWN

  set fr [frame .f$port]
  pack [label $fr.lab -text "pump $id/$model at $port"] \
      -side left -anchor w
  set ::state($port) $curstate
  foreach cmd {STOP START} {
    pack [radiobutton $fr.b$cmd -text $cmd -indicatoron 0 \
              -command [list ctrlpump $sock $port $cmd] \
              -relief flat -value $cmd -variable ::state($port)] \
        -side right -anchor e
  pack $fr -side top -fill x

proc pumpwidget_delete {sock port} {
  # delete a "pump widget"
  destroy .f$port

How it works

As a constant "background task" there is [scanport]. It goes through all the ports in the pre-defined port range and tries to connect. To allow for other things to happen, it just tries one port for every invocation, increments $thisport and reschedules itself. This is a typical strategy for explicitly concurrent programs: break up long-running things into small steps and leave holes in them for the scheduler to go about other businesses.

The group of procedures [newpump], [init1pump] and [init2pump] handle the connection to a new pump, querying its state, accepting its answer and setting up a controller widget for it. They form already a rudimentary state automaton; it's easy to see that we will need a better organizational principle when protocols become more complex (as is the case in Real Life). Some form of explicit state automaton or coroutines may save us from a Big Mess here.

The procedure [rdready] is there to catch unexpected things the pump may say to us (our pumps don't do that!) and more importantly, to notice when the socket gets closed (our side signals that as a readable channel with the eof condition set). General communication errors should land here too.

Much state is kept either in global variables (e.g. the array $state($sock) or in the widgets themselves (cf. the radio button command, which knows which $socket is its own).

One obvious enhancement would be to ditch the button's command and coordinate things via the $state($sock) variable by adding a trace to it. This way, we could control things "from behind", by setting this variable to an appropriate value (thus making timed schedules very simple).

arjen - 2014-01-22 10:16:56

Nice demonstration - it gave me an idea to build a sort of game server. Now all I need is the time and energy to actually write the thing ;).