home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
magazine
/
pcmagazi
/
1985
/
11
/
fractals.bas
< prev
Wrap
BASIC Source File
|
1985-03-05
|
5KB
|
126 lines
10 '=========================
20 ' Fractals
30 ' generate fractal curves using recursive midpoint reduction
40 ' copyright 1984, s m estvanik
50 ' 9 JULY 84
60 '==========================
70 ' m = number of points on a line
80 ' p = x location on a line
90 ' h = height at that value of p
100 DIM MP(12),P(12,12), H(12,12), T(20,200,2) ' t( nlines, pts per line)
110 DIM STACK(40,4) 'used to simulate recursion
120 '
130 KEY OFF
140 GOSUB 1000 'get values for lines
150 RANDOMIZE(VAL(RIGHT$(TIME$,2)))
160 '
170 GOSUB 2000 'preview graph
180 ' calculate fractals for each line requested
190 FOR K=1 TO NLINES STEP 2
200 N=0
210 FOR I=1 TO MP(K)-1
220 SP =1
230 STACK(SP,1)=P(K,I):STACK(SP,2)=P(K,I+1)
240 STACK(SP,3)=H(K,I):STACK(SP,4)=H(K,I+1)
250 GOSUB 2500 'call fractal calculator
260 NEXT
270 MP(K)=N 'number of points calculated
280 LOCATE K,5:PRINT "Line";K;",";MP(K);"points calculated"
290 NEXT
300 FOR K=2 TO NLINES-1 STEP 2 'interpolate
310 LOCATE 14,2,0:PRINT "Interpolating line";K;
320 IF MP(K-1)<MP(K+1) THEN MP(K)=MP(K-1) ELSE MP(K)=MP(K+1)
330 FOR I=1 TO MP(K)
340 IF T(K-1,I,1)=0 OR T(K+1,I,1)=0 GOTO 370
350 T(K,I,1)=(T(K-1,I,1)+T(K+1,I,1))/2
360 T(K,I,2)=(T(K-1,I,2)+T(K+1,I,2))/2
370 NEXT
380 NEXT
390 GOSUB 3000 'plot lines with hidden line removal
400 END
1000 '==================================== get data for lines
1010 READ NLINES,M '#lines, points per line
1020 DATA 9,7
1030 READ XMAX,YMAX 'max values for x,y
1032 FOR I=1 TO NLINES STEP 2:MP(I)=M:NEXT
1040 DATA 35, 100
1090 FOR K=1 TO NLINES STEP 2:FOR I=1 TO MP(K):READ H(K,I)
1092 H(K,I)=(H(K,I)-8500)/50 'scaling
1093 NEXT :NEXT
1094 YMAX=(14000-8500) /50
1095 ' Heights for each line, starting at farthest
1100 DATA 11600,12500,11600,12800,11600,11600,10400
1102 DATA 10400, 12000, 10800,11600,12000,13770,12000
1104 DATA 10000,11800,10000,10000,11200,11600,11500
1106 DATA 9600,10800,10000,9800,11200,10400,11200
1108 DATA 8800,10000,9600,9600,9600,10000,11600
1110 'horizontal distances across each line
1112 FOR K=1 TO NLINES STEP 2:FOR I=1 TO M:READ P(K,I):NEXT :NEXT
1115 DATA 1,5,10,15,20,25,30, 1,5,10,15,20,25,30, 1,5,10,15,20,25,30, 1,5,10,15,20,25,30, 1,5,10,15,20,25,30
1120 INPUT "Roughness (2-10)";RUFFNESS '************ help or desciption?
1130 INPUT "tolerance (min 2* nlines/100)";TOLERANCE
1200 YINC=50/NLINES
1210 XINC=150/NLINES 'scaling factors for transforms
1250 RETURN
2000 '=============== preview initial landscape
2002 CLS
2010 FOR K=1 TO NLINES
2020 FOR I=1 TO MP(K)
2030 T(K,I,1)=P(K,I)
2040 T(K,I,2)=H(K,I)
2050 NEXT :NEXT
2060 GOSUB 3000
2070 RETURN
2500 '======================================= fractal calculator
2510 WHILE SP>0 'as long as there are values on the stack.....
2520 T1=STACK(SP,1):T2=STACK(SP,2)
2530 H1=STACK(SP,3):H2=STACK(SP,4)
2540 SP=SP-1 'pop
2550 IF T2-T1>TOLERANCE GOTO 2610
2560 ' required resolution achieved
2570 N=N+1
2580 IF N>200 THEN PRINT "Overflow of t buffer";:STOP
2590 IF STACK(SP,0)=1 THEN T(K,N,1)=T2:T(K,N,2)=H2 ELSE T(K,N,1)=T1:T(K,N,2)=H1
2600 GOTO 2730
2610 TM=(T1+T2)/2 'midpoint
2620 PUSH =RND-.5
2630 HM=(H1+H2)/2+RUFFNESS*(T2-T1)*PUSH
2640 ' push each of the two new segments on the stack
2650 SP=SP+1
2660 STACK(SP,1)=TM:STACK(SP,2)=T2
2670 STACK(SP,3)=HM:STACK(SP,4)=H2
2680 STACK(SP,0)=2
2690 SP=SP+1
2700 STACK(SP,1)=T1:STACK(SP,2)=TM
2710 STACK(SP,3)=H1:STACK(SP,4)=HM
2720 STACK(SP,0)=1
2730 WEND
2740 RETURN
3000 '==================================== plot lines with hidden line removal
3010 SCREEN 1,0:COLOR 1,0
3020 ' pixel scale: horizontal, vertical
3030 XS=320/XMAX:YS=200/YMAX
3040 '---------transform to tilt landscape
3050 FOR K=1 TO NLINES
3060 FOR I=1 TO MP(K)
3070 ' add to each value to move away from borders
3080 T(K,I,1)=2+T(K,I,1)*XS
3090 T(K,I,2)=1+T(K,I,2)*YS 'scale
3100 NEXT
3110 NEXT
3120 PC=0
3130 FOR K=1 TO NLINES
3140 IF MP(K)<1 GOTO 3230
3150 PC=PC+1:IF PC>3 THEN PC=0 'cycle thru possible colors
3160 N=MP(K)
3170 LINE (0,200-T(K,1,2))-(T(K,1,1),200-T(K,1,2)),PC 'connect with border
3180 FOR I=1 TO N-1
3190 LINE (T(K,I,1),200-T(K,I,2))-(T(K,I+1,1),200-T(K,I+1,2)),PC
3200 NEXT
3210 LINE (T(K,N,1),200-T(K,N,2))-(319,200-T(K,N,2)),PC
3220 PAINT (T(K,2,1),199-T(K,2,2)+5),PC,PC 'remove hidden lines
3230 NEXT
3240 X$=INPUT$(1)
3250 SCREEN 0,0:WIDTH 80
3260 RETURN