home *** CD-ROM | disk | FTP | other *** search
/ Chip 1998 March / Chip_1998-03_cd.bin / tema / MINICAD / MC7DEMO / MINICAD.1 / SPURGEAR.MPC < prev    next >
Encoding:
Text File  |  1997-04-30  |  5.5 KB  |  310 lines
  1. Procedure SpurGear;
  2. {
  3. ⌐1997, Diehl Graphsoft, Inc.
  4. Developed by Tom Urie
  5.  
  6. This procedure draws a spur gear.
  7. }
  8. LABEL 20,98,99;
  9.  
  10. CONST
  11.  {
  12. These constants are used to define an approximate involute curve.
  13. }
  14.     f1=0.3966; 
  15.     fx1=0.935;    
  16.     fy1=0.5;     
  17.     fx2=1.105;
  18.     fy2=1.25;
  19.  
  20. VAR
  21.     Alpha,A1,Beta,PDia : REAL;
  22.     a,b,OD,RD,DPitch,r : REAL;
  23.     x0,y0,x0t,y0t : REAL;
  24.     x,y,xt,yt : ARRAY[1..6] OF REAL;
  25.     Theta1,Theta2 : REAL;
  26.  
  27.     j,k,NTeeth,Profile : INTEGER;
  28.     Abort : BOOLEAN;
  29.  
  30. Procedure GearDialog;
  31. {
  32. This procedure defines the dialog box.
  33. }
  34. VAR
  35.     Width,x1,y1,x2,y2,px1,px2,px3,px4,py1,py2,py3,py4 : INTEGER;
  36.  
  37. Procedure AlignScr(Width:INTEGER; VAR x1,x2:INTEGER);
  38. VAR
  39.     scrx1,scry1,scrx2,scry2:INTEGER;
  40. BEGIN
  41.     GetScreen(scrx1,scry1,scrx2,scry2);
  42.     x1:=((scrx1+scrx2) div 2)-(Width div 2);
  43.     x2:=x1+Width; 
  44. END;
  45.  
  46. Procedure LocateButtons3(scnh,scnw : INTEGER);
  47. {
  48. This procedure locates the 'OK' and 'Cancel' buttons stacked on the right side of the dialog box.
  49. }
  50. VAR
  51.     v1,v2,v3,v4 : INTEGER;
  52.  
  53. Procedure Swap(VAR  m1,m2,m3,m4 : INTEGER);
  54. VAR
  55.     Temp : INTEGER;
  56. BEGIN
  57.     Temp:=m1;
  58.     m1:=m3;
  59.     m3:=Temp;
  60.     Temp:=m2;
  61.     m2:=m4;
  62.     m4:=Temp;
  63. END;        {of Swap}
  64.  
  65. BEGIN
  66.     px1:=scnw - 90;
  67.     px2:=scnw - 20;
  68.     px3:=px1;
  69.     px4:=px2;
  70.  
  71.     py1:=scnh -70;
  72.     py2:=scnh - 50;
  73.     py3:=scnh - 40;
  74.     py4:=scnh - 20;
  75.  
  76.     GetVersion(v1,v2,v3,v4);
  77.     IF v4 = 1 THEN SWAP(py1,py2,py3,py4);
  78.  
  79. END;        {of Locate Buttons3}
  80.  
  81. Procedure MakeDialog;
  82. CONST
  83.     y1=100;
  84.     scnh=180;
  85.     scnw=280;
  86.  
  87. VAR
  88.     h : INTEGER;
  89.  
  90. BEGIN
  91.     AlignScr(scnw,x1,x2);
  92.     y2:=y1+scnh;
  93.     LocateButtons3(scnh,scnw);
  94.  
  95.     BeginDialog(1,1,x1,y1,x2,y2);
  96.         AddButton('OK',1,1,px1,py1,px2,py2);
  97.         AddButton('Cancel',2,1,px3,py3,px4,py4);
  98.  
  99.         h:=30;
  100.         AddField('No. of Teeth:',4,1,20,44-h,145,60-h);
  101.         AddField('0',5,2,150,45-h,245,60-h);
  102.  
  103.         AddField('Pitch Diameter:',6,1,20,69-h,145,85-h);
  104.         AddField('0',7,2,150,70-h,245,85-h);
  105.  
  106.         AddField('Diametral Pitch:',8,1,20,94-h,145,110-h);
  107.         AddField('0',9,2,150,95-h,245,110-h);
  108.  
  109.         AddField('Tooth Profile:',10,1,20,119-h,145,135-h);
  110.         AddButton('Straight',11,3,20,140-h,100,155-h);
  111.         AddButton('Involuted',12,3,20,160-h,100,175-h);
  112.     EndDialog;
  113. END;
  114.  
  115. BEGIN
  116.     MakeDialog;
  117. END;
  118.  
  119. Procedure GetInfo;
  120. {
  121. This procedure displays the dialog box and retrieves the information.
  122. }
  123. VAR
  124.     Item : INTEGER;
  125.     Done,Go,Select10,OK : BOOLEAN;
  126.     RFlag : ARRAY[1..2] OF INTEGER;
  127.  
  128. Procedure SetRButton(i,Item : INTEGER);
  129. BEGIN
  130.     IF RFlag[i] <> Item THEN BEGIN
  131.         SetItem(RFlag[i],FALSE);
  132.         SetItem(Item,TRUE);
  133.         RFlag[i]:=Item;
  134.     END;
  135. END;
  136.  
  137. BEGIN
  138.     Done:=FALSE;
  139.     Abort:=FALSE;
  140.     NTeeth:=24;
  141.     PDia:=3;
  142.     DPitch:=8;
  143.     Profile:=1;
  144.     RFlag[1]:=11;
  145.  
  146.     GetDialog(1);
  147.     SetTitle('Spur Gears');
  148.     SetField(5,Num2Str(0,NTeeth));
  149.     SetField(7,Num2Str(4,PDia));
  150.     SetField(9,Num2Str(2,DPitch));
  151.     SetItem(RFlag[1],TRUE);
  152.     SelField(5);
  153.  
  154.     REPEAT
  155.         DialogEvent(Item);
  156.         IF Item = 1 THEN
  157.             Done:=TRUE;
  158.  
  159.         IF Item = 2 THEN
  160.         BEGIN
  161.             Done:=TRUE;
  162.             Abort:=TRUE;
  163.         END;
  164.  
  165.         IF Item = 5 THEN
  166.         BEGIN
  167.             OK:=ValidNumStr(GetField(5),NTeeth);
  168.             IF NOT OK THEN
  169.             BEGIN
  170.                 Sysbeep;
  171.                 SetField(5,Num2Str(0,NTeeth));
  172.                 SelField(5);
  173.             END;
  174.             IF DPitch <> 0 THEN
  175.                 PDia:=NTeeth/DPitch;
  176.             SetField(7,Num2Str(4,PDia));
  177.         END;
  178.  
  179.         IF Item = 7 THEN
  180.         BEGIN
  181.             Go:=ValidNumStr(GetField(7),PDia);
  182.             IF PDia <> 0 THEN
  183.                 DPitch:=NTeeth/PDia;
  184.             SetField(9,num2str(2,DPitch));
  185.         END;
  186.  
  187.         IF Item = 9 THEN
  188.         BEGIN
  189.             Go:=ValidNumStr(GetField(9),DPitch);
  190.             IF DPitch <> 0 THEN
  191.                 PDia:=NTeeth/DPitch;
  192.             SetField(7,Num2Str(4,PDia));
  193.         END;
  194.  
  195.         IF (Item = 11) OR (Item = 12) THEN
  196.         BEGIN
  197.             SetRButton(1,Item);
  198.             Profile:=Item-10;
  199.         END;
  200.  
  201.     UNTIL DONE;
  202.     ClrDialog;
  203. END;
  204.  
  205. BEGIN
  206. {
  207. Main program.
  208. }
  209.  
  210. {
  211. Display the dialog box and get the info.
  212. }
  213.  
  214.     GearDialog;
  215.     SetCursor(ArrowC);
  216.     GetInfo;
  217.     IF Abort THEN GOTO 99;
  218.     DSelectAll;
  219.  
  220. {
  221. Get location of the gear.
  222. }
  223.  
  224.     GetPt(x0,y0);
  225.  
  226. {
  227. Calculate gear parameters.
  228. }
  229.  
  230.     a:=1/DPitch;            {Addendum}
  231.     b:=1.157/DPitch;        {Dedendum}
  232.     OD:=PDia+2*a;        {Outside diameter}
  233.     RD:=PDia-2*b;            {Root diameter}
  234.     r:=1.5*(b-a);            {Root fillet}
  235.     Alpha:=Deg2Rad(360/NTeeth);    {Angle between teeth}
  236.     Beta:=Alpha/4;
  237.     y0:=y0+RD/2;  {Point on the root diameter at Alpha=0}
  238.  
  239. {
  240. Calculate the six points (x[1],y[1]...x[6],y[6]) that define the tooth profile.
  241. }
  242.  
  243.     x[1]:=-PDia*Sin(Beta)/2;
  244.     Theta1:=ArcSin(2*x[1]/RD);
  245.     y[1]:=-RD*(1-Cos(Theta1))/2;
  246.     x[2]:=x[1];
  247.     y[2]:=(PDia*cos(Beta)-RD)/2;
  248.     x[3]:=-f1*OD*Sin(Beta)/2;
  249.     Theta2:=ArcSin(x[3]/PDia);
  250.     y[3]:=(OD*Cos(Theta2)-RD)/2;
  251.  
  252.     IF Profile = 2 THEN
  253.     BEGIN
  254.         x[1]:=fx1*x[1];
  255.         y[1]:=fy1*y[1];
  256.         x[2]:=fx2*x[2];
  257.         y[2]:=fy2*y[2];
  258.         y[3]:=Sqrt((OD/2)^2-x[3]^2)-RD/2;
  259.     END;
  260.  
  261.     x[4]:=-x[3];        y[4]:=y[3];
  262.     x[5]:=-x[2];        y[5]:=y[2];
  263.     x[6]:=-x[1];        y[6]:=y[1];
  264.     A1:=Alpha;
  265.     ClosePoly;
  266.     Absolute;
  267.  
  268. {
  269. Draw the gear.
  270. }
  271.  
  272.     BeginPoly;
  273.     FOR k:= 1 TO NTeeth DO
  274.     BEGIN
  275.         A1:=A1-Alpha;
  276. {
  277. Calculate the coordinates of the point on the root diameter at angle A1.
  278. }
  279.         x0t:=x0+RD*sin(-A1)/2;
  280.         y0t:=y0-RD*(1-cos(-A1))/2;
  281. {
  282. Transpose the 6 defining points of the tooth profile to angle A1.
  283. }
  284.         FOR j:=1 TO 6 DO BEGIN
  285.             xt[j]:=x[j]*Cos(A1)-y[j]*Sin(A1);
  286.             yt[j]:=x[j]*Sin(A1)+y[j]*Cos(A1);
  287. {
  288. Draw straight teeth.
  289. }
  290.             IF Profile = 1 THEN
  291.                 LineTo((x0t+xt[j]),(y0t+yt[j]));
  292.         END;
  293.         IF Profile = 1 THEN GOTO 98;
  294.  
  295. {
  296. Draw involuted teeth.
  297. }
  298.  
  299.         ArcTo((x0t+xt[1]),(y0t+yt[1]),r);
  300.         CurveTo((x0t+xt[2]),(y0t+yt[2]));
  301.         LineTo((x0t+xt[3]),(y0t+yt[3]));
  302.         LineTo((x0t+xt[4]),(y0t+yt[4]));
  303.         CurveTo((x0t+xt[5]),(y0t+yt[5]));
  304.         ArcTo((x0t+xt[6]),(y0t+yt[6]),r);
  305.     98:END;
  306.     EndPoly;
  307.  
  308. 99:END;
  309.  
  310. Run(SpurGear);