-
-
-
-
-
-
-Example by <Richard Suchenwirth> -http://wiki.tcl.tk/1329
-
-
-
-
-translated from Tcl to XOTcl by gustaf neumann in 2001 -
-
- -
-
-translated from XOTcl to NX by gustaf neumann in 2010 -
-
-
-
-
-
-
-
-Left mousebutton starts, middle slows down, right stops
-
-
-
package require Tk -package require nx -package require nx::trait - -nx::Class create Wheel { - :property x - :property y - :property r - :property {spokes 24} - :property {pivot 0} - :property {color red} - :property {tag ""} - - :public method drawSpokes {} { - ::nx::var import [:info parent] c alpha - set delta [expr {360.0 / ${: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 {[info exists :act_pivot]} { - lassign [set :act_pivot] item perc - 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}] - } - } - - :method init {} { - ::nx::var import [:info parent] c alpha - 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] - :drawSpokes - - if {${:pivot}} { - set deg2arc [expr {atan(1.0) * 8 / 360.0}] - 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]] - 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.0}] - $c create oval \ - [expr {${:x} - $rh}] [expr {${:y} - $rh}] \ - [expr {${:x} + $rh}] [expr {${:y} + $rh}] \ - -fill white -tag hub - set :r $r1 - } -} - - -nx::Class create Locomotive { - :property {speed 4} - - :require trait nx::trait::callback - - :method turn {} { - 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 [:info children] { $wheel drawSpokes } - ${:c} raise hub - set xp0 [expr {105 + 15 * sin((${:alpha} - 90) * atan(1.0) * 8 / 360)}] - ${:c} delete piston - ${:c} coords p0 $xp0 120 [expr {$xp0+2}] 122 ;#CW - ${:c} create line 90 121 $xp0 121 -width 2 -fill white -tag piston ;#CW - :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.0}] [expr {rand() * 2 - 2}] - } - } - set t [${:c} create oval [${:c} bbox chimney] -fill white -outline white -tag smoke] - ${:c} move $t 0 -10 - ${:c} lower smoke - } - - :method drawRod {p0 p1 p2 p3} { - ${:c} delete rod - ${:c} create rect [${:c} bbox $p1 $p3] -fill white -tag rod - ${: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 - } - - :public method tick {} { - :turn - foreach i [after info] {after cancel $i} - after 10 [self] tick - } - - :public method throttle {} { - incr :speed 2 - :tick - } - - :public method break {} { - incr :speed -2 - if {${:speed}<0} {set :speed 0} - :tick - } - - :public method emergencyBreak {} { - set :speed 0 - :tick - } - - :method init {} { - set :c [canvas .c -width 600 -height 160 -background lightblue] - pack ${:c} - - bind ${:c} <1> [:callback throttle] - bind ${:c} <2> [:callback break] - bind ${:c} <3> [:callback 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 new -childof [self] -x 50 -y 150 -r 13 -spokes 12 - Wheel new -childof [self] -x 105 -y 150 -r 13 -spokes 12 - Wheel new -childof [self] -x 150 -y 150 -r 30 -pivot 0.5 -tag p1 - Wheel new -childof [self] -x 215 -y 150 -r 30 -pivot 0.5 -tag p2 - Wheel new -childof [self] -x 280 -y 150 -r 30 -pivot 0.5 -tag p3 - :drawRod p0 p1 p2 p3 - Wheel new -childof [self] -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 new -childof [self] -x 395 -y 150 -r 13 -spokes 12 - Wheel new -childof [self] -x 440 -y 150 -r 13 -spokes 12 - ${:c} create rect 380 132 456 142 -fill red - Wheel new -childof [self] -x 495 -y 150 -r 13 -spokes 12 - Wheel new -childof [self] -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 - :tick - } -} - -Locomotive new