path: root/graphics/pstricks/contrib/pst-spirograph/dvips/pst-spirograph.pro

%% $Id: pst-spirograph.pro 1160 2020-03-14 14:08:31Z herbert $
%%
% PostScript prologue for pst-spirograph.tex.
%
% Version 0.51, 2020/03/14 
%
/tx@spirographDict 50 dict def 
tx@spirographDict begin
/coorPen {
  1 dict begin
    /t exch def
    r2 qi t cos mul ki qi t mul 60 ni mul sub cos mul add mul cm
    r2 qi t sin mul ki qi t mul 60 ni mul sub sin mul sub mul cm
  end
} def
/coorPen2 {
  1 dict begin
    /t exch def
    r2 qi2 t cos mul ki qi2 t mul 60 ni mul neg 180 Z2 div sub sub cos mul sub mul cm
    r2 qi2 t sin mul ki qi2 t mul 60 ni mul neg 180 Z2 div sub sub sin mul sub mul cm
  end
} def
/Datas1 {
  /Z@ exch def
  /m@ exch def
  /R@ { m@ Z@ mul 2 div } bind def % cercle primitif
  /Rb { R@ ap cos mul } bind def % cercle de base
  /Rp { R@ 2 mul 2.5 m@ mul sub 2 div } bind def % cercle de pied
  /Rt { R@ 2 mul 2 m@ mul add 2 div } bind def % cercle de tète
} def
/Datas2 {
  /Z@ exch def
  /m@ exch def
  /R@ { m@ Z@ mul 2 div } bind def % cercle primitif
  /Rb { R@ ap cos mul } bind def % cercle de base
  /Rp { R@ 2 mul 2 m@ mul sub 2 div } bind def % cercle de pied
  /Rt { R@ 2 mul 2.5 m@ mul add 2 div } bind def % cercle de tète
} def
/Calculs { % les valeurs suivantes sont en radians
  /ThetaP {R@ Rb div dup mul 1 sub sqrt } bind def % intersection avec cercle primitif
  /ThetaT {Rt Rb div dup mul 1 sub sqrt } bind def % intersection avec cercle de tete
  % Les valeurs suivantes ont en degrés
  /ThetaTdeg {Rt Rb div dup mul 1 sub sqrt RadtoDeg } bind def %
  /ThetaPdeg {R@ Rb div dup mul 1 sub sqrt RadtoDeg } bind def
  /DeltaP {ThetaPdeg sin ThetaP ThetaPdeg cos mul sub
           ThetaPdeg cos ThetaP ThetaPdeg sin mul add atan } bind def
  /DeltaT {ThetaTdeg sin ThetaT ThetaTdeg cos mul sub
           ThetaTdeg cos ThetaT ThetaTdeg sin mul add atan } bind def
  /DeltaS {Pi 2 div Z@ div } bind def
  /DeltaSdeg {90 Z@ div } bind def
  /AngleDent {360 Z@ div} bind def
  /Alpha {DeltaSdeg DeltaP add DeltaT sub } bind def
  /2Beta {DeltaSdeg DeltaP add 2 mul } bind def
  /Beta_  {DeltaSdeg DeltaP add neg} bind def
  /ptA { Rp cm 0} bind def
  /ptB { Rb cm 0} bind def
  /ptC { Rp cm DeltaSdeg 2 mul neg 2Beta 2 div add cos mul
         Rp cm DeltaSdeg 2 mul neg 2Beta 2 div add sin mul} bind def
  /ptA'{ Rp cm DeltaP DeltaSdeg add 2 mul cos mul
         Rp cm DeltaP DeltaSdeg add 2 mul sin mul} bind def
  /ptB'{ Rb cm DeltaP DeltaSdeg add 2 mul cos mul
         Rb cm DeltaP DeltaSdeg add 2 mul sin mul} bind def
  /ptC'{ Rp cm DeltaSdeg 3 mul DeltaP add cos mul
         Rp cm DeltaSdeg 3 mul DeltaP add sin mul} bind def
  /Raxe { Rp 4 div } bind def
  /A@0 14.5 def % position et largeur de la clavette
  % rayon de raccordement sur le cercle de pied
  /Rarct {Rp Pi mul Z@ div 12 div cm} bind def
} def
% Le symetrique P' de P par rapport a la l'axe de la dent
% Delta(axe de la dent) y=x*tan(Beta)
% x'=y*sin(2*Beta)+x*cos(2*Beta)
% y'=x*sin(2*Beta)-y*cos(2*Beta)
% x y symAxe -> x' y'
/symAxe {
 2 dict begin
  /y exch def
  /x exch def
  y 2Beta sin mul x 2Beta cos mul add % x'
  x 2Beta sin mul y 2Beta cos mul sub % y'
 end
} def
 %
