#!/usr/bin/wish

package require Tk
pack [canvas .c -bg white -width 300 -height 300]\
 -expand yes -fill both

namespace import ::tcl::mathop::* ::tcl::mathfunc::*

variable pi [acos -1]

proc drawGeometry {} {
  .c create line 10 150 290 150\
    -fill green -width 5 -tags geometry
}

proc gearwheelCoords {x y r num {alpha 0}} {
  variable pi
  set 2pi [* 2 $pi]
  set toothLength 12
  set rI [- $r $toothLength]
  set rO [+ $r $toothLength]
  set phi [/ $2pi $num]
  for {set i 0} {$i < $num} {incr i} {
    if {$i % 2 != 0} then {
      set rC $rI
    } else {
      set rC $rO
    }
    lappend coords\
      [+ $x [* $rC [cos [+ $alpha [* $i $phi]]]]]\
      [+ $y [* $rC [sin [+ $alpha [* $i $phi]]]]]
  }
  set coords
}

set outerGearCoords [gearwheelCoords 150 150 104 52]
set innerGearCoords [gearwheelCoords 200 150 52 26]

.c delete all
.c create oval 20 20 280 280 -fill silver -tags outer -width 0
.c create polygon $outerGearCoords\
  -fill white -width 0 -smooth yes -tags outer
.c create polygon $innerGearCoords\
  -fill grey90 -width 0 -smooth yes -tags inner
drawGeometry
.c create oval 240 140 260 160 -fill "" -outline red -width 3\
  -tags crankpin

proc setInnerGear alpha {
  set radius 50
  lassign {150 150 50} sunX sunY orbit
  set xC [+ $sunX [* $orbit [cos $alpha]]]
  set yC [+ $sunY [* $orbit [sin $alpha]]]
  .c coords inner\
    [gearwheelCoords $xC $yC 50 26 [* $alpha -1]]
  set dx [* [cos [- $alpha]] $radius]
  set dy [* [sin [- $alpha]] $radius]
  set x [+ $xC $dx]
  set y [+ $yC $dy]
  .c coords crankpin [- $x 10] [- $y 10] [+ $x 10] [+ $y 10]
}

variable alpha 0

proc step {} {
  variable alpha
  set alpha [+ $alpha 0.01]
  setInnerGear $alpha
  after 50 step
}

# main

step