'=======================================================================
' Generate an involute spur gear from an ideal rack or hob.
' only the general situation without correction of undercut is modeled
'=======================================================================
Dim As Double MM = 3.5 ' MM = 25.4 / DP
Dim As Double PA = 20. ' pressure angle in degrees
Dim As Integer n = 57 '19. ' number of teeth
'=======================================================================
Const As Double Pi = 4 * Atn(1)
Const As Double DtoR = Atn(1) / 45
Dim As Double PD = n * MM ' pitch diameter
Dim As Double BD = PD * Cos(PA * DtoR) ' base diameter
Dim As Double ad = 1.00 * MM ' addendum
Dim As Double dd = 1.25 * MM ' dedendum
Dim As Double OD = PD + 2.00 * MM ' outside diameter
Dim As Double RD = PD - 2.50 * MM ' root diameter
Dim As Double CP = Pi * PD / n ' circular pitch
Dim As Double min = 2/Sin(PA*DtoR)^2 ' minimum n without undercut
Dim As Double BL = 0.04 * MM ' recommended backlash
'=======================================================================
Print Using " ##.## metric module" ; MM
Print Using " ####.# pressure angle in degrees"; PA
Print Using " ##### number of teeth" ; n
Print Using "####.### pitch diameter" ; PD
Print Using "####.### base diameter" ; BD
Print Using "####.### addendum" ; ad
Print Using "####.### dedendum" ; dd
Print Using "####.### outside diameter" ; OD
Print Using "####.### root diameter" ; RD
Print Using "####.### circular pitch" ; CP
Print Using "####.### undercut limit" ; min
Print Using "####.### backlash" ; BL ' half to each gear ?
If min > n Then Print " WARNING: generated teeth will be undercut. "
'=======================================================================
Dim As Double Rp = PD * 0.5 ' pitch radius
Dim As Double Ra = OD * 0.5 ' outer tip radius, Rp + addendum
Dim As Double Rb = BD * 0.5 ' base radius
Dim As Double Rr = RD * 0.5 ' root radius
'-----------------------------------------------------------------------
' find gamma of the pitch point
Dim As Double t = Sqr(Rp*Rp - Rb*Rb) / Rb ' pitch point parametric value
Dim As Double ux = Cos(t)
Dim As Double uy = Sin(t)
Dim As Double px = Rb * ( ux + t * uy )
Dim As Double py = Rb * ( uy - t * ux )
print using "gamma for pitch point is##.### "; Atn(py/px) / DtoR
print using "pitch point x=###.### y=###.###"; px; py
' Circle(px, py), .27, 13,,,,F
dim as double tooth = 2 * Pi / n
print using "Each tooth is###.### degrees"; tooth * 180 / Pi
for r as double = Rb to Ra + 1e-6 step (Ra - Rb) / 15 ' n+1 points
Dim As Double t = Sqr(r*r - Rb*Rb) / Rb
Dim As Double ux = Cos(t)
Dim As Double uy = Sin(t)
Dim As Double px = Rb * ( ux + t * uy )
Dim As Double py = Rb * ( uy - t * ux )
print px, py
next r
'=======================================================================
Screenres 1000, 1000, 4
' Window (0.4*Ra, -Ra/2) - (1.2*Ra, Ra/2)
Window (0.4*Ra, -Ra/4) - (1.2*Ra, Ra/4)
Line (-2, 0)-(Ra, 0), 6
Line ( 0,-2)-( 0, 2), 6
'-----------------------------------------------------------------------
' Line ( Ra,-3)-( Ra, 3), 6
'Circle (0,0), Ra, 6
'Circle (0,0), Rp, 6
'Circle (0,0), Rb, 6
'Circle (0,0), Rr, 6
' draw all reference circles
For t As Double = 0 To 2 * Pi Step Pi * .01 / Ra
Dim As Double ux = Cos(t)
Dim As Double uy = Sin(t)
Pset ( Rr*ux, Rr*uy), 7
Pset ( Rp*ux, Rp*uy), 7
Pset ( Rb*ux, Rb*uy), 7
Pset ( Ra*ux, Ra*uy), 7
Next t
'-----------------------------------------------------------------------
Draw String (Rr, 0.2), " Root" , 7
Draw String (Rb, -.1), " Base" , 7
Draw String (Rp, 0.2), " Pitch", 7
Draw String (Ra, -.1), " Tip" , 7
'=======================================================================
' draw the tooth profile
' x = Rb * Cos(a) + a * Sin(a)
' y = Rb * Sin(a) - a * Cos(a)
Dim As Integer k = 14
Dim As Double Ta = Sqr(Ra*Ra - Rb*Rb) / Rb ' T at involute crossing addendum
Dim As Double Tp = Sqr(Rp*Rp - Rb*Rb) / Rb ' T at pitch point on involute
For t As Double = 0 To Ta Step .001 ' t is the parametric variable
Dim As Double ux = Cos(t)
Dim As Double uy = Sin(t)
Dim As Double px = Rb * ( ux + t * uy )
Dim As Double py = Rb * ( uy - t * ux )
If t > Tp Then k = 13
Pset(px, py), k
Next t
'-----------------------------------------------------------------------
pset (Rb, 0), 0
for r as double = Rb to Ra + 1e-6 step (Ra - Rb) / 15 ' n+1 points
Dim As Double t = Sqr(r*r - Rb*Rb) / Rb
Dim As Double ux = Cos(t)
Dim As Double uy = Sin(t)
Dim As Double px = Rb * ( ux + t * uy )
Dim As Double py = Rb * ( uy - t * ux )
line -(px, py), 15
Circle(px, py), .07, 13,,,,F
next r
'=======================================================================
Sleep
'=======================================================================
