17 Bit Software 1: Collection A

home *** CD-ROM | disk | FTP | other *** search

/ 17 Bit Software 1: Collection A / 17Bit_Collection_A.iso / files / 35.dms / 35.adf / fscape.bas < prev next >

Wrap

BASIC Source File | 1988-05-22 | 13.9 KB | 469 lines

10 ' Fracscapes 20 ' or 30 ' 3-D Fractal landscapes 40 ' 50 ' by Michiel van de Panne 60 ' From the july issue of Creative Computing (R.I.P.) 70 ' 80 ' hacked unmercifully and 90 ' modified for the Amiga from 100 ' the Mac version by 110 ' David Milligan, 70707,2521 120 ' and Ted Ingalls 130 ' 10-19-85 140 ' 150 ' ** This program will construct a realistic 160 ' ** 3-D landscape fractal from many random numbers 170 ' ** in up to seven levels of detail, simulating 180 ' ** mountain ranges, coastlines, sea floor and/or 190 ' ** surfaces, lakes, islands, etc. 200 ' ** Once the array used to do the drawing is created, 210 ' ** it can be saved to disk and reloaded and re-drawn. 220 ' ** We saved the array rather than the screen because 230 ' ** (1) we couldn't figure out how to find the start 240 ' ** of screen memory from ABasiC and couldn't get 250 ' ** a 640x200 screen stuffed into an array, and 260 ' ** (2) the array can be re-drawn with different scaling 270 ' ** factors for perspective changes and with sea level on 280 ' ** or off (default is off). 290 ' ** The length of time required to draw an array depends 300 ' ** on the number of levels selected. For each increase 310 ' ** in level the number of triangular subdivisions 320 ' ** is quadrupled. A level 7 landscape has the highest 330 ' ** 'resolution', but takes over an hour to draw. 340 ' 350 ' ** One of the main things we added to the original 360 ' ** program was color. The 12 colors are selected 370 ' ** by what we determined was altitude to render 380 ' ** forests, water, snow, dirt, etc. 390 ' ** Considering we understand vitually nothing 400 ' ** of the math involved, it works pretty well. 410 ' ** If you've got a better idea, have at it. 420 ' ** This program is definately NOT polished, 430 ' ** optimized or bug free, but it is fun to 440 ' ** play with. 450 ' ** While I don't understand them, I find fractal 460 ' ** graphics generation fascinating. If you've 470 ' ** got a nifty fractal program, upload it here 480 ' ** or sing out via E-mail. 490 ' 500 ' David Milligan, 70707,2521 510 ' 520 scnclr 530 ' 540 rem *** Set Screen to 640 x 200 *** 550 ' 560 ask window wid%,hi% 570 if wid%<600 then screen 1,4,0 580 ' 590 ' *** Program Initialization *** 600 ' 610 dim d(128,65),name$(40):a%=varptr(d(0,0)):l%=33280:le=0 620 gosub 4450:gosub 690:gosub 770:gosub 3300:goto 2760 630 ' 640 rem *** Trap Mouse Button *** 650 ' 660 ask mouse x%,y%,b%:if b%=0 then 660 670 return 680 ' 690 rem *** Turn Off Cursor *** 700 ' 710 rgb 15,0,0,0:return 720 ' 730 rem *** Turn Cursor on *** 740 ' 750 rgb 15,11,11,11:return 760 ' 770 rem *** Set Program Colours *** 780 ' 790 rgb 0,0,0,0 800 rgb 1,15,15,15 810 rgb 3,8,8,8:' light grey 820 rgb 4,5,5,5:' dark grey 830 rgb 5,7,4,3:' light brown 840 rgb 6,6,3,2:' dark brown 850 rgb 7,0,4,0:' medium green 860 rgb 8,0,0,12:' light blue 870 rgb 9,0,0,10:' blue 880 rgb 10,0,0,7:' medium blue 890 rgb 11,0,0,4:' dark blue 900 rgb 12,0,6,0:' green 910 rgb 13,0,7,0:' light green 920 rgb 14,0,2,0 :' dark green 930 return 940 ' 950 ' *** Calculate array data and insert *** 960 ' 970 print at (8,3);"Working on Level " 980 ds=2:for n=1 to le:ds=ds+2^(n-1):next n 990 mx=ds-1:my=mx/2:rh=pi*30/180:vt=rh*1.2 1000 for n=1 to le:l=10000/1.8^n 1010 print at (26,3);n 1020 ib=mx/2^n:sk=ib*2 1030 randomize -1 1040 gosub 1120:rem Assign heights along x in array 1050 gosub 1210:rem *** Assign heights along Y *** 1060 gosub 1300:rem *** Assign heights along Z *** 1070 next n 1080 scnclr:goto 2680 1090 ' 1100 ' *** Heights along X *** 1110 ' 1120 for ye=0 to mx-1 step sk 1130 for xe=ib+ye to mx step sk 1140 ax=xe-ib:ay=ye:gosub 1400:d1=d:ax=xe+ib:gosub 1400:d2=d 1150 d=(d1+d2)/2+rnd(1)*l/2-l/4:ax=xe:ay=ye:gosub 1470 1160 next xe 1170 next ye:return 1180 ' 1190 rem *** Heights along Y *** 1200 ' 1210 for xe=mx to 1 step -sk 1220 for ye=ib to xe step sk 1230 ax=xe:ay=ye+ib:gosub 1400:d1=d:ay=ye-ib:gosub 1400:d2=d 1240 d=(d1+d2)/2+rnd(1)*l/2-l/4:ax=xe:ay=ye:gosub 1470 1250 next ye 1260 next xe:return 1270 ' 1280 rem *** Heights along Z *** 1290 ' 1300 for xe=0 to mx-1 step sk 1310 for ye=ib to mx-xe step sk 1320 ax=xe+ye-ib:ay=ye-ib:gosub 1400:d1=d 1330 ax=xe+ye+ib:ay=ye+ib:gosub 1400:d2=d 1340 ax=xe+ye:ay=ye:d=(d1+d2)/2+rnd(1)*l/2-l/4:gosub 1470 1350 next ye 1360 next xe:return 1370 ' 1380 rem *** Return data from array *** 1390 ' 1400 if ay>my then 1420 1410 by=ay:bx=ax:goto 1430 1420 by=mx+1-ay:bx=mx-ax 1430 d=d(bx,by):return 1440 ' 1450 rem *** Put data into array *** 1460 ' 1470 if ay>my then 1490 1480 by=ay:bx=ax:goto 1500 1490 by=mx+1-ay:bx=mx-ax 1500 d(bx,by)=d:return 1510 ' 1520 rem *** Sea level section *** 1530 ' 1540 if sealevel=0 then gosub 1750:return 1550 if xo<>-999 then 1580 1560 if zz<0 then gosub 2010:z2=zz:zz=0:goto 1740 1570 gosub 2050:goto 1730 1580 if z2>0 and zz>0 then gosub 1750:goto 1730 1590 if z2<0 and zz<0 then z2=zz:zz=0:goto 1740 1600 w3=zz/(zz-z2):x3=(x2-xx)*w3+xx:y3=(y2-yy)*w3+yy:z3=0 1610 zt=zz:yt=yy:xt=xx 1620 if zz>0 then 1710 1630 ' 1640 rem *** Going into water *** 1650 ' 1660 zz=z3:yy=y3:xx=x3:gosub 2320 1670 gosub 2010:zz=0:yy=yt:xx=xt:z2=zt:goto 1740 1680 ' 1690 rem *** Coming out of water *** 1700 ' 1710 zz=z3:yy=y3:xx=x3:gosub 2320 1720 gosub 2050:zz=zt:yy=yt:xx=xt 1730 z2=zz 1740 x2=xx:y2=yy:return 1750 ' 1760 ' *** New Color Subroutine *** 1770 ' 1780 if zz<0 then goto 1890 1790 if zz>950 then pena 2:return 1800 if zz>850 then pena 3:return 1810 if zz>750 then pena 4:return 1820 if zz>650 then pena 5:return 1830 if zz>550 then pena 6:return 1840 if zz>450 then pena 13:return 1850 if zz>350 then pena 12:return 1860 if zz>100 then pena 7:return 1870 gosub 2050 1880 return 1890 ' 1900 ' *** below sea level *** 1910 ' 1920 if zz>-200 then gosub 2010:return 1930 if zz>-500 then pena 9:return 1940 if zz>-800 then pena 10:return 1950 if zz>-1200 then pena 11:return 1960 pena 11 1970 return 1980 ' 1990 rem *** Switch to sea level color *** 2000 ' 2010 pena 8:f1=1:return 2020 ' 2030 rem *** Switch to land color *** 2040 ' 2050 pena 14 2060 f1=0:return 2070 ' 2080 ' *** Rotation *** 2090 ' 2100 if xx<>0 then 2130 2110 if yy<=0 then ra=-pi/2:goto 2150 2120 ra=pi/2:goto 2150 2130 ra=atn(yy/xx) 2140 if xx<0 then ra=ra+pi 2150 r1=ra+rh:rd=sqr(xx*xx+yy*yy) 2160 xx=rd*cos(r1):yy=rd*sin(r1) 2170 return 2180 ' 2190 rem *** Tilt down *** 2200 ' 2210 rd=sqr(zz*zz+xx*xx) 2220 if xx=0 then ra=pi/2:goto 2250 2230 ra=atn(zz/xx) 2240 if xx<0 then ra=ra+pi 2250 r1=ra-vt 2260 xx=rd*cos(r1)+xx:zz=rd*sin(r1) 2270 return 2280 ' 2290 rem *** Plot to (xp,yp) *** 2300 ' 2310 gosub 1540 2320 xx=xx*xs:yy=yy*ys:zz=zz*zs 2330 gosub 2100:rem *** Rotate *** 2340 gosub 2210:rem *** Tilt up *** 2350 if xo=-999 then pr$="M" else pr$="D" 2360 xp=int(yy)+cx:yp=int(zz) 2370 gosub 2400 2380 return 2390 ' 2400 rem *** do plotting here *** 2410 ' 2420 ask mouse x%,y%,b%:if b%<>0 then 2760 2430 xp=xp*1.38:yp=48.53-0.663*yp:if pr$="M" then x8=xp:y8=yp 2440 draw (x8,y8 to xp,yp):x8=xp:y8=yp:xo=xp 2450 return 2460 ' 2470 rem *** Plot X Axis *** 2480 ' 2490 for ax=0 to mx:xo=-999:for ay=0 to ax 2500 gosub 1400:zz=d:yy=ay/mx*10000:xx=ax/mx*10000-yy/2 2510 gosub 2310:next ay:next ax 2520 return 2530 ' 2540 rem *** Plot Y Axis *** 2550 ' 2560 for ay=0 to mx:xo=-999:for ax=ay to mx 2570 gosub 1400:zz=d:yy=ay/mx*10000:xx=ax/mx*10000-yy/2 2580 gosub 2310:next ax:next ay 2590 return 2600 ' 2610 rem *** Plot Z Axis *** 2620 ' 2630 for ex=0 to mx:xo=-999:for ey=0 to mx-ex 2640 ax=ex+ey:ay=ey:gosub 1400:zz=d:yy=ay/mx*10000 2650 xx=ax/mx*10000-yy/2:gosub 2310:next ey:next ex 2660 return 2670 ' 2680 ' *** Setup Screen *** 2690 ' 2700 close 2:cmd 1:graphic(1):gosub 760 2710 tax=ax:tay=ay 2720 gosub 2630 2730 gosub 2560 2740 gosub 2490 2750 ' 2760 rem *** Main Menu Section *** 2770 ' 2780 gosub 3370 2790 print at(4,2);"-> Use Keyboard to Select <-" 2800 print at(6,4);"1 - Start New Landscape" 2810 ? at(6,5);"2 - Draw Existing Array" 2820 ? at(6,6);"3 - Save Fractal Array" 2830 ? at(6,7);"4 - Load Fractal Array" 2840 ? at(6,8);"5 - Reset Scaling Factors" 2850 ? at(6,9);"6 - Set Sea Level Options" 2860 rem ? at(6,10);"7 - Read & Display Mouse x,y" 2870 ? at(6,11);"7 - Close This Window !" 2880 ? at(10,12);"Click the Left Button" 2890 ? at(10,13);"To Restore Menu" 2900 ? at(6,14);"0 - Exit to ABasiC" 2910 pena 0:gosub 4500 2920 print at(10,16);"Selection (0-8) ";:input a$ 2930 query=val(a$):print at(10,16);spc(20):erase a$ 2940 on query goto 3120,4140,3650,3760,4240,4010,4000,4000,4000 2950 ' 2960 rem *** Program exit *** 2970 ' 2980 scnclr:close 3 2990 cmd 1:scnclr:close 1 3000 cmd 0:pena 0 3010 ' 3020 rem *** Restore ABasiC's colours *** 3030 ' 3040 rgb 0,6,9,15 3050 rgb 1,0,0,0 3060 rgb 2,15,15,15 3070 gosub 750 3080 clr:end 3090 ' 3100 rem *** Start a new fractal screen *** 3110 ' 3120 scnclr:close 3 3130 ' 3140 rem *** New landscape *** 3150 ' 3160 cmd 1:graphic(1):scnclr 3170 gosub 3330 3180 ' 3190 rem *** Prompt to begin drawing *** 3200 ' 3210 print at(2,2);"Click the Left Mouse Button to Start." 3220 print at(4,4);"Click While Drawing to Abort." 3230 gosub 660:scnclr 3240 print at(8,3);"Number of levels ";:input le 3250 scnclr:if le<1 or le>7 then 3240 3260 goto 950 3270 ' 3280 rem *** Windows *** 3290 ' 3300 window #1,0,0,639,199,"Fracscapes" 3310 return 3320 ' 3330 window #2,120,50,340,60,"New Fracscape" 3340 cmd #2:graphic(0):scnclr 3350 return 3360 ' 3370 window #3,100,20,300,160,"Main Menu" 3380 cmd 3:graphic(0):scnclr 3390 return 3400 ' 3410 window #4,100,50,400,40,"Save Array" 3420 cmd 4:graphic(0):scnclr 3430 return 3440 ' 3450 window #5,100,100,400,40,"Load Array" 3460 cmd 5:graphic(0):scnclr 3470 return 3480 ' 3490 window #6,100,20,340,130,"Array Description" 3500 cmd 6:graphic(0):scnclr 3510 return 3520 ' 3530 window #7,100,30,340,60,"Sea Level Options" 3540 cmd 7:graphic(0):scnclr 3550 return 3560 ' 3570 window #8,50,20,340,50,"Draw Array in Memory" 3580 cmd 8:graphic(0) 3590 return 3600 ' 3610 window #9,150,30,300,130,"Scaling Settings" 3620 cmd 9:graphic(0) 3630 return 3640 ' 3650 rem *** screen save *** 3660 ' 3670 on error goto 4540 3680 gosub 3410:name$="" 3690 print at(2,2);"Save Array as -> ";:line input name$ 3700 d(0,65)=le:d(1,65)=mx:d(2,65)=my:d(3,65)=tax:d(4,65)=tay 3710 d(5,65)=xs:d(6,65)=ys:d(7,65)=zs:d(8,65)=sealevel 3720 bsave name$,a%,l% 3730 scnclr:close 4:cmd 3 3740 goto 4110 3750 ' 3760 rem *** Screen Load *** 3770 ' 3780 ' on error goto 5000 3790 gosub 3450:name$="" 3800 print at(2,2);"Name of Array to Load -> ";:line input name$ 3810 bload name$,a% 3820 le=d(0,65):mx=d(1,65):my=d(2,65):ax=d(3,65):ay=d(4,65) 3830 xs=d(5,65):ys=d(6,65):zs=d(7,65):sealevel=d(8,65) 3840 scnclr:close 5 3850 gosub 3490 3860 ? at(7,2);"Array name -> ";name$ 3870 ? at(7,4);"Number of Levels -> ";le 3880 if sealevel=0 then level$="off" else level$="on" 3890 ? at(7,6);"Sea Level Display -> ";level$ 3900 ? at(7,8);"Scaling Values -> X= ";xs 3910 ? at(26,9);"Y= ";ys 3920 ? at(26,10);"Z= ";zs 3930 ? at(5,13);"Click left button to continue" 3940 gosub 640 3950 scnclr:close #6:cmd 3 3960 goto 4110 3970 ' 3980 rem *** Turn off menu window *** 3990 ' 4000 scnclr:close 3:gosub 660:goto 2760 4010 ' 4020 ' **** Set Sea Level Option **** 4030 ' 4040 gosub 3530 4050 print at (2,3);"Display sea level surface (Y/N) ";:input a$ 4060 if a$="y" or a$="Y" then sealevel=1 else sealevel=0:goto 4070 4070 scnclr:close 7:cmd 3 4080 ' 4090 ' *** Error Trap *** 4100 ' 4110 on error goto 4540 4120 query=0:erase a$ 4130 goto 2920 4140 ' 4150 ' *** Redraw old Array *** 4160 ' 4170 if le=0 then 2920 4180 gosub 3570 4190 print at(2,2);"Clear Screen Before Re-Draw (Y/N) ";:input a$ 4200 scnclr:close 8:cmd 3:scnclr:close 3:cmd 1:graphic(1) 4210 if a$="y" or a$="Y" then scnclr 4220 erase a$:goto 2700 4230 ' 4240 ' *** Scaling Settings *** 4250 ' 4260 gosub 3610 4270 graphic(0) 4280 print at(5,2);"Current Scaling Settings :" 4290 print at(13,4);"X= ";xs 4300 print at(13,5);"Y= ";ys 4310 print at(13,6);"Z= ";zs 4320 print at(5,8);"Press C to Change Settings" 4330 print at(11,9);"D for Default Settings" 4340 print at(11,10);"X to Exit" 4350 gosub 4500 4360 print at(13,12);"Selection ";:input a$ 4370 if a$="c" or a$="C" then 4420 4380 if a$="d" or a$="D" then gosub 4460:goto 4410 4390 if a$<>"x" and a$<>"X" then 4410 4400 scnclr:close 9:cmd 3:goto 4110 4410 scnclr:erase a$:goto 4280 4420 print at(13,12);spc(16) 4430 print at(4,12);"Input New X,Y,Z ";:input xs,ys,zs 4440 goto 4410 4450 ' 4460 ' *** Stock Scaling Factors *** 4470 ' 4480 xs=.04:ys=.04:zs=.05:return 4490 ' 4500 for i=0 to 10 4510 get a$:erase a$:next i 4520 on error goto 4540 4530 return 4540 ' 4550 ' 4560 ' **** error trap **** 4570 ' 4580 ' 4590 fmem%=fre 4600 window #10,100,100,300,90,"Rats - An Error Occurred" 4610 cmd #10:graphic(0):scnclr 4620 ?at(2,2);"Error # ";err;" occurred at line ";erl 4630 ?at(2,4);err$(err) 4640 ?at(2,5);"There are ";fmem%;" bytes of memory showing" 4650 ?at(2,7);"Click left button to continue...." 4660 gosub 640 4670 scnclr:close 10,3,4,5,6 4680 goto 2760