[Xotcl] Railroad example in XOTcl

[Gustaf Neumann]

 Here is a small fun-example of a Tk program translated to XOTcl.
 Start it with xowish

enjoy
-gustaf
=====================================================================================
 #!/usr/local/bin/xowish
# Example by <Richard Suchenwirth> translated from Tcl to XOTcl by gustaf neumann
# Left mousebutton starts, middle slows down, right stops 
package require XOTcl

Class Wheel -parameter {r x y {spokes 24} {pivot 0} {color red} {tag ""}}
Wheel instproc drawSpokes {} {
  [[self] info parent] instvar c alpha
  [self] instvar W color spokes r x y
  set delta [expr {360./$spokes}]
  set deg2arc [expr {atan(1.0)*8/360.}]
  for {set i 0} {$i<$spokes} {incr i} {
    set x1 [expr {$x+cos($deg2arc*$alpha)*$r}]
    set y1 [expr {$y+sin($deg2arc*$alpha)*$r}]
    $c create line $x $y $x1 $y1 -fill $color -tag spoke
    set alpha [expr {$alpha+$delta}]
  }
  if {[[self] exists act_pivot]} {
    foreach {item perc} [[self] set act_pivot] break
    set rp [expr {$r*$perc}]
    set xp [expr {$x-$rp*cos($deg2arc*$alpha)}]
    set yp [expr {$y-$rp*sin($deg2arc*$alpha)}]
    $c coords $item $xp $yp [expr {$xp+1}] [expr {$yp+1}]
  }
}
Wheel instproc init {} {
  [[self] info parent] instvar c alpha
  [self] instvar pivot color tag W r x y
  set alpha 0.
  set y [expr {$y-$r}]
  $c create oval [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}] \
      -outline white
  set r1 [expr {$r-2}]
  set W [$c create oval [expr {$x-$r1}] [expr {$y-$r1}] [expr {$x+$r1}] \
	     [expr {$y+$r1}] -outline $color -width 2]
  [self] drawSpokes

  if {$pivot} {
    set deg2arc [expr {atan(1.0)*8/360.}]
    set rp [expr {$r1*$pivot}]
    set xp [expr {$x-$rp*cos($deg2arc*$alpha)}]
    set yp [expr {$y-$rp*sin($deg2arc*$alpha)}]
    set new_pivot [$c create rect $xp $yp \
		       [expr {$xp+1}] [expr {$yp+1}] -fill $color \
		       -tag  [list $tag pivot]]
    [self] set act_pivot [list $new_pivot $pivot]
     
    $c create arc [expr {$x-$r1}] [expr {$y-$r1}]\
	[expr {$x+$r1}] [expr {$y+$r1}] \
	-style chord -fill $color -start 310\
	-extent 80 -tag counterweight
    set pivot $new_pivot
  }
  set rh [expr {$r/12.}]
  $c create oval [expr {$x-$rh}] [expr {$y-$rh}] [expr {$x+$rh}] \
      [expr {$y+$rh}] -fill white -tag hub
  set r $r1
}

