home *** CD-ROM | disk | FTP | other *** search
/ 17 Bit Software 1: Collection A / 17Bit_Collection_A.iso / files / 35.dms / 35.adf / fractal7.bas < prev    next >
BASIC Source File  |  1988-05-22  |  5KB  |  131 lines
  1. 10    screen 1,4,0: randomize -1: pena 7
  2. 20    dim d(128,64)
  3. 30    input "Number of levels <1-7> ";le: if le < 1 or le > 7 then 30
  4. 40    ds=2: for n=1 to le:ds=ds+2^(n-1):next n
  5. 50    mx=ds-1:my=mx/2:rh=pi*30/180:vt=rh*1.2
  6. 60    for n=1 to le:L=10000/1.8^n
  7. 70    ?: ? "Working on level ";n
  8. 80    ib=mx/2^n:sk=ib*2
  9. 90    gosub 150: ' *** Assign heights along X in array ***
  10. 100   gosub 220: ' *** Assign heights along Y in array ***
  11. 110   gosub 290: ' *** Assign heights along diag. in array ***
  12. 120   next n
  13. 130   goto 640:  ' *** Draw ***
  14. 140   ' *** Heights along x ***
  15. 150   for ye = 0 to mx - 1 step sk
  16. 160   for xe = ib+ye to mx step sk
  17. 170   ax = xe-ib: ay = ye: gosub 370: d1=d: ax = xe+ib: gosub 370:                 d2 = d
  18. 180   d = (d1+d2)/2 + rnd(1) * L/2 - L/4: ax = xe: ay = ye: gosub 420
  19. 190   next xe
  20. 200   next ye: return
  21. 210   ' *** Heights along Y ***
  22. 220   for xe = mx to 1 step -sk
  23. 230   for ye = ib to xe step sk
  24. 240   ax = xe: ay = ye + ib: gosub 370: d1 = d: ay = ye - ib: gosub 370:           d2 = d
  25. 250   d = (d1+d2)/2 + rnd(1) * L/2 - L/4: ax = xe: ay = ye: gosub 420
  26. 260   next ye
  27. 270   next xe: return
  28. 280   ' *** Heights along diag. ***
  29. 290   for xe = 0 to mx - 1 step sk
  30. 300   for ye = ib to mx - xe step sk
  31. 310   ax = xe + ye - ib: ay = ye - ib: gosub 370: d1 = d
  32. 320   ax = xe + ye + ib: ay = ye + ib: gosub 370: d2 = d
  33. 330   ax = xe + ye: ay = ye: d = (d1+d2)/2 + rnd(1) * L/2 - L/4:                  gosub 420
  34. 340   next ye
  35. 350   next xe: return
  36. 360   ' *** Return data from array ***
  37. 370   if ay > my then 390
  38. 380   by = ay: bx = ax: goto 400
  39. 390   by = mx+1-ay: bx = mx-ax
  40. 400   d = d(bx,by): return
  41. 410   ' *** Put data into array ***
  42. 420   if ay > my then 440
  43. 430   by = ay: bx = ax: goto 450
  44. 440   by = mx+1-ay: bx = mx-ax
  45. 450   d(bx,by) = d: return
  46. 460   ' *** Put in sea level here ***
  47. 470   if xo <> -999 then 500
  48. 480   if zz < 0 then gosub 1070: z2 = zz: zz = 0: goto 620
  49. 490   gosub 1090: goto 610
  50. 500   if z2 > 0 and zz > 0 then 610
  51. 510   if z2 < 0 and zz < 0 then z2 = zz: zz = 0: goto 620
  52. 520   w3 = zz/(zz-z2): x3 = (x2-xx) * w3 + xx: y3 = (y2-yy) * w3 + yy:             z3 = 0
  53. 530   zt = zz: yt = yy: xt = xx
  54. 540   if zz > 0 then 590
  55. 550   ' *** Going into water ***
  56. 560   zz = z3: yy = y3: xx = x3: gosub 950
  57. 570   gosub 1070: zz = 0: yy = yt: xx = xt: z2 = zt: goto 620
  58. 580   ' *** Coming up out of water ***
  59. 590   zz = z3: yy= y3: xx= x3: gosub 950
  60. 600   gosub 1090: zz = zt: yy = yt: xx = xt
  61. 610   z2 = zz
  62. 620   x2 = xx: y2 = yy: return
  63. 630   ' **** Display here ****
  64. 640   gosub 1100: ' *** Set up plotting device or screen ***
  65. 650   xs = .04: ys = .04: zs = .04: ' *** scaling factors ***
  66. 660   for ax = 0 to mx: xo = -999: for ay = 0 to ax
  67. 670   gosub 370: zz = d: yy = ay/mx * 10000: xx = ax/mx * 10000 - yy/2
  68. 680   gosub 940: next ay: next ax
  69. 690   for ay = 0 to mx: xo = -999: for ax = ay to mx
  70. 700   gosub 370: zz = d: yy = ay/mx * 10000: xx = ax/mx * 10000 - yy/2
  71. 710   gosub 940: next ax: next ay
  72. 720   for ex = 0 to mx: xo = -999: for ey = 0 to mx-ex
  73. 730   ax = ex + ey: ay = ey: gosub 370: zz = d: yy = ay/mx *10000
  74. 740   xx = ax/mx * 10000 - yy/2: gosub 940: next ey: next ex
  75. 750   goto 1130: ' *** done plotting, goto end loop ***
  76. 760   ' *** Rotate ***
  77. 770   if xx <> 0 then 800
  78. 780   if yy <= 0 then ra = -pi/2: goto 820
  79. 790   ra = pi/2: goto 820
  80. 800   ra = atn(yy/xx)
  81. 810   if xx < 0 then ra = ra + pi
  82. 820   r1 = ra + rh: rd = sqr (xx*xx + yy*yy)
  83. 830   xx = rd * cos(r1): yy = rd * sin(r1)
  84. 840   return
  85. 850   ' *** Tilt down ***
  86. 860   rd = sqr(zz*zz + xx*xx)
  87. 870   if xx = 0 then ra = pi/2: goto 900
  88. 880   ra = atn (zz/xx)
  89. 890   if xx < 0 then ra = ra + pi
  90. 900   r1 = ra - vt
  91. 910   xx = rd * cos(r1) + xx: zz = rd * sin(r1)
  92. 920   return
  93. 930   ' *** Move or plot to (xp,yp)
  94. 940   gosub 470
  95. 950   xx = xx * xs: yy = yy * ys: zz = zz * zs
  96. 960   gosub 770: ' *** Rotate ***
  97. 970   gosub 860: ' *** Tilt up ***
  98. 980   if xo = -999 then pr$ = "M"
  99. 985   if xo <> -999 then pr$ = "D"
  100. 990   xp = int(yy) + cx: yp = int(zz)
  101. 1000  gosub 1030
  102. 1010  return
  103. 1020  ' *** plot line here ***
  104. 1030  xp = xp * 1.3: yp = 33.14 - .623 * yp
  105. 1040  if pr$ = "M" then x8 = xp: y8 = yp: xo = x
  106. 1045  if y8 > 199 or y8 < 0 or yp > 199 or yp < 0 then return
  107. 1050  draw (x8,y8 to xp,yp): x8 = xp: y8 = yp: return
  108. 1060  ' *** switch to sea color ***
  109. 1070  pena 11: return
  110. 1080  ' *** switch to land color ***
  111. 1090  pena 8: return
  112. 1100  ' * * * setup plotting device or screen * * *
  113. 1110  scnclr: pena 1: area (0,0 to 0,200 to 620,200 to 620,0 to 0,0):              return
  114. 1120  ' *** End loop ***
  115. 1130  getkey a$
  116. 1140  end
  117. 60000 '   This program come from "Creative Computing" July 1985 pp 78-82
  118. 60010 ' by Michiel van de Panne.  He used the method of generating
  119. 60020 ' fractal landscapes from the September 1984 issue of "Scientific
  120. 60030 ' American".  To modify the program you can change the color of
  121. 60040 ' pena in line 1070 and in line 1090.  You can change the
  122. 60050 ' background color by changing pena to a different color in line
  123. 60060 ' 1110.  The program can only handle 6 levels with a dimension of
  124. 60070 ' d(64,32) in line 20 -- if you want to wait for level 7 to be
  125. 60080 ' plotted, change line 20 to dimension d as dim d(128,64) for 
  126. 60090 ' 16384 triangles to generated.
  127. 60100 '   The size of the landscape can be scaled in line 1030.
  128. 60110 ' Line 10 and lines 1030-1040 have the computer dependent code.
  129. 60120 ' To remove the seas from the landscape change line 470 to read
  130. 60130 ' 470 return
  131.