home *** CD-ROM | disk | FTP | other *** search
/ 17 Bit Software 1: Collection A / 17Bit_Collection_A.iso / files / 36.dms / 36.adf / fscape.bas < prev    next >
BASIC Source File  |  1988-05-22  |  14KB  |  937 lines
  1. 10    '          Fracscapes
  2.  
  3. 20    '              or
  4.  
  5. 30    '    3-D Fractal landscapes
  6.  
  7. 40    '
  8.  
  9. 50    '   by Michiel van de Panne
  10.  
  11. 60    '   From the july issue of Creative Computing (R.I.P.)
  12.  
  13. 70    '
  14.  
  15. 80    '    hacked unmercifully and
  16.  
  17. 90    '   modified for the Amiga from
  18.  
  19. 100   '   the Mac version by
  20.  
  21. 110   '   David Milligan, 70707,2521
  22.  
  23. 120   '   and Ted Ingalls
  24.  
  25. 130   '         10-19-85
  26.  
  27. 140   '
  28.  
  29. 150   '  **  This program will construct a realistic
  30.  
  31. 160   '  **  3-D landscape fractal from many random numbers
  32.  
  33. 170   '  **  in up to seven levels of detail, simulating
  34.  
  35. 180   '  **  mountain ranges, coastlines, sea floor and/or
  36.  
  37. 190   '  **  surfaces, lakes, islands, etc.
  38.  
  39. 200   '  **  Once the array used to do the drawing is created,
  40.  
  41. 210   '  **  it can be saved to disk and reloaded and re-drawn.
  42.  
  43. 220   '  **  We saved the array rather than the screen because
  44.  
  45. 230   '  **  (1) we couldn't figure out how to find the start
  46.  
  47. 240   '  **  of screen memory from ABasiC and couldn't get
  48.  
  49. 250   '  **  a 640x200 screen stuffed into an array, and
  50.  
  51. 260   '  **  (2) the array can be re-drawn with different scaling
  52.  
  53. 270   '  **  factors for perspective changes and with sea level on 
  54.  
  55. 280   '  **  or off (default is off).
  56.  
  57. 290   '  **  The length of time required to draw an array depends
  58.  
  59. 300   '  **  on the number of levels selected. For each increase
  60.  
  61. 310   '  **  in level the number of triangular subdivisions
  62.  
  63. 320   '  **  is quadrupled. A level 7 landscape has the highest
  64.  
  65. 330   '  **  'resolution', but takes over an hour to draw.
  66.  
  67. 340   '
  68.  
  69. 350   '  **  One of the main things we added to the original
  70.  
  71. 360   '  **  program was color. The 12 colors are selected
  72.  
  73. 370   '  **  by what we determined was altitude to render
  74.  
  75. 380   '  **  forests, water, snow, dirt, etc.
  76.  
  77. 390   '  **  Considering we understand vitually nothing
  78.  
  79. 400   '  **  of the math involved, it works pretty well.
  80.  
  81. 410   '  **  If you've got a better idea, have at it.
  82.  
  83. 420   '  **  This program is definately NOT polished,
  84.  
  85. 430   '  **  optimized or bug free, but it is fun to
  86.  
  87. 440   '  **  play with.
  88.  
  89. 450   '  **  While I don't understand them, I find fractal
  90.  
  91. 460   '  **  graphics generation fascinating. If you've
  92.  
  93. 470   '  **  got a nifty fractal program, upload it here
  94.  
  95. 480   '  **  or sing out via E-mail.
  96.  
  97. 490   '
  98.  
  99. 500   '           David Milligan, 70707,2521
  100.  
  101. 510   '
  102.  
  103. 520   scnclr
  104.  
  105. 530   '
  106.  
  107. 540   rem *** Set Screen to 640 x 200 ***
  108.  
  109. 550   '
  110.  
  111. 560   ask window wid%,hi%
  112.  
  113. 570   if wid%<600 then screen 1,4,0
  114.  
  115. 580   '
  116.  
  117. 590   '   *** Program Initialization ***
  118.  
  119. 600   '
  120.  
  121. 610   dim d(128,65),name$(40):a%=varptr(d(0,0)):l%=33280:le=0
  122.  
  123. 620   gosub 4450:gosub 690:gosub 770:gosub 3300:goto 2760
  124.  
  125. 630   '
  126.  
  127. 640   rem *** Trap Mouse Button ***
  128.  
  129. 650   '
  130.  
  131. 660   ask mouse x%,y%,b%:if b%=0 then 660
  132.  
  133. 670   return
  134.  
  135. 680   '
  136.  
  137. 690   rem *** Turn Off Cursor ***
  138.  
  139. 700   '
  140.  
  141. 710   rgb 15,0,0,0:return
  142.  
  143. 720   '
  144.  
  145. 730   rem *** Turn Cursor on ***
  146.  
  147. 740   '
  148.  
  149. 750   rgb 15,11,11,11:return
  150.  
  151. 760   '
  152.  
  153. 770   rem *** Set Program Colours ***
  154.  
  155. 780   '
  156.  
  157. 790   rgb 0,0,0,0
  158.  
  159. 800   rgb 1,15,15,15
  160.  
  161. 810   rgb 3,8,8,8:' light grey
  162.  
  163. 820   rgb 4,5,5,5:' dark grey
  164.  
  165. 830   rgb 5,7,4,3:' light brown
  166.  
  167. 840   rgb 6,6,3,2:' dark brown
  168.  
  169. 850   rgb 7,0,4,0:' medium green
  170.  
  171. 860   rgb 8,0,0,12:' light blue
  172.  
  173. 870   rgb 9,0,0,10:' blue
  174.  
  175. 880   rgb 10,0,0,7:' medium blue
  176.  
  177. 890   rgb 11,0,0,4:' dark blue
  178.  
  179. 900   rgb 12,0,6,0:' green
  180.  
  181. 910   rgb 13,0,7,0:' light green
  182.  
  183. 920   rgb 14,0,2,0 :' dark green
  184.  
  185. 930   return
  186.  
  187. 940   '
  188.  
  189. 950   '   *** Calculate array data and insert ***
  190.  
  191. 960   '
  192.  
  193. 970   print at (8,3);"Working on Level "
  194.  
  195. 980   ds=2:for n=1 to le:ds=ds+2^(n-1):next n
  196.  
  197. 990   mx=ds-1:my=mx/2:rh=pi*30/180:vt=rh*1.2
  198.  
  199. 1000  for n=1 to le:l=10000/1.8^n
  200.  
  201. 1010  print at (26,3);n
  202.  
  203. 1020  ib=mx/2^n:sk=ib*2
  204.  
  205. 1030  randomize -1
  206.  
  207. 1040  gosub 1120:rem Assign heights along x in array
  208.  
  209. 1050  gosub 1210:rem *** Assign heights along Y ***
  210.  
  211. 1060  gosub 1300:rem *** Assign heights along Z ***
  212.  
  213. 1070  next n
  214.  
  215. 1080  scnclr:goto 2680
  216.  
  217. 1090  '
  218.  
  219. 1100  '   *** Heights along X ***
  220.  
  221. 1110  '
  222.  
  223. 1120  for ye=0 to mx-1 step sk
  224.  
  225. 1130  for xe=ib+ye to mx step sk
  226.  
  227. 1140  ax=xe-ib:ay=ye:gosub 1400:d1=d:ax=xe+ib:gosub 1400:d2=d
  228.  
  229. 1150  d=(d1+d2)/2+rnd(1)*l/2-l/4:ax=xe:ay=ye:gosub 1470
  230.  
  231. 1160  next xe
  232.  
  233. 1170  next ye:return
  234.  
  235. 1180  '
  236.  
  237. 1190  rem *** Heights along Y ***
  238.  
  239. 1200  '
  240.  
  241. 1210  for xe=mx to 1 step -sk
  242.  
  243. 1220  for ye=ib to xe step sk
  244.  
  245. 1230  ax=xe:ay=ye+ib:gosub 1400:d1=d:ay=ye-ib:gosub 1400:d2=d
  246.  
  247. 1240  d=(d1+d2)/2+rnd(1)*l/2-l/4:ax=xe:ay=ye:gosub 1470
  248.  
  249. 1250  next ye
  250.  
  251. 1260  next xe:return
  252.  
  253. 1270  '
  254.  
  255. 1280  rem *** Heights along Z ***
  256.  
  257. 1290  '
  258.  
  259. 1300  for xe=0 to mx-1 step sk
  260.  
  261. 1310  for ye=ib to mx-xe step sk
  262.  
  263. 1320  ax=xe+ye-ib:ay=ye-ib:gosub 1400:d1=d
  264.  
  265. 1330  ax=xe+ye+ib:ay=ye+ib:gosub 1400:d2=d
  266.  
  267. 1340  ax=xe+ye:ay=ye:d=(d1+d2)/2+rnd(1)*l/2-l/4:gosub 1470
  268.  
  269. 1350  next ye
  270.  
  271. 1360  next xe:return
  272.  
  273. 1370  '
  274.  
  275. 1380  rem *** Return data from array ***
  276.  
  277. 1390  '
  278.  
  279. 1400  if ay>my then 1420
  280.  
  281. 1410  by=ay:bx=ax:goto 1430
  282.  
  283. 1420  by=mx+1-ay:bx=mx-ax
  284.  
  285. 1430  d=d(bx,by):return
  286.  
  287. 1440  '
  288.  
  289. 1450  rem *** Put data into array ***
  290.  
  291. 1460  '
  292.  
  293. 1470  if ay>my then 1490
  294.  
  295. 1480  by=ay:bx=ax:goto 1500
  296.  
  297. 1490  by=mx+1-ay:bx=mx-ax
  298.  
  299. 1500  d(bx,by)=d:return
  300.  
  301. 1510  '
  302.  
  303. 1520  rem *** Sea level section ***
  304.  
  305. 1530  '
  306.  
  307. 1540  if sealevel=0 then gosub 1750:return
  308.  
  309. 1550  if xo<>-999 then 1580
  310.  
  311. 1560  if zz<0 then gosub 2010:z2=zz:zz=0:goto 1740
  312.  
  313. 1570  gosub 2050:goto 1730
  314.  
  315. 1580  if z2>0 and zz>0 then gosub 1750:goto 1730
  316.  
  317. 1590  if z2<0 and zz<0 then z2=zz:zz=0:goto 1740
  318.  
  319. 1600  w3=zz/(zz-z2):x3=(x2-xx)*w3+xx:y3=(y2-yy)*w3+yy:z3=0
  320.  
  321. 1610  zt=zz:yt=yy:xt=xx
  322.  
  323. 1620  if zz>0 then 1710
  324.  
  325. 1630  '
  326.  
  327. 1640  rem *** Going into water ***
  328.  
  329. 1650  '
  330.  
  331. 1660  zz=z3:yy=y3:xx=x3:gosub 2320
  332.  
  333. 1670  gosub 2010:zz=0:yy=yt:xx=xt:z2=zt:goto 1740
  334.  
  335. 1680  '
  336.  
  337. 1690  rem *** Coming out of water ***
  338.  
  339. 1700  '
  340.  
  341. 1710  zz=z3:yy=y3:xx=x3:gosub 2320
  342.  
  343. 1720  gosub 2050:zz=zt:yy=yt:xx=xt
  344.  
  345. 1730  z2=zz
  346.  
  347. 1740  x2=xx:y2=yy:return
  348.  
  349. 1750  '
  350.  
  351. 1760  '  *** New Color Subroutine ***
  352.  
  353. 1770  '
  354.  
  355. 1780  if zz<0 then goto 1890
  356.  
  357. 1790  if zz>950 then pena 2:return
  358.  
  359. 1800  if zz>850 then pena 3:return
  360.  
  361. 1810  if zz>750 then pena 4:return
  362.  
  363. 1820  if zz>650 then pena 5:return
  364.  
  365. 1830  if zz>550 then pena 6:return
  366.  
  367. 1840  if zz>450 then pena 13:return
  368.  
  369. 1850  if zz>350 then pena 12:return
  370.  
  371. 1860  if zz>100 then pena 7:return
  372.  
  373. 1870  gosub 2050
  374.  
  375. 1880  return
  376.  
  377. 1890  '
  378.  
  379. 1900  '  *** below sea level ***
  380.  
  381. 1910  '
  382.  
  383. 1920  if zz>-200 then gosub 2010:return
  384.  
  385. 1930  if zz>-500 then pena 9:return
  386.  
  387. 1940  if zz>-800 then pena 10:return
  388.  
  389. 1950  if zz>-1200 then pena 11:return
  390.  
  391. 1960  pena 11
  392.  
  393. 1970  return
  394.  
  395. 1980  '
  396.  
  397. 1990  rem *** Switch to sea level color ***
  398.  
  399. 2000  '
  400.  
  401. 2010  pena 8:f1=1:return
  402.  
  403. 2020  '
  404.  
  405. 2030  rem *** Switch to land color ***
  406.  
  407. 2040  '
  408.  
  409. 2050  pena 14
  410.  
  411. 2060  f1=0:return
  412.  
  413. 2070  '
  414.  
  415. 2080  '   *** Rotation ***
  416.  
  417. 2090  '
  418.  
  419. 2100  if xx<>0 then 2130
  420.  
  421. 2110  if yy<=0 then ra=-pi/2:goto 2150
  422.  
  423. 2120  ra=pi/2:goto 2150
  424.  
  425. 2130  ra=atn(yy/xx)
  426.  
  427. 2140  if xx<0 then ra=ra+pi
  428.  
  429. 2150  r1=ra+rh:rd=sqr(xx*xx+yy*yy)
  430.  
  431. 2160  xx=rd*cos(r1):yy=rd*sin(r1)
  432.  
  433. 2170  return
  434.  
  435. 2180  '
  436.  
  437. 2190  rem *** Tilt down ***
  438.  
  439. 2200  '
  440.  
  441. 2210  rd=sqr(zz*zz+xx*xx)
  442.  
  443. 2220  if xx=0 then ra=pi/2:goto 2250
  444.  
  445. 2230  ra=atn(zz/xx)
  446.  
  447. 2240  if xx<0 then ra=ra+pi
  448.  
  449. 2250  r1=ra-vt
  450.  
  451. 2260  xx=rd*cos(r1)+xx:zz=rd*sin(r1)
  452.  
  453. 2270  return
  454.  
  455. 2280  '
  456.  
  457. 2290  rem *** Plot to (xp,yp) ***
  458.  
  459. 2300  '
  460.  
  461. 2310  gosub 1540
  462.  
  463. 2320  xx=xx*xs:yy=yy*ys:zz=zz*zs
  464.  
  465. 2330  gosub 2100:rem *** Rotate ***
  466.  
  467. 2340  gosub 2210:rem *** Tilt up ***
  468.  
  469. 2350  if xo=-999 then pr$="M" else pr$="D"
  470.  
  471. 2360  xp=int(yy)+cx:yp=int(zz)
  472.  
  473. 2370  gosub 2400
  474.  
  475. 2380  return
  476.  
  477. 2390  '
  478.  
  479. 2400  rem *** do plotting here ***
  480.  
  481. 2410  '
  482.  
  483. 2420  ask mouse x%,y%,b%:if b%<>0 then 2760
  484.  
  485. 2430  xp=xp*1.38:yp=48.53-0.663*yp:if pr$="M" then x8=xp:y8=yp
  486.  
  487. 2440  draw (x8,y8 to xp,yp):x8=xp:y8=yp:xo=xp
  488.  
  489. 2450  return
  490.  
  491. 2460  '
  492.  
  493. 2470  rem *** Plot X Axis ***
  494.  
  495. 2480  '
  496.  
  497. 2490  for ax=0 to mx:xo=-999:for ay=0 to ax
  498.  
  499. 2500  gosub 1400:zz=d:yy=ay/mx*10000:xx=ax/mx*10000-yy/2
  500.  
  501. 2510  gosub 2310:next ay:next ax
  502.  
  503. 2520  return
  504.  
  505. 2530  '
  506.  
  507. 2540  rem *** Plot Y Axis ***
  508.  
  509. 2550  '
  510.  
  511. 2560  for ay=0 to mx:xo=-999:for ax=ay to mx
  512.  
  513. 2570  gosub 1400:zz=d:yy=ay/mx*10000:xx=ax/mx*10000-yy/2
  514.  
  515. 2580  gosub 2310:next ax:next ay
  516.  
  517. 2590  return
  518.  
  519. 2600  '
  520.  
  521. 2610  rem *** Plot Z Axis ***
  522.  
  523. 2620  '
  524.  
  525. 2630  for ex=0 to mx:xo=-999:for ey=0 to mx-ex
  526.  
  527. 2640  ax=ex+ey:ay=ey:gosub 1400:zz=d:yy=ay/mx*10000
  528.  
  529. 2650  xx=ax/mx*10000-yy/2:gosub 2310:next ey:next ex
  530.  
  531. 2660  return
  532.  
  533. 2670  '
  534.  
  535. 2680  '   *** Setup Screen ***
  536.  
  537. 2690  '
  538.  
  539. 2700  close 2:cmd 1:graphic(1):gosub 760
  540.  
  541. 2710  tax=ax:tay=ay
  542.  
  543. 2720  gosub 2630
  544.  
  545. 2730  gosub 2560
  546.  
  547. 2740  gosub 2490
  548.  
  549. 2750  '
  550.  
  551. 2760  rem *** Main Menu Section ***
  552.  
  553. 2770  '
  554.  
  555. 2780  gosub 3370
  556.  
  557. 2790  print at(4,2);"-> Use Keyboard to Select <-"
  558.  
  559. 2800  print at(6,4);"1 - Start New Landscape"
  560.  
  561. 2810  ? at(6,5);"2 - Draw Existing Array"
  562.  
  563. 2820  ? at(6,6);"3 - Save Fractal Array"
  564.  
  565. 2830  ? at(6,7);"4 - Load Fractal Array"
  566.  
  567. 2840  ? at(6,8);"5 - Reset Scaling Factors"
  568.  
  569. 2850  ? at(6,9);"6 - Set Sea Level Options"
  570.  
  571. 2860  rem ? at(6,10);"7 - Read & Display Mouse x,y"
  572.  
  573. 2870  ? at(6,11);"7 - Close This Window !"
  574.  
  575. 2880  ? at(10,12);"Click the Left Button"
  576.  
  577. 2890  ? at(10,13);"To Restore Menu"
  578.  
  579. 2900  ? at(6,14);"0 - Exit to ABasiC"
  580.  
  581. 2910  pena 0:gosub 4500
  582.  
  583. 2920  print at(10,16);"Selection (0-8) ";:input a$
  584.  
  585. 2930  query=val(a$):print at(10,16);spc(20):erase a$
  586.  
  587. 2940  on query goto 3120,4140,3650,3760,4240,4010,4000,4000,4000
  588.  
  589. 2950  '
  590.  
  591. 2960  rem *** Program exit ***
  592.  
  593. 2970  '
  594.  
  595. 2980  scnclr:close 3
  596.  
  597. 2990  cmd 1:scnclr:close 1
  598.  
  599. 3000  cmd 0:pena 0
  600.  
  601. 3010  '
  602.  
  603. 3020  rem *** Restore ABasiC's colours ***
  604.  
  605. 3030  '
  606.  
  607. 3040  rgb 0,6,9,15
  608.  
  609. 3050  rgb 1,0,0,0
  610.  
  611. 3060  rgb 2,15,15,15
  612.  
  613. 3070  gosub 750
  614.  
  615. 3080  clr:end
  616.  
  617. 3090  '
  618.  
  619. 3100  rem *** Start a new fractal screen ***
  620.  
  621. 3110  '
  622.  
  623. 3120  scnclr:close 3
  624.  
  625. 3130  '
  626.  
  627. 3140  rem *** New landscape ***
  628.  
  629. 3150  '
  630.  
  631. 3160  cmd 1:graphic(1):scnclr
  632.  
  633. 3170  gosub 3330
  634.  
  635. 3180  '
  636.  
  637. 3190  rem *** Prompt to begin drawing ***
  638.  
  639. 3200  '
  640.  
  641. 3210  print at(2,2);"Click the Left Mouse Button to Start."
  642.  
  643. 3220  print at(4,4);"Click While Drawing to Abort."
  644.  
  645. 3230  gosub 660:scnclr
  646.  
  647. 3240  print at(8,3);"Number of levels ";:input le
  648.  
  649. 3250  scnclr:if le<1 or le>7 then 3240
  650.  
  651. 3260  goto 950
  652.  
  653. 3270  '
  654.  
  655. 3280  rem *** Windows ***
  656.  
  657. 3290  '
  658.  
  659. 3300  window #1,0,0,639,199,"Fracscapes"
  660.  
  661. 3310  return
  662.  
  663. 3320  '
  664.  
  665. 3330  window #2,120,50,340,60,"New Fracscape"
  666.  
  667. 3340  cmd #2:graphic(0):scnclr
  668.  
  669. 3350  return
  670.  
  671. 3360  '
  672.  
  673. 3370  window #3,100,20,300,160,"Main Menu"
  674.  
  675. 3380  cmd 3:graphic(0):scnclr
  676.  
  677. 3390  return
  678.  
  679. 3400  '
  680.  
  681. 3410  window #4,100,50,400,40,"Save Array"
  682.  
  683. 3420  cmd 4:graphic(0):scnclr
  684.  
  685. 3430  return
  686.  
  687. 3440  '
  688.  
  689. 3450  window #5,100,100,400,40,"Load Array"
  690.  
  691. 3460  cmd 5:graphic(0):scnclr
  692.  
  693. 3470  return
  694.  
  695. 3480  '
  696.  
  697. 3490  window #6,100,20,340,130,"Array Description"
  698.  
  699. 3500  cmd 6:graphic(0):scnclr
  700.  
  701. 3510  return
  702.  
  703. 3520  '
  704.  
  705. 3530  window #7,100,30,340,60,"Sea Level Options"
  706.  
  707. 3540  cmd 7:graphic(0):scnclr
  708.  
  709. 3550  return
  710.  
  711. 3560  '
  712.  
  713. 3570  window #8,50,20,340,50,"Draw Array in Memory"
  714.  
  715. 3580  cmd 8:graphic(0)
  716.  
  717. 3590  return
  718.  
  719. 3600  '
  720.  
  721. 3610  window #9,150,30,300,130,"Scaling Settings"
  722.  
  723. 3620  cmd 9:graphic(0)
  724.  
  725. 3630  return
  726.  
  727. 3640  '
  728.  
  729. 3650  rem *** screen save ***
  730.  
  731. 3660  '
  732.  
  733. 3670  on error goto 4540
  734.  
  735. 3680  gosub 3410:name$=""
  736.  
  737. 3690  print at(2,2);"Save Array as -> ";:line input name$
  738.  
  739. 3700  d(0,65)=le:d(1,65)=mx:d(2,65)=my:d(3,65)=tax:d(4,65)=tay
  740.  
  741. 3710  d(5,65)=xs:d(6,65)=ys:d(7,65)=zs:d(8,65)=sealevel
  742.  
  743. 3720  bsave name$,a%,l%
  744.  
  745. 3730  scnclr:close 4:cmd 3
  746.  
  747. 3740  goto 4110
  748.  
  749. 3750  '
  750.  
  751. 3760  rem *** Screen Load ***
  752.  
  753. 3770  '
  754.  
  755. 3780  ' on error goto 5000
  756.  
  757. 3790  gosub 3450:name$=""
  758.  
  759. 3800  print at(2,2);"Name of Array to Load -> ";:line input name$
  760.  
  761. 3810  bload name$,a%
  762.  
  763. 3820  le=d(0,65):mx=d(1,65):my=d(2,65):ax=d(3,65):ay=d(4,65)
  764.  
  765. 3830  xs=d(5,65):ys=d(6,65):zs=d(7,65):sealevel=d(8,65)
  766.  
  767. 3840  scnclr:close 5
  768.  
  769. 3850  gosub 3490
  770.  
  771. 3860  ? at(7,2);"Array name -> ";name$
  772.  
  773. 3870  ? at(7,4);"Number of Levels -> ";le
  774.  
  775. 3880  if sealevel=0 then level$="off" else level$="on"
  776.  
  777. 3890  ? at(7,6);"Sea Level Display -> ";level$
  778.  
  779. 3900  ? at(7,8);"Scaling Values ->  X= ";xs
  780.  
  781. 3910  ? at(26,9);"Y= ";ys
  782.  
  783. 3920  ? at(26,10);"Z= ";zs
  784.  
  785. 3930  ? at(5,13);"Click left button to continue"
  786.  
  787. 3940  gosub 640
  788.  
  789. 3950  scnclr:close #6:cmd 3
  790.  
  791. 3960  goto 4110
  792.  
  793. 3970  '
  794.  
  795. 3980  rem *** Turn off menu window ***
  796.  
  797. 3990  '
  798.  
  799. 4000  scnclr:close 3:gosub 660:goto 2760
  800.  
  801. 4010  '
  802.  
  803. 4020  ' **** Set Sea Level Option ****
  804.  
  805. 4030  '
  806.  
  807. 4040  gosub 3530
  808.  
  809. 4050  print at (2,3);"Display sea level surface (Y/N) ";:input a$
  810.  
  811. 4060  if a$="y" or a$="Y" then sealevel=1 else sealevel=0:goto 4070
  812.  
  813. 4070  scnclr:close 7:cmd 3
  814.  
  815. 4080  '
  816.  
  817. 4090  '  ***  Error Trap ***
  818.  
  819. 4100  '
  820.  
  821. 4110  on error goto 4540
  822.  
  823. 4120  query=0:erase a$
  824.  
  825. 4130  goto 2920
  826.  
  827. 4140  '
  828.  
  829. 4150  ' *** Redraw old Array ***
  830.  
  831. 4160  '
  832.  
  833. 4170  if le=0 then 2920
  834.  
  835. 4180  gosub 3570
  836.  
  837. 4190  print at(2,2);"Clear Screen Before Re-Draw (Y/N) ";:input a$
  838.  
  839. 4200  scnclr:close 8:cmd 3:scnclr:close 3:cmd 1:graphic(1)
  840.  
  841. 4210  if a$="y" or a$="Y" then scnclr
  842.  
  843. 4220  erase a$:goto 2700
  844.  
  845. 4230  '
  846.  
  847. 4240  ' *** Scaling Settings ***
  848.  
  849. 4250  '
  850.  
  851. 4260  gosub 3610
  852.  
  853. 4270  graphic(0)
  854.  
  855. 4280  print at(5,2);"Current Scaling Settings :"
  856.  
  857. 4290  print at(13,4);"X= ";xs
  858.  
  859. 4300  print at(13,5);"Y= ";ys
  860.  
  861. 4310  print at(13,6);"Z= ";zs
  862.  
  863. 4320  print at(5,8);"Press C to Change Settings"
  864.  
  865. 4330  print at(11,9);"D for Default Settings"
  866.  
  867. 4340  print at(11,10);"X to Exit"
  868.  
  869. 4350  gosub 4500
  870.  
  871. 4360  print at(13,12);"Selection ";:input a$
  872.  
  873. 4370  if a$="c" or a$="C" then 4420
  874.  
  875. 4380  if a$="d" or a$="D" then gosub 4460:goto 4410
  876.  
  877. 4390  if a$<>"x" and a$<>"X" then 4410
  878.  
  879. 4400  scnclr:close 9:cmd 3:goto 4110
  880.  
  881. 4410  scnclr:erase a$:goto 4280
  882.  
  883. 4420  print at(13,12);spc(16)
  884.  
  885. 4430  print at(4,12);"Input New X,Y,Z ";:input xs,ys,zs
  886.  
  887. 4440  goto 4410
  888.  
  889. 4450  '
  890.  
  891. 4460  ' *** Stock Scaling Factors ***
  892.  
  893. 4470  '
  894.  
  895. 4480  xs=.04:ys=.04:zs=.05:return
  896.  
  897. 4490  '
  898.  
  899. 4500  for i=0 to 10
  900.  
  901. 4510  get a$:erase a$:next i
  902.  
  903. 4520  on error goto 4540
  904.  
  905. 4530  return
  906.  
  907. 4540  '
  908.  
  909. 4550  '
  910.  
  911. 4560  '    **** error trap ****
  912.  
  913. 4570  '
  914.  
  915. 4580  '
  916.  
  917. 4590  fmem%=fre
  918.  
  919. 4600  window #10,100,100,300,90,"Rats - An Error Occurred"
  920.  
  921. 4610  cmd #10:graphic(0):scnclr
  922.  
  923. 4620  ?at(2,2);"Error # ";err;" occurred at line ";erl
  924.  
  925. 4630  ?at(2,4);err$(err)
  926.  
  927. 4640  ?at(2,5);"There are ";fmem%;" bytes of memory showing"
  928.  
  929. 4650  ?at(2,7);"Click left button to continue...."
  930.  
  931. 4660  gosub 640
  932.  
  933. 4670  scnclr:close 10,3,4,5,6
  934.  
  935. 4680  goto 2760
  936.  
  937.