[Keith Vetter] 2008-03-01 : Here's a little animation of a http://en.wikipedia.org/wiki/Scotch_yoke%|%Scotch Yoke%|%, which converts linear motion into rotary motion or vice-versa. [WikiDbImage scotchyoke.jpg] See also [Geneva Drive] and [Gear Animation]. ---- [Jeff Smith] Below is an online demo using [CloudTk] <> <> ---- ---- **Program** ====== ##+########################################################################## # # Scotch Yoke -- Animates a Scotch Yoke # by Keith Vetter, Feb 29, 2008 # # http://www.mekanizmalar.com/scotch_yoke.shtml package require Tk if {! [catch {package require tile}]} { namespace import -force ::ttk::checkbutton } set S(help) { The Scotch Yoke is a mechanism for converting linear motion into rotary motion or vice-versa It has the advantage over a standard crankshaft or connecting rod by having higher torque, fewer moving parts, smoother operation and less time spent at top dead center. On the other hand, it wears out rapidly due to sliding friction and high contact pressures. } array set S {title "Scotch Yoke" w 730 h 400 animate 1 aid "" delay 10} # Gear center set V(gear,r) 120 set V(gear,clr) gray40 # Driving peg set V(peg,r) 30 set V(peg,o) [list 0 [expr {-($V(gear,r) - $V(peg,r))}]] set V(peg,clr) magenta set V(rod,h) 50 set V(rod,w) 540 set V(rod,th) 20 set V(rod,clr) cyan set V(block,sz) {30 110} set V(block,dx) [expr {$V(rod,th) + 5}] set V(block,clr1) \#6c664c set V(block,clr2) \#AC863c proc DoDisplay {} { global S wm title . $S(title) frame .top -bd 2 -relief ridge frame .bottom -bd 0 label .title -text $S(title) -font {Times 42 bold} button .? -text "?" -command About catch {.? config -font "[font actual [.? cget -font]] -weight bold"} checkbutton .anim -variable S(animate) -text Animate -command Animate catch {.anim config -relief ridge -pady 5 -padx 5} canvas .c -width $S(w) -height $S(h) -bd 0 -highlightthickness 0 bind .c {ReCenter %W %h %w} pack .title -in .top -side top -fill x pack .c -in .top -side top -fill both -expand 1 pack .top -side top -fill both -expand 1 pack .bottom -side bottom -fill x -expand 1 pack .anim -in .bottom -side left -expand 1 -pady 10 place .? -in .bottom -relx .99 -rely .5 -anchor e } proc ReCenter {W h w} { ;# Called by configure event set h2 [expr {$h / 2}] ; set w2 [expr {$w / 2}] $W config -scrollregion [list -$w2 -$h2 $w2 $h2] } proc Gears {} { global V S set xy [MakeBox 0 0 $V(gear,r)] .c create oval $xy -fill $V(gear,clr) foreach {x0 y0} $V(peg,o) break set xy [MakeBox $x0 $y0 $V(peg,r)] set xy2 [eval RegularPolygon2 $xy -start 0 -extent 360] .c create polygon $xy2 -tag peg -fill $V(peg,clr) } proc Blocks {} { global V foreach {w h} $V(block,sz) break set dx $V(block,dx) set x1 [expr {$V(gear,r) + $dx}] set x2 [expr {$x1 + $w}] set y1 [expr {-$h/2}] set y2 [expr {-$V(rod,h)/2}] set y3 [expr {$V(rod,h)/2}] set y4 [expr {$h/2}] .c create rect $x1 $y1 $x2 $y2 -fill $V(block,clr1) -tag a .c create rect $x1 $y2 $x2 $y3 -fill $V(block,clr2) -tag b .c create rect $x1 $y3 $x2 $y4 -fill $V(block,clr1) -tag c .c create rect -$x1 $y1 -$x2 $y2 -fill $V(block,clr1) -tag d .c create rect -$x1 $y2 -$x2 $y3 -fill $V(block,clr2) -tag e .c create rect -$x1 $y3 -$x2 $y4 -fill $V(block,clr1) -tag f } proc Rod {} { global V set x1 [expr {$V(rod,w) / 2}] set y1 [expr {$V(rod,h) / 2}] set x2 [expr {$V(peg,r) + $V(rod,th)}] set y2 $y1 set x3 $x2 set y3 [expr {$V(gear,r) + $V(rod,th)}] set x4 [expr {-$x3}] set y4 [expr {$V(gear,r) - 2*$V(peg,r) - $V(rod,th)}] set bottom [RegularPolygon2 $x3 $y3 $x4 $y4 -start 0 -extent 180] set top [RegularPolygon2 $x3 -$y3 $x4 -$y4 -start 180 -extent 180] # outer part set xy1 $bottom lappend xy1 -$x2 $y2 -$x1 $y1 lappend xy1 -$x1 -$y1 -$x2 -$y2 set xy1 [concat $xy1 $top] lappend xy1 $x2 -$y2 $x1 -$y1 lappend xy1 $x1 $y1 $x2 $y2 set xy1 [concat $xy1 [lrange $bottom 0 1]] # inner hole set x5 $V(peg,r) set y5 $V(gear,r) set x6 [expr {-$V(peg,r)}] set y6 [expr {$V(gear,r) - 2*$V(peg,r)}] set bottom [RegularPolygon2 $x5 $y5 $x6 $y6 -start 180 -extent -180] set top [RegularPolygon2 $x5 -$y5 $x6 -$y6 -start 0 -extent -180] set xy2 [concat [lrange $bottom end-1 end] $top $bottom] # exploit winding rule drawing to get hole in the middle set xy [concat $xy1 $xy2] .c create poly $xy -tag rod -fill $V(rod,clr) -outline black # remove porkchop outline remnant set xy [concat [lrange $xy1 0 1] [lrange $xy2 0 1]] .c create line $xy -tag rod -fill $V(rod,clr) } proc MakeBox {x y r} { return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]] } # from http://wiki.tcl.tk/Regular%20Polygons%202 proc RegularPolygon2 {x0 y0 x1 y1 args} { array set V {-sides 0 -start 90 -extent 360} ;# Default values foreach {a value} $args { if {! [info exists V($a)]} {error "unknown option $a"} if {$value == {}} {error "value of \"$a\" missing"} set V($a) $value } if {$V(-extent) == 0} {return {}} set xm [expr {($x0+$x1)/2.}] set ym [expr {($y0+$y1)/2.}] set rx [expr {abs($xm-$x0)}] set ry [expr {abs($ym-$y0)}] set n $V(-sides) if {$n == 0} { ;# 0 sides => circle set n [expr {round(($rx+$ry)*0.5)}] if {$n <= 2} {set n 4} } set dir [expr {$V(-extent) < 0 ? -1 : 1}] ;# Extent can be negative if {abs($V(-extent)) > 360} { set V(-extent) [expr {$dir * (abs($V(-extent)) % 360)}] } set step [expr {$dir * 360.0 / $n}] set numsteps [expr {1 + double($V(-extent)) / $step}] set xy {} set DEG2RAD [expr {acos(-1)*2/360}] for {set i 0} {$i < int($numsteps)} {incr i} { set rad [expr {($V(-start) - $i * $step) * $DEG2RAD}] set x [expr {$rx*cos($rad)}] set y [expr {$ry*sin($rad)}] lappend xy [expr {$xm + $x}] [expr {$ym - $y}] } # Figure out where last segment should end if {$numsteps != int($numsteps)} { # Vecter V1 is last drawn vertext (x,y) from above # Vector V2 is the edge of the polygon set rad2 [expr {($V(-start) - int($numsteps) * $step) * $DEG2RAD}] set x2 [expr {$rx*cos($rad2) - $x}] set y2 [expr {$ry*sin($rad2) - $y}] # Vector V3 is unit vector in direction we end at set rad3 [expr {($V(-start) - $V(-extent)) * $DEG2RAD}] set x3 [expr {cos($rad3)}] set y3 [expr {sin($rad3)}] # Find where V3 crosses V1+V2 => find j s.t. V1 + kV2 = jV3 set j [expr {($x*$y2 - $x2*$y) / ($x3*$y2 - $x2*$y3)}] lappend xy [expr {$xm + $j * $x3}] [expr {$ym - $j * $y3}] } return $xy } # From http://wiki.tcl.tk/CanvasRotation proc RotateItem {w tagOrId Ox Oy angle} { set angle [expr {$angle * atan(1) * 4 / 180.0}] ;# Radians foreach id [$w find withtag $tagOrId] { ;# Do each component separately set xy {} foreach {x y} [$w coords $id] { # rotates vector (Ox,Oy)->(x,y) by angle clockwise set x [expr {$x - $Ox}] ;# Shift to origin set y [expr {$y - $Oy}] set xx [expr {$x * cos($angle) - $y * sin($angle)}] ;# Rotate set yy [expr {$x * sin($angle) + $y * cos($angle)}] set xx [expr {$xx + $Ox}] ;# Shift back set yy [expr {$yy + $Oy}] lappend xy $xx $yy } $w coords $id $xy } } proc About {} { set msg "$::S(title)\nby Keith Vetter, February 2008\n$::S(help)" tk_messageBox -message $msg -title "About $::S(title)" } proc Animate {} { after cancel $::S(aid) StepIt 1 if {$::S(animate)} { set ::S(aid) [after $::S(delay) Animate] } } proc StepIt {dir} { global S V set x1 [lindex [.c bbox peg] 0] RotateItem .c peg 0 0 $dir set x2 [lindex [.c bbox peg] 0] set dx [expr {$x2 - $x1}] .c move rod $dx 0 } DoDisplay Gears Rod Blocks if {$S(animate)} Animate return ====== ---- !!!!!! %| [Category Animation] | [Category Application] | [Category Graphics] | [Category Toys] |% !!!!!!