% Rotation pour amener l'axe de la dent horizontal
%
/RotDent {
  2 dict begin
    /y exch def
    /x exch def
    i@ cos x mul i@ sin y mul sub
    i@ sin x mul i@ cos y mul add
  end
} def
% developpante du cercle de base
%
/Circles {
  gsave
  setlinedash
  newpath
  0 0 R@ cm 0 360 arc
  closepath
  circlescolor
  stroke
  % on ne dessine pas le cercle de base
  %newpath
  %0 0 Rb cm 0 360 arc
  %closepath
  %stroke
  grestore
} def
%
% trace des cercles
/devCercle {
  1 dict begin
  /t exch def % en degres
  Rb t cos t DegtoRad t sin mul add mul cm % x
  Rb t sin t DegtoRad t cos mul sub mul cm % y
 end
} def
%%
%%%% definition de la roue dentee %%%%%%
/Roue {
  % arc de développante
  /tabArcDev [ 0 1 ThetaTdeg { /i@ exch def [i@ devCercle] } for ] def
  /n@ tabArcDev length def
% l'arc de developpante initial
  /tabDent [ tabArcDev aload pop
% l'arc ce cercle de tete
     DeltaT 0.1 2Beta DeltaT sub {/i@ exch def
     [Rt cm i@ cos mul Rt cm i@ sin mul] } for
% le symetrique de l'arc de developpante par rapport a l'axe de la dent
  n@ 1 sub -1 0 { /compteur exch def [tabArcDev compteur get aload pop symAxe] } for ] def
% trace de la dent
  /n2@ tabDent length def
  newpath
  ptC moveto
  0 1 Z@ 1 sub {
    /i@ exch AngleDent mul def
    ifinner {
      wheel 2 eq { ptA RotDent ptB RotDent Rarct arct ptB RotDent lineto }
                 { ptA RotDent lineto ptB RotDent lineto } ifelse
    }{
      Rp Rb eq { ptA RotDent lineto ptB RotDent lineto }
               { ptA RotDent ptB RotDent Rarct arct ptB RotDent lineto } ifelse
    } ifelse
    0 1 n2@ 1 sub {
      /compteur exch def
      tabDent compteur get aload pop
      RotDent lineto 
    } for
    ifinner {
      wheel 2 eq {
       Rp Rb eq 
         { ptA' RotDent lineto ptC' RotDent lineto }
         { ptA' RotDent ptC' RotDent Rarct arct ptC' RotDent lineto } ifelse
      }{ ptA' RotDent lineto ptC' RotDent lineto } ifelse
    }{
      Rp Rb eq 
        { ptA' RotDent lineto ptC' RotDent lineto }
        { ptA' RotDent ptC' RotDent Rarct arct ptC' RotDent lineto } ifelse
    } ifelse
  } for
} def
%
% pour l'engrenage interieur
/COURONNE { 0 0 Rt 1.1 mul cm 360 0 arcn } def
%
/trous {
  1 dict begin
    /a@ { R@ cm 3 div Pi div } bind def
    gsave
    positionAngular rotate
    0 60 540 {
      /THETA exch def
      untrou
      1 setgray iffill { Fill } if
      untrou
      linecolor
      stroke
    } for
    grestore
  end
} def
%
/untrou {
  newpath
  a@ THETA DegtoRad mul THETA cos mul neg
  a@ THETA DegtoRad mul THETA sin mul
  0.05 cm 0 360 arc
  closepath
} def
%
%%%%%%%%%% Roue No 1 %%%%%%%%%%%%%%%%%
/Roue1 {
  1 dict begin
  /wheel 1 def
  gsave
  t@@x t@@y translate
  m1 Z1
  ifinner {
    Datas2
    Calculs
    Beta_ rotate
    Roue
    COURONNE
    closepath
    iffill { color1 Fill } if
    Roue
    closepath
    linecolor
    stroke
    COURONNE
    closepath
    linecolor
    stroke
    ifcircles { Circles } if
  }{
    Datas1
    Calculs
    Beta_ rotate
    Roue
    closepath
    iffill { color1 Fill } if
    Roue
    closepath
    linecolor
    stroke
    ifcircles { Circles } if
  } ifelse
  grestore
  % dessin de l'hypocycloide ou de l'epicycloide
  gsave
  t@@x t@@y translate
  ifinner {
    tabSpirograph 0 get aload pop moveto
    1 1 nPts {
      /nP exch def
      tabSpirograph nP get aload pop lineto
    } for
  }{
    tabSpirograph2 0 get aload pop moveto
    1 1 nPts2 {
      /nP exch def
      tabSpirograph2 nP get aload pop lineto
    } for
  } ifelse 
  curvecolor
  SetCurveWidth
  stroke
  grestore
  end
} def
%%%%%%%%%% Roue No 2 %%%%%%%%%%%%%%%%%
/Roue2 {
  5 dict begin
  /wheel 2 def
  gsave
  m2 Z2 Datas1
  Calculs
  /a@ex m2 Z1 Z2 add mul 2 div cm def % entraxe engrenage exterieur
  /a@in m2 Z1 Z2 sub mul 2 div cm def % entraxe engrenage interieur
  /a@ {R@ cm 3 div 3.14159 div} bind def
  ifinner{
    a@in polarAngle cos mul t@@x add a@in polarAngle sin mul t@@y add translate
    Beta_ polarAngle Z1 Z2 sub Z2 div mul sub rotate
    /positionAngular 2Beta 2 div def
  }{
    a@ex polarAngle cos mul t@@x add a@ex polarAngle sin mul t@@y add translate
    DeltaSdeg DeltaP add neg 180 Z2 div add 180 add polarAngle Z1 Z2 add Z2 div mul add rotate
    /positionAngular Beta_ neg def
  } ifelse
  Roue
  closepath
  iffill { color2 Fill } if
  Roue
  closepath
  linecolor
  stroke
  trous
  ifcircles { Circles } if
  grestore
  gsave
  newpath
  ifinner {
    a@in polarAngle cos mul t@@x add a@in polarAngle sin mul t@@y add translate
    Beta_ polarAngle Z1 Z2 sub Z2 div mul sub rotate
    /THETA 540 ni 60 mul sub def
    positionAngular rotate
    a@ THETA DegtoRad mul THETA cos mul neg
    a@ THETA DegtoRad mul THETA sin mul
    0.12 cm 0 360 arc
  }{
     a@ex polarAngle cos mul t@@x add a@ex polarAngle sin mul t@@y add translate
    DeltaSdeg DeltaP add neg 180 Z2 div add 180 add polarAngle Z1 Z2 add Z2 div mul add rotate
    /a@ {R@ cm 3 div 3.14159 div} bind def
    /THETA 540 ni 60 mul sub def
    positionAngular rotate
    a@ THETA DegtoRad mul THETA cos mul neg
    a@ THETA DegtoRad mul THETA sin mul
    0.12 cm 0 360 arc
  } ifelse
  closepath
  curvecolor
  fill
  grestore
  end
} def
      /Roue3 {
      % arc de développante
        /tabArcDev [ 0 1 ThetaTdeg { /i@ exch def [i@ devCercle] } for ] def
        /n@ tabArcDev length def
        /tabDent [
	      % l'arc de developpante initial
	  	  tabArcDev aload pop
	      % l'arc ce cercle de tete
	      DeltaT 0.1 2Beta DeltaT sub {/i@ exch def [Rt cm i@ cos mul Rt cm i@ sin mul] } for
          % le symetrique de l'arc de developpante par rapport a l'axe de la dent
	      n@ 1 sub -1 0  { /compteur exch def [tabArcDev compteur get aload pop symAxe] } for
        ] def
        % tracé de la dent
        /n2@ tabDent length def
        newpath
        ptC moveto
        0 1 Z@ 1 sub { /i@ exch AngleDent mul def
          wheel 2 eq { ptA RotDent ptB RotDent Rarct arct ptB RotDent lineto }
                     { ptA RotDent lineto ptB RotDent lineto } ifelse
          0 1 n2@ 1 sub { /compteur exch def tabDent compteur get aload pop RotDent lineto } for
    	  wheel 2 eq {
	    Rp Rb eq { ptA' RotDent lineto ptC' RotDent lineto }
	             { ptA' RotDent ptC' RotDent Rarct arct ptC' RotDent lineto } ifelse
          } { ptA' RotDent lineto ptC' RotDent lineto } ifelse
        } for
      } def
      %%%% fin de la definition de la roue dentee %%%
      /plaquette {
        Beta_ neg rotate
        /alpha1 1 R1 2 mul atan 2 div def
        /alpha2 1 R1 2 mul 2 m1 mul sub 2 div atan 2 div def
        /xR1 R1 2 mul cm def
        /yR1 0.5 cm def
        /xR2 R1 2 mul cm def
        /yR2 -0.5 cm def
        /xR3 R1 2 mul 2 m1 mul sub 2 div R1 2 div sub cm def
        /yR3 -0.5 cm def
        /xR4 R1 2 mul 2 m1 mul sub 2 div R1 2 div sub cm def
        /yR4 0.5 cm def
	newpath
        xR1 yR1 moveto
        xR2 yR2 lineto
        xR3 yR3 lineto
        xR4 yR4 lineto
	closepath
	iffill { color1 Fill } if
	newpath
        xR1 yR1 moveto
        xR2 yR2 lineto
        xR3 yR3 lineto
        xR4 yR4 lineto
	closepath
	linecolor
	stroke
      } def
      /drawHole {
	R1 cm HolePos mul 0 GetCurveWidth 1.5 mul 0 360 arc
	curvecolor
	fill
	0 setgray
	R1 cm HolePos mul 0 GetCurveWidth 1.5 mul 0 360 arc
	stroke
      } def
      %% calculs des points de la courbe
      /coorPen3 {
        4 dict begin
        /t exch def
	%  r2 qi t cos mul ki qi t mul 60 ni mul sub cos mul add mul cm
	%  r2 qi t sin mul ki qi t mul 60 ni mul sub sin mul sub mul cm
        /beta t R1 R2 sub R1 div mul def
        /xC R1 R2 sub t cos mul def
        /yC R1 R2 sub t sin mul def
        R1 HolePos mul beta cos mul xC add cm
        R1 HolePos mul beta sin mul yC add cm
        end
      } def
    /AXE {
      %newpath
      Raxe 4 div cm
      A@0 cos Raxe mul cm moveto
      0 0 Raxe cm 90 A@0 sub 90 A@0 add arcn
      Raxe 4 div cm neg
      A@0 cos Raxe mul cm
      lineto
      Raxe 4 div cm neg
      Raxe A@0 cos 0.2 add mul cm
      lineto
      Raxe 4 div cm
      Raxe A@0 cos 0.2 add mul cm
      lineto
    } def
    %%% clavette %%%
    /CLAVETTE {
      newpath
      Raxe 4 div cm
      A@0 cos 0.2 sub Raxe mul cm moveto
      Raxe 4 div cm
      Raxe A@0 cos 0.2 add mul cm lineto
      Raxe 4 div cm neg
      Raxe A@0 cos 0.2 add mul cm lineto
      Raxe 4 div cm neg
      A@0 cos 0.2 sub Raxe mul cm lineto
      closepath
    } def
%
end
%%