Class Railroad -parameter {{speed 4}}
Railroad instproc turn {} {
  [self] instvar c alpha speed
  set alpha [expr {round($alpha+360-$speed)%360}]
  foreach i [$c find withtag counterweight] {
    $c itemconfig $i -start [expr {310-$alpha}]
  }
  $c delete spoke
  foreach wheel [[self] info children] { $wheel drawSpokes }
  $c raise hub
  set xp0 [expr {105+15*sin(($alpha-90)*atan(1.0)*8/360)}]
  $c delete piston
  eval $c coords p0 $xp0 120 [expr {$xp0+2}] 122 ;#CW
  $c create line 90 121 $xp0 121 -width 2 -fill white -tag piston ;#CW
  [self] drawRod p0 p1 p2 p3
  $c raise p0
  foreach i [$c find withtag smoke] {
    if {[lindex [$c bbox $i] 3]<0} {
      $c delete $i
    } else {
      $c move $i [expr {rand()*$speed/3.}] [expr {rand()*2-2}]
    }
  }
  set t [eval $c create oval [$c bbox chimney] -fill white -outline white -tag smoke]
  $c move $t 0 -10
  $c lower smoke
}
Railroad instproc drawRod {p0 p1 p2 p3} {
  [self] instvar c
  $c delete rod
  eval $c create rect [$c bbox $p1 $p3] -fill white -tag rod
  eval $c create line [lrange [$c bbox $p0] 0 1] \
      [lrange [$c bbox $p2] 0 1] -width 3 -fill white -tag rod
  $c raise rod
  $c raise pivot
}
Railroad instproc tick {} {
  [self] turn
  foreach i [after info] {after cancel $i}
  after 10 [self] tick
}
Railroad instproc throttle {} {
  [self] incr speed 6
  [self] tick
}
Railroad instproc break {} {
  [self] incr speed -2
  if {[[self] set speed]<0} {[self] set speed 0}
  [self] tick
}
Railroad instproc emergencyBreak {} {
  [self] set speed 0
  [self] tick
}

Railroad instproc init {} {
  [self] instvar c
  set c [canvas .c -width 600 -height 160 -background lightblue]
  pack $c

  bind $c <1> [list [self] throttle]
  bind $c <2> [list [self] break]
  bind $c <3> [list [self] emergencyBreak]

  $c delete all
  $c create rect 32 115 360 125 -fill black ;# frame
  $c create rect 22 118 32 122 -fill grey30 ;# buffer
  $c create line 22 115 22 125
  $c create poly 60 95 40 115 50 115 70 95 -fill black
  $c create rect 60 45 310 95 -fill grey25  ;# boiler
  $c create oval 55 50 65 90 -fill black ;# smokebox
  $c create rect 70 32 85 50 -fill black -tag chimney
  $c create rect 40 52 90 75 -fill black ;# wind diverter
  $c create oval 130 36 150 52 -fill black ;# dome
  $c create rect 195 35 215 50 -fill black ;# sandbox
  $c create oval 260 36 280 52 -fill black ;# dome
  $c create rect 65 100 90 135 -fill black ;# cylinder
  $c create rect 90 120 92 122 -fill red -tag p0 ;# crossbar
  $c create rect 72 87 82 100 -fill black ;# steam tube
  $c create rect 310 40 370 115 -fill black ;# cab
  $c create rect 310 32 390 42 -fill grey30 ;# cab roof
  $c create text 338 82 -text "01 234" -fill gold -font {Times 7}
  $c create rect 318 48 333 66 -fill white ;# cab window #1
  $c create rect 338 48 355 66 -fill white ;# cab window #2
  Wheel newChild -x  50 -y 150 -r 13 -spokes 12
  Wheel newChild -x 105 -y 150 -r 13 -spokes 12
  Wheel newChild -x 150 -y 150 -r 30 -pivot 0.5 -tag p1
  Wheel newChild -x 215 -y 150 -r 30 -pivot 0.5 -tag p2
  Wheel newChild -x 280 -y 150 -r 30 -pivot 0.5 -tag p3
  [self] drawRod p0 p1 p2 p3
  Wheel newChild -x 340 -y 150 -r 16 -spokes 12
  $c create rect 360 110 380 118 -fill black
  $c create rect 380  65 560 125 -fill black -tag tender
  $c create rect 560 118 570 122 -fill grey30 ;# buffer
  $c create line 571 116 571 125
  $c create rect 390 45 525 65 -fill black -tag tender
  Wheel newChild -x 395 -y 150 -r 13 -spokes 12
  Wheel newChild -x 440 -y 150 -r 13 -spokes 12
  $c create rect 380 132 456 142 -fill red
  Wheel newChild -x 495 -y 150 -r 13 -spokes 12
  Wheel newChild -x 540 -y 150 -r 13 -spokes 12
  $c create rect 480 132 556 142 -fill red -outline red
  $c create rect 0 150 600 160 -fill brown ;# earth
  $c create line 0 150 600 150 -fill grey -width 2 ;# rail
  [self] tick
}

Railroad r