-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathFRACTALE.BAS
355 lines (355 loc) · 11 KB
/
FRACTALE.BAS
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
90 KEY OFF
100 SCREEN 2
110 WINDOW(0,0)-(639,199)
120 COEF=3.141593/180
130 FANG=3.141593/15
140 DEFINT N
150 DIM V1(3),V2(3),VN(3),VECL(3),VOBS(3),PT(3,3),XE(3),YE(3),BARY(3),C(3)
160 CLS
170 INPUT "Degr‚ de maillage (0 … 7) : ",MAIL
180 INPUT "Indice de profil (1 … 100) : ",PROF
190 INPUT "Type aleatoire (0 … 32000) : ",ALEA
200 INPUT "El‚vation du niveau de la mer : ",MER
210 PRINT
220 INPUT "Angle de vision vertical Theta (-90<Theta<90) : ",THETA
230 INPUT "Angle de vision horizontal Phi (0<Phi<360) : ",PHI
240 INPUT "Distance de l'observateur a l'origine (>5000) : ",RAY
250 CT=COS(THETA*COEF):ST=SIN(THETA*COEF)
260 CP=COS(PHI*COEF):SP=SIN(PHI*COEF)
270 XOBS=RAY*CT*CP
280 YOBS=RAY*CT*SP
290 ZOBS=RAY*ST
300 PRINT :PRINT "Selectionnez un type de trace "
310 PRINT " -1- Rapide "
320 PRINT " -2- Parties cach‚es"
330 PRINT " -3- Surface ‚clair‚e"
340 INPUT " > ",TYPE
350 IF TYPE<>3 THEN 450
360 PRINT
370 INPUT "Angle vertical d'‚clairage Alpha (-90<alpha<90) : ",ALPHA
380 INPUT "Angle horizontal d'‚clairage B‚ta (0<Beta<360) : ",BETA
390 INPUT "Distance de la source lumineuse … l'origine (>5000) : ",R
400 ALPHA =ALPHA*COEF:BETA=BETA *COEF
410 XECL=R*COS(ALPHA)*COS(BETA)
420 YECL=R*COS(ALPHA)*SIN(BETA)
430 ZECL=R*SIN(ALPHA)
440 INPUT "D‚sirez-vous les contours des facettes ? (O/N) : ",BORD$
450 LOCATE 23,17:PRINT "Les calculs sont en cour : veuillez patienter"
460 TPAV=TIMER
470 GOSUB 2630:GOSUB 2950
490 REM ************************************************************************
500 REM -=- Sous Programe d'affichage -=-
510 REM ************************************************************************
520 CLS
530 IF TYPE =1 THEN GOSUB 1840:GOTO 570
540 IF PHI>=120 AND PHI<240 THEN GOSUB 630:GOTO 570
550 IF PHI<120 THEN GOSUB 1030 :GOTO 570
560 GOSUB 1430
570 BEEP
580 TEMPS=INT(TIMER-TPAV+.5):HEU=TEMPS\3600:MINU=(TEMPS\60)MOD 60:SEC=TENPS MOD 60
590 A$=INPUT$(1)
600 IF A$=CHR$(13) THEN LOCATE 1,1:INPUT "",NOM$:BEEP:DEF SEG=&HB800:BSAVE NOM$,0,16000
610 IF A$="t" OR A$="T" THEN LOCATE 2,6:PRINT MINU;"Min ";SEC;"s":IF HEU<>0 THEN 2,1:PRINT HEU;"h"
620 GOTO 590
630 IF PHI<180 THEN DEB=1:SENS=1 ELSE FIN=1:SENS=-1
640 FOR I=2 TO DN
650 TST=0:IF PHI<180 THEN FIN=DN-I+1 ELSE DEB =DN-I+1
660 FOR J=DEB TO FIN STEP SENS
670 IF PHI<180 THEN GOSUB 710:GOSUB 870 ELSE GOSUB 870:GOSUB 710
680 NEXT J
690 NEXT I
700 RETURN
710 CI=I-1:CJ=J:GOSUB 3320
720 FOR L=1 TO 3
730 V1(L)=C(L):PT(1,L)=C(L)
740 NEXT L
750 CI=I:GOSUB 3320
760 FOR L=1 TO 3
770 V1(L)=V1(L)-C(L):PT(2,L)=C(L)
780 NEXT L
790 IF TST=0 THEN TST=1:GOTO 860
800 IF PHI<180 THEN CJ=J-1 ELSE CJ=J+1:CI=I-1
810 GOSUB 3320
820 FOR L=1 TO 3
830 PT(3,L)=C(L)
840 NEXT L
850 GOSUB 2020
860 RETURN
870 CI=I-1:CJ=J+1:GOSUB 3320
880 FOR L=1 TO 3
890 V2(L)=C(L):PT(1,L)=C(L)
900 NEXT L
910 CI=I:CJ=J:GOSUB 3320
920 FOR L=1 TO 3
930 V2(L)=V2(L)-C(L):PT(2,L)=C(L)
940 NEXT L
950 IF TST=0 THEN TST=1:GOTO 1020
960 IF PHI<180 THEN CI=I-1 ELSE CJ=J=1
970 GOSUB 3320
980 FOR L=1 TO 3
990 PT(3,L)=C(L)
1000 NEXT L
1010 GOSUB 2020
1020 RETURN
1030 IF PHI>60 THEN DEB=1:SENS=1 ELSE FIN=1:SENS=-1
1040 FOR I=2 TO DN
1050 TST=0:IF PHI>60 THEN FIN=DN-I+1 ELSE DEB =DN-I+1
1060 FOR J=DEB TO FIN STEP SENS
1070 IF PHI>60 THEN GOSUB 1110:GOSUB 1270 ELSE GOSUB 1270:GOSUB 1110
1080 NEXT J
1090 NEXT I
1100 RETURN
1110 CI=J:CJ=I-1:GOSUB 3320
1120 FOR L=1 TO 3
1130 V2(L)=C(L):PT(1,L)=C(L)
1140 NEXT L
1150 CJ=I:GOSUB 3320
1160 FOR L=1 TO 3
1170 V2(L)=V2(L)-C(L):PT(2,L)=C(L)
1180 NEXT L
1190 IF TST=0 THEN TST=1:GOTO 1260
1200 IF PHI>60 THEN CI=J-1 ELSE CI=J+1:CJ=I-1
1210 GOSUB 3320
1220 FOR L=1 TO 3
1230 PT(3,L)=C(L)
1240 NEXT L
1250 GOSUB 2020
1260 RETURN
1270 CI=J+1:CJ=I-1:GOSUB 3320
1280 FOR L=1 TO 3
1290 V1(L)=C(L):PT(1,L)=C(L)
1300 NEXT L
1310 CI=J:CJ=I:GOSUB 3320
1320 FOR L=1 TO 3
1330 V1(L)=V1(L)-C(L):PT(2,L)=C(L)
1340 NEXT L
1350 IF TST=0 THEN TST=1:GOTO 1420
1360 IF PHI>60 THEN CJ=I-1 ELSE CI=J+1
1370 GOSUB 3320
1380 FOR L=1 TO 3
1390 PT(3,L)=C(L)
1400 NEXT L
1410 GOSUB 2020
1420 RETURN
1430 IF PHI<300 THEN DEB=1:SENS=1:ELSE FIN=1:SENS=-1
1440 FOR I=DN-1 TO 1 STEP -1
1450 TST=0:IF PHI <300 THEN FIN=I ELSE DEB=I
1460 FOR J=DEB TO FIN STEP SENS
1470 K=I+1-J
1480 IF PHI <300 THEN GOSUB 1520 :GOSUB 1680 ELSE GOSUB 1680:GOSUB 1520
1490 NEXT J
1500 NEXT I
1510 RETURN
1520 CI=J:CJ=K+1 :GOSUB 3320
1530 FOR L=1 TO 3
1540 V1(L)=C(L):PT(1,L)=C(L)
1550 NEXT L
1560 CJ=K:GOSUB 3320
1570 FOR L=1 TO 3
1580 V1(L)=V1(L)-C(L):PT(2,L)=C(L)
1590 NEXT L
1600 IF TST=0 THEN TST=1:GOTO 1670
1610 IF PHI<300 THEN CI=J-1:CJ=K+1 ELSE CI=J+1
1620 GOSUB 3320
1630 FOR L=1 TO 3
1640 PT(3,L)=C(L)
1650 NEXT L
1660 GOSUB 2020
1670 RETURN
1680 CI=J+1:CJ=K:GOSUB 3320
1690 FOR L=1 TO 3
1700 V2(L)=C(L):PT(1,L)=C(L)
1710 NEXT L
1720 CI=J:GOSUB 3320
1730 FOR L=1 TO 3
1740 V2(L)=V2(L)-C(L):PT(2,L)=C(L)
1750 NEXT L
1760 IF TST=0 THEN TST=1:GOTO 1830
1770 IF PHI<300 THEN CJ=K+1 ELSE CI=J+1:CJ=K-1
1780 GOSUB 3320
1790 FOR L=1 TO 3
1800 PT(3,L)=C(L)
1810 NEXT L
1820 GOSUB 2020
1830 RETURN
1840 C=1
1850 FOR I=2 TO DN
1860 FOR J=1 TO DN-I+1
1870 CI=I:CJ=J:GOSUB 3220
1880 XE(1)=XE*ECHX+XCENT:YE(1)=YE*ECHY+YCENT
1890 CI=I-1:GOSUB 3220
1900 XE(2)=XE*ECHX+XCENT:YE(2)=YE*ECHX+YCENT
1910 CJ=J+1:GOSUB 3220
1920 XE(3)=XE*ECHX+XCENT:YE(3)=YE*ECHY+YCENT
1930 GOSUB 3600
1940 NEXT J
1950 NEXT I
1960 RETURN
1970 REM
1980 REM ***********************************************************************
1990 REM -=- Calcul des couleurs et remplissage des facettes -=-
2000 REM ***********************************************************************
2010 REM
2020 INDM=0:NCOUL =0
2030 IF PT(1,3)=MER AND PT(2,3)=MER AND PT(3,3)=MER THEN INDM=1:GOTO 2300
2040 VN(1)=V1(2)*V2(3)-V1(3)*V2(2)
2050 VN(2)=V1(3)*V2(1)-V1(1)*V2(3)
2060 VN(3)=V1(1)*V2(2)-V1(2)*V2(1)
2070 VN=SQR(VN(1)^2+VN(2)^2+VN(3)^2)
2080 FOR N=1 TO 3
2090 BARY(N)=(PT(1,N)+PT(2,N)+PT(3,N))/3
2100 NEXT N
2110 VOBS(1)=BARY(1)-XOBS
2120 VOBS(2)=BARY(2)-YOBS
2130 VOBS(3)=BARY(3)-ZOBS
2140 PROSC=VN(1)*VOBS(1)+VN(2)*VOBS(2)+VN(3)*VOBS(3)
2150 VOBS=SQR(VOBS(1)^2+VOBS(2)^2+VOBS(3)^2)
2160 COSANG=PROSC/(VN*VOBS)
2170 ANG=ATN(SQR(1-COSANG^2)/COSANG)
2180 IF ANG>0 THEN NCOUL=1
2190 IF NCOUL=1 OR TYPE=2 THEN 2300
2200 VECL(1)=BARY(1)-XECL
2210 VECL(2)=BARY(2)-YECL
2220 VECL(3)=BARY(3)-ZECL
2230 PROSC=VN(1)*VECL(1)+VN(2)*VECL(2)+VN(3)*VECL(3)
2240 VECL=SQR(VECL(1)^2+VECL(2)^2+VECL(3)^2)
2250 COSANG=PROSC/(VN*VECL)
2260 ANG=ANT(SQR(1-COSANG^2)/COSANG)
2270 IF ANG<0 THEN ANG=ANG+3.141593
2280 COUL=INT(ANG/FANG+.5)
2290 IF COUL<>0 THEN FREQ=15/COUL ELSE FREQ=1E+30
2300 FOR N=1 TO 3
2310 C(1)=PT(N,1):C(2)=PT(N,2):C(3)=PT(N,3)
2320 GOSUB 3230
2330 XE(N)=INT(XE*ECHX+XCENT+.5):YE(N)=INT(YE*ECHY+YCENT+.5)
2340 NEXT N
2350 IF YE(2)>=YE(1) AND YE(2)>=YE(3) THEN EXX=XE(1):EXY=YE(1):XE(1)=XE(2):YE(1)=YE(2):XE(2)=EXX:YE(2)=EXY:GOTO 2370
2360 IF YE(3)>=YE(1) AND YE(3)>=YE(2) THEN EXX=XE(1):EXY=YE(1):XE(1)=XE(3):YE(1)=YE(3):XE(3)=EXX:YE(3)=EXY
2370 IF YE(3)>YE(2) THEN EXX=XE(2):EXY=YE(2):XE(2)=XE(3):YE(2)=YE(3):XE(3)=EXX:YE(3)=EXY
2380 EX1=XE(1)-XE(2):EY1=YE(1)-YE(2)
2390 EX2=XE(1)-XE(3):EY2=YE(1)-YE(3)
2400 EX3=XE(2)-XE(3):EY3=YE(2)-YE(3)
2410 IF EY1<>0 THEN STP1=EX1/EY1
2420 IF EY2<>0 THEN STP2=EX2/EY2
2430 IF EY3<>0 THEN STP3=EX3/EY3
2440 PCH=INT(RND*FREQ+1.5):COMP=1
2450 CPT2=0
2460 FOR CPT1=0 TO EY1
2470 X1=INT(XE(1)-CPT1*SPT1+.5):X2=INT(XE(1)-CPT2*STP2+.5):Y1=YE(1)-CPT1
2480 IF EY1=0 THEN X1=XE(2)
2490 IF EY2=0 THEN X2=XE(3)
2500 GOSUB 3420
2510 NEXT CPT1
2520 FOR CPT1=1 TO EY3
2530 X1=INT(XE(2)-CPT1*STP3+.5):X2=INT(XE(1)-CPT2*STP2+.5):Y1=YE(1)-CPT2
2540 GOSUB 3420
2550 NEXT CPT1
2560 IF (TYPE=2 AND NCOUL=0 AND INDM=0) OR (TYPE=3 AND NCOUL=1) OR BORD$="O" OR BORD$="o" THEN C=1:GOSUB 3600
2570 RETURN
2580 REM
2590 REM =======================================================================
2600 REM G‚n‚ration de la Matrice
2610 REM =======================================================================
2620 REM G‚n‚ration de la Matrice
2630 RANDOMIZE ALEA
2640 DN=2^MAIL+1:PAS=DN-1:ECH=4000
2650 DIM NOEUD (DN,DN)
2660 WHILE PAS>1
2670 FOR I=1 TO DN-PAS STEP PAS
2680 FOR J=1 TO DN-I-PAS+1 STEP PAS
2690 A=I+PAS/2:B=J+PAS/2:C=I+PAS:D=J+PAS
2700 GOSUB 2870
2710 NOEUD (I,B)=(NOEUD(I,J)+NOEUD(I,D))/2+ALT
2720 GOSUB 2870
2730 NOEUD (A,J)=(NOEUD(I,J)+NOEUD(C,J))/2+ALT
2740 GOSUB 2870
2750 NOEUD (A,B)=(NOEUD(C,J)+NOEUD(I,D))/2+ALT
2760 NEXT J
2770 NEXT I
2780 PAS=PAS/2
2790 ECH=ECH/2
2800 WEND
2810 RETURN
2820 REM
2830 REM =======================================================================
2840 REM Calcul al‚atoire d'altitude
2850 REM =======================================================================
2860 REM
2870 ALT=RND*ECH
2880 IF RND>PROF/100 THEN ALT=-ALT
2890 RETURN
2900 REM
2910 REM =======================================================================
2920 REM Sous-programme de calcul du centrage
2930 REM =======================================================================
2940 REM
2950 XEMIN=1000:YEMIN=1000
2960 XEMAX=-1000:YEMAX=-1000
2970 IF MAIL>5 THEN STP=2^(MAIL-5) ELSE STP=1
2980 FOR I=1 TO DN STEP STP
2990 FOR J=1 TO DN-I+1 STEP STP
3000 CI=I:CJ=J
3010 GOSUB 3220
3020 IF XE<XEMIN THEN XEMIN=XE
3030 IF XE>XEMAX THEN XEMAX=XE
3040 IF YE<YEMIN THEN YEMIN=YE
3050 IF YE>YEMAX THEN YEMAX=YE
3060 NEXT J
3070 NEXT I
3080 ECRX=600:ECRY=190
3090 RAP=2.62
3100 ECHX=ECRX/(XEMAX-XEMIN)/RAP
3110 ECHY=ECRY/(YEMAX-YEMIN)
3120 IF ECHY<ECHX THEN ECHX=ECHY
3130 ECHY=ECHX:ECHX=ECHX*RAP
3140 XCENT=(640-ECHX*(XEMAX+XEMIN))/2
3150 YCENT=(200-ECHY*(YEMAX+YEMIN))/2
3160 RETURN
3170 REM
3180 REM =======================================================================
3190 REM calcule de corden‚e de l'‚cran
3200 REM =======================================================================
3210 REM
3220 GOSUB 3320
3230 D=C(1)*CP*CT+C(2)*SP*CT+C(3)*ST-RAY
3240 XE=(C(1)*SP-C(2)*CP)/D
3250 YE=(C(1)*CP*ST+C(2)*SP*ST-C(3)*CT)/D
3260 RETURN
3270 REM
3280 REM =======================================================================
3290 REM Calcule de coordon‚e spatiales
3300 REM =======================================================================
3310 REM
3320 C(1)=((1-CI)/(DN-1)+1/3)*4000*SQR(3)
3330 C(2)=((CJ-1)+(CI-1)/2)*8000/(DN-1)-4000
3340 C(3)=NOEUD(CI,CJ)
3350 IF C(3)<MER THEN C(3)=MER
3360 RETURN
3370 REM
3380 REM =======================================================================
3390 REM sous programe de coloriage
3400 REM =======================================================================
3410 REM
3420 IF (NCOUL=1 AND TYPE=2) OR (Y1 MOD 2=0 AND INDM=1) THEN C=1 ELSE C=0
3430 IF TYPE=2 OR INDM=1 OR NCOUL=1 THEN LINE (X1,Y1)-(X2,Y1),C:GOTO 3530
3440 IF X1<>X2 THEN 3470
3450 IF COMP=INT(PCH+.5) THEN PSET(X1,Y1),1 ELSE PSET(X1,Y1),0
3460 GOTO 3530
3470 FOR N=X1 TO X2 STEP SGN(X2-X1)
3480 C=0
3490 IF COMP=INT(PCH+.5) THEN C=1:PCH=PCH+FREQ
3500 PSET (N,Y1),C
3510 COMP=COMP+1
3520 NEXT N
3530 CPT2=CPT2+1
3540 RETURN
3550 REM
3560 REM ===============================
3570 REM trac‚ des contours
3580 REM ===============================
3590 REM
3600 LINE (XE(1),YE(1))-(XE(2),YE(2)),C
3610 LINE (XE(2),YE(2))-(XE(3),YE(3)),C
3620 LINE (XE(3),YE(3))-(XE(1),YE(1)),C
3630 RETURN