##+##########################################################################
#
# spiro.tcl
#
# Draws Epicycloids, hypocycloids, epitrochoids and hypotrochoids.
# by Keith Vetter
#
# Revisions:
# KPV Sep 27, 2002 - initial revision
# KPV Oct 01, 2002 - added epicycle, change font emboldening
#

# 120/60/100/hypo => line
# 120/40/55/hypo  => triangle
# 120/30/40/hypo  => square
# 120/24/30/hypo  => pentagon
# 120/20/25/hypo  => hexagon
# 120/15/22/hypo  => octagon
#
##+##########################################################################
#############################################################################

package require Tk

set sz(w) 600                                   ;# Size of canvas
set sz(h) 600

set epi(draw) 1                                 ;# Checkbutton vars
set epi(clear) 1
set epi(sa) 100                                 ;# Scale vars
set epi(sb) 70
set epi(spct) 100
set epi(stype) epicycloid                       ;# Radiobutton var
set epi(a) 0                                    ;# Working values
set epi(b) 0
set epi(step) 0                                 ;# Animation vars
set epi(stepsize) 5
set epi(after_delay) 20
set epi(color) black
array set epi {
   epicycloid,1 "Cardiod: 1 cusp epicycloid"
   epicycloid,2 "Nephroid: 2 cusp epicycloid"
   epicycloid,5 "Ranunculoid: t cusp epicycloid"
   hypocycloid,2 "Diameter: example of Copernicus's theorem"
   hypocycloid,3 "Deltoid: 3 cusp hypocycloid"
   hypocycloid,4 "Astroid: 4 cusp hypocycloid"
}
##+##########################################################################
#
# DoDisplay
#
# Sets up our GUI
#
proc DoDisplay {} {
   global sz

   wm title . "SpiroGraph"

   pack [frame .top -relief raised -bd 2] -side top -fill x
   pack [frame .bottom] -side bottom -fill x
   pack [frame .bottom.right] -side right -fill y
   pack [frame .bottom.mid] -side right -fill y -expand 1
   pack [frame .screen -bd 2 -relief raised] -side top -fill both -expand 1

   canvas .c -relief raised -bd 2 -wid $::sz(w) -height $::sz(h) -highlightth 0
   label .msg -textvariable epi(msg) -bd 0 -bg white

   set colors {red orange yellow green blue cyan purple violet white}
   lappend colors [.c cget -bg] black
   foreach color $colors {
       radiobutton .top.b$color -width 1 -padx 0 -pady 0 -bg $color \
           -variable epi(color) -value $color
       bind .top.b$color <3> [list .c config -bg $color]
   }
   eval pack [winfo children .top] -side left -fill y

   checkbutton .draw -text "Draw It! " -command NextStep \
       -variable epi(draw) -relief raised -anchor w -bd 8
   .draw configure -font "[font actual [.draw cget -font]] -weight bold"

   checkbutton .auto -text "Auto Clear" -variable epi(clear) \
       -relief raised -anchor w
   button .clear -text Clear -command {Reset 1}
   button .helper -text Help -command Help
   label .type -text "Curve Type" -anchor w
   .type configure -font "[font actual [.type cget -font]] -weight bold"

   frame .types -bd 2 -relief sunken
   radiobutton .epi -text Epicycloid -variable epi(stype) \
       -value epicycloid -anchor w -command NewDimensions
   radiobutton .hypo -text Hypocycloid -variable epi(stype) \
       -value hypocycloid -anchor w -command NewDimensions
   radiobutton .epi2 -text Epicycle -variable epi(stype) \
       -value epicycle -anchor w -command NewDimensions
   scale .inner -orient h -var epi(sa) -from 20 -to 200 \
       -label "Inner Circle" -relief ridge
   scale .outer -orient h -var epi(sb) -from 2 -to 100 \
       -label "Outer Circle" -relief ridge
   scale .h -orient h -var epi(spct) -from 0 -to 500 \
       -label "Outer Radius %" -relief ridge

   pack .c -side top -fill both -expand 1 -in .screen
   pack .msg -side left -fill both -expand 1 -in .screen
   pack .helper -side right -in .top
   pack .inner .outer .h -side left -in .bottom
   pack .draw .auto .clear -side top -in .bottom.right -fill x -padx 1m
   pack config .draw -expand 1 -fill both
   pack .type -side top -in .bottom.mid -fill x
   pack .types -in .bottom.mid -side top -fill both -expand 1
   pack .epi .epi2 .hypo -side top -in .types -fill x -expand 1

   bind Canvas <Button-2> [bind Text <Button-2>]
   bind Canvas <B2-Motion> [bind Text <B2-Motion>]
   bind .c <Alt-c>            [list console show]

   bind .c <Configure> {ReCenter %W %h %w}
   bind .inner <ButtonRelease-1> NewDimensions
   bind .outer <ButtonRelease-1> NewDimensions
   bind .h     <ButtonRelease-1> NewDimensions
   focus .c

}
##+##########################################################################
#
# NewDimensions
#
# Called whenever we change one of the parameters of our curve.
#
proc NewDimensions {} {
   global epi

   ;# Make sure something changed
   if {$epi(a)==$epi(sa) && $epi(b)==$epi(sb) && $epi(pct)==$epi(spct)
       && $epi(stype) == $epi(type)} return

   set epi(draw) 0
   catch {after cancel $epi(after)}
   foreach x {a b pct type} { set epi($x) $epi(s$x) }

   set epi(h)  [expr {$epi(b) * $epi(pct) / 100.0}]
   if {$epi(type) == "epicycloid"} {
       set epi(k1) [expr {double($epi(a) + $epi(b))}]
   } else {
       set epi(k1) [expr {double($epi(a) - $epi(b))}]
   }
   set epi(k2) [expr {$epi(k1) / $epi(b)}]
   if {$epi(type) == "epicycle"} { set epi(k1) $epi(a) }
   set epi(stepsize) [expr {$epi(pct) > 400 ? 1 : $epi(pct) > 200 ? 3 : 5}]

   ;# Figure out when to stop
   set nhits [expr {$epi(a) / [GCD $epi(a) $epi(b)]}] ;# Hitting inner circle
   set hits4rev [expr {double($epi(a)) / $epi(b)}] ;# Hits in one revolution
   set revs [expr {round($nhits / $hits4rev)}]    ;# Total revolutions needed
   set epi(maxstep) [expr {360 * $revs}]

   set type $epi(type)
   if {$epi(pct) != 100} {
       regsub cycloid $type trochoid type
       .epi  config -text Epitrochoid
       .hypo config -text Hypotrochoid
   } else {
       .epi  config -text Epicycloid
       .hypo config -text Hypocycloid
   }
   set epi(msg) "$revs revolutions with $nhits points"
   if {$revs == 1} { regsub revolutions $epi(msg) revolution epi(msg) }

   if {$epi(pct) == 100 && $revs == 1 && $epi(a) >= $epi(b)} {
       if {[info exists epi($epi(type),$nhits)]} {
           set epi(msg) $epi($epi(type),$nhits)
       }
   }
   Reset 0
}
##+##########################################################################
#
# NextStep
#
# Draws one segment of the curve.
#
proc NextStep {{force 0}} {
   global epi

   if {! $force && ! $epi(draw)} return
   .c delete outer
   if {$epi(step) > $epi(maxstep)} {
       .c delete inner
       set epi(draw) 0
       .draw config -state disabled
       return
   }
   set theta [expr {$epi(step) * 3.14159 / 180}]

   set Ox [expr {$epi(k1) * cos($theta)}]      ;# Outer circle's center
   set Oy [expr {$epi(k1) * sin($theta)}]
   set xy [MakeBox $Ox $Oy $epi(b)]

   if {$epi(type) == "epicycloid"} {
       set x1 [expr {$Ox - $epi(h) * cos($epi(k2) * $theta)}]
   } else {
       set x1 [expr {$Ox + $epi(h) * cos($epi(k2) * $theta)}]
   }
   set y1 [expr {$Oy - $epi(h) * sin($epi(k2) * $theta)}]

   if {$epi(step) != 0} {
       foreach {x0 y0} $epi(last) break
       .c create line $x0 $y0 $x1 $y1 -tag {epi curve} -wid 3 -fill $epi(color)
   } else {
       .c create oval -$epi(a) -$epi(a) $epi(a) $epi(a) -fill {} \
           -outline red -tag {epi inner} -width 5
   }
   .c create line 0 0 $Ox $Oy -fill red -tag {epi outer}
   .c create oval $xy -tag {epi outer} -fill {} -outline red -width 5
   .c create line $Ox $Oy $x1 $y1 -fill red -tag {epi outer} -width 5
   .c create oval [MakeBox $x1 $y1 4] -fill $epi(color) -outline $epi(color) \
       -tag {epi outer}
   set epi(last) [list $x1 $y1]
   incr epi(step) $epi(stepsize)

   if {$epi(draw)} {
       set epi(after) [after $epi(after_delay) NextStep]
   }
}
##+##########################################################################
#
# Reset
#
# Resets back to start and optionally clears the screen
#
proc Reset {clear} {
   global epi

   if {$clear || $epi(clear)} {
       .c delete epi                           ;# Delete everything
       set epi(draw) 0
   }
   .c delete inner outer
   set epi(step) 0
   .draw config -state normal
   NextStep 1
}
##+##########################################################################
#
# MakeBox
#
# Returns top left, bottom right of a box centered at x,y
#
proc MakeBox {x y n} {
   set x0 [expr {$x - $n}]
   set y0 [expr {$y - $n}]
   set x1 [expr {$x + $n}]
   set y1 [expr {$y + $n}]
   return [list $x0 $y0 $x1 $y1]
}
##+##########################################################################
#
# Recenter
#
# Called when window gets resized.
#
proc ReCenter {W h w} {
   set h [expr {$h / 2.0}]
   set w [expr {$w / 2.0}]
   $W config -scrollregion [list -$w -$h $w $h]

   set h [expr {-$h * .9}]
   set w [expr {-$w * .9}]
   .c delete title
   .c create text $w $h -anchor nw -font bold -text SpiroGraph -tag title
}
##+##########################################################################
#
# GCD
#
# Euler's algorithm for finding greatest common divisor.
#
proc GCD {a b} {
   while {$b > 0} {
       foreach {a b} [list $b [expr {$a % $b}]] break
   }
   return $a
}
##+##########################################################################
#
# Help
#
# Give very simple help.
#
proc Help {} {
   catch {destroy .help}
   toplevel .help
   wm transient .help .
   wm title .help "SpiroGraph Help"
   if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} {
       wm geom .help "+[expr {$wx+35}]+[expr {$wy+35}]"
   }
   set w .help.t
   text $w -wrap word -width 70 -height 28 -pady 10
   button .help.quit -text Dismiss -command {catch {destroy .help}}
   pack .help.quit -side bottom
   pack $w -side top -fill both -expand 1

   $w tag config header -justify center -font bold -foreground red
   $w tag config header2  -justify center -font bold
   set margin [font measure [$w cget -font] " o "]
   set margin2 [font measure [$w cget -font] " o - "]
   $w tag config bullet -lmargin2 $margin
   $w tag config bullet -font "[font actual [$w cget -font]] -weight bold"
   $w tag config n -lmargin1 $margin -lmargin2 $margin2

   $w insert end "SpiroGraph" header "\nby Keith Vetter\n\n" header2

   $w insert end " o What are these Curves?\n" bullet
   $w insert end "- I remember great fun as a kid playing with spirograph " n
   $w insert end "Then in high school I cut my programming teeth by " n
   $w insert end "writing BASIC programs to draw these curves. " n
   $w insert end "Later I was to learn that these curves are technically " n
   $w insert end "called epicycloids, epitrochoids, hypocycloids and " n
   $w insert end "hypotrochoids.\n\n" n

   $w insert end " o What are Epicycloids and Hypocycloids?\n" bullet
   $w insert end "- An epicycloid is the path traced out by a point " n
   $w insert end "on the edge of a circle rolling on the outsde of " n
   $w insert end "another circle.\n" n
   $w insert end "- A hypocycloid is the same but with the circle rolling " n
   $w insert end "on the inside.\n\n" n

   $w insert end " o What are Epitrochoids and Hypotrochoids?\n" bullet
   $w insert end "- These are similar curves but with the point traced in " n
   $w insert end "not exactly on the outer circle's perimeter.\n\n" n

   $w insert end " o What are Epicycles?\n" bullet
   $w insert end "- A related curve is an epicycle, where the center " n
   $w insert end "of the outer curve follows the perimeter of the " n
   $w insert end "inner curve. Mathematically, this is a less interesting " n
   $w insert end "curve because the outer circle rotation speed is " n
   $w insert end "arbitrary.\n" n
   $w insert end "- Historically, epicycles are famous because they " n
   $w insert end "were a kludge added to the Ptolemic geo-centric solar " n
   $w insert end "system model to explain a planet's retrograde motion " n
   $w insert end "when viewed from the earth.\n\n" n

   $w config -state disabled
}

DoDisplay
NewDimensions
set epi(draw) 1
NextStep