summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/dvips/pst-spirograph/pst-spirograph.pro
blob: 588345b42e4f352185eb9422b1641e75b2bcca2d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
%% $Id: pst-spirograph.pro 1159 2020-03-12 15:13:17Z herbert $
%%
% PostScript prologue for pst-spirograph.tex.
%
% Version 0.50, 2020/03/11 
%
/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.06 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.06 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 %%%
      /COURONNE { 0 0 Rt 1.25 mul cm 360 0 arcn } def
      /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
	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
%
end
%%