home *** CD-ROM | disk | FTP | other *** search
/ 64'er 1987 October / 64er_Magazin_87-10_1987_Markt__Technik_de.d64 / fr.berge.flaeche (.txt) < prev    next >
Commodore BASIC  |  2022-10-26  |  4KB  |  148 lines
  1. 10 rem ****************************
  2. 20 rem *      fraktale berge      *
  3. 30 rem * 1987 by stefan vilsmeier *
  4. 40 rem ****************************
  5. 50 :
  6. 60 if a=0 then a=1:load "fractal.obj",8,1
  7. 70 dim h%(128,128),s%(319,1),f%(7,7)
  8. 80 open 1,8,15,"u9":close 1: rem diese zeeile kann bei problemen mit dem
  9. 90 rem floppyspeeder weggelassen werden!
  10. 100 poke53280,15:poke53281,15
  11. 110 input "[147][151]grad ";g
  12. 120 input "meereshoehe ";n
  13. 130 input "lichtquelle ";l1,l2,l3
  14. 140 l=sqr(l1*l1+l2*l2+l3*l3)
  15. 150 l1=l1/l:l2=l2/l:l3=l3/l
  16. 160 rem *********** variablen *****
  17. 170 w=128:d=.5:h=128:u=180:r=10:ge=2.25:sq=.866
  18. 180 gosub 3500
  19. 200 rem ********* anfangswerte ****
  20. 210 rem (koennen variiert werden)
  21. 220 h%(0,0)=0
  22. 230 h%(128,0)=0
  23. 240 h%(0,128)=0
  24. 250 h%(64,0)=0
  25. 260 h%(0,64)=0
  26. 270 h%(64,64)=0
  27. 300 rem ********* grafik ein ******
  28. 310 sys50176,11,15:sys50179,1:sys50194
  29. 350 :
  30. 360 :
  31. 370 rem ****************************
  32. 380 rem *     berge berechnen      *
  33. 390 rem ****************************
  34. 400 :
  35. 410 for m=1 to g
  36. 420 :br=w*10:w2=w/2
  37. 430 :for t=0 to 127 step w
  38. 440 : for i=0 to 127-t step w
  39. 450 :  b=(h%(i,t)+h%(i+w,t))/2
  40. 460 :   h%(i+w2,t)=b+(rnd(1)-d)*br
  41. 470 :  b=(h%(t,i)+h%(t,i+w))/2
  42. 480 :   h%(t,i+w2)=b+(rnd(1)-d)*br
  43. 490 :  b=(h%(128-t-i,i)+h%(128-t-i-w,i+w))/2
  44. 500 :   h%(128-t-i-w2,i+w2)=b+(rnd(1)-d)*br
  45. 510 : next i
  46. 520 :next t
  47. 530 w=w/2
  48. 540 next m
  49. 650 :
  50. 660 :
  51. 670 rem ****************************
  52. 680 rem *     berge zeichnen       *
  53. 690 rem ****************************
  54. 700 :
  55. 710 for t=0 to 127 step w
  56. 720 :a=t/2:b=a+w:c=(t+w)/2:f=c+w
  57. 730 :ss=ge*w:hh=sq*ss:v3=ss*hh
  58. 740 :ya=(t+w)+u-h:yb=t+u-h
  59. 750 :for i=0 to 127-t step w
  60. 760 : ii=127-t-w
  61. 770 : h1=h%(i,t)/10:if h1<n then h1=n
  62. 780 : h2=h%(i,t+w)/10:if h2<n then h2=n
  63. 790 : h3=h%(i+w,t)/10:if h3<n then h3=n
  64. 800 : h4=h%(i+w,t+w)/10:if h4<n then h4=n
  65. 810 : x1=(i+a)*ge+r:y1=yb-h1
  66. 820 : x2=(i+c)*ge+r:y2=ya-h2
  67. 830 : x3=(i+b)*ge+r:y3=yb-h3
  68. 840 : x4=(i+f)*ge+r:y4=ya-h4
  69. 850 : gosub 3200:gosub 3300:ifh1=0andh2=0andh3=0thenfa=0
  70. 860 : x=x1:xx=x3:y=y1:yy=y3:gosub 2000
  71. 870 : x=x2:xx=x1:y=y2:yy=y1:gosub 2000
  72. 880 : x=x2:xx=x3:y=y2:yy=y3:gosub 2000
  73. 890 : if i>ii goto 1010
  74. 900 : gosub 3200:gosub 3320:ifh2=0andh3=0andh4=0thenfa=0
  75. 910 : x=x3:xx=x4:y=y3:yy=y4:gosub 2000
  76. 920 : x=x4:xx=x2:y=y4:yy=y2:gosub 2000
  77. 930 : x=x2:xx=x3:y=y2:yy=y3:gosub 2000
  78. 1010 :next i
  79. 1020 next t
  80. 1500 get a$:if a$="" goto 1500
  81. 1510 sys 50179,0:if a$<>"s" then goto 80:rem neustart
  82. 1540 :
  83. 1550 :
  84. 1560 rem ***************************
  85. 1570 rem *   'grafik speichern'    *
  86. 1580 rem ***************************
  87. 1590 :
  88. 1600 input "grafik-name ";n$
  89. 1610 open 2,8,2,"pi."+n$+",p,w":sys 50191:close 2
  90. 1620 goto 80:rem neustart
  91. 1950 :
  92. 1960 :
  93. 1970 rem ***************************
  94. 1980 rem *      schattieren        *
  95. 1990 rem ***************************
  96. 2000 :
  97. 2010 we=abs(x-xx)/(x-xx)
  98. 2020 sg=(y-yy)/(x-xx):ys=yy
  99. 2030 for xs=xx to x step we
  100. 2040 :ys=ys+sg*we
  101. 2050 :ifs%(xs,0)=0ands%(xs,1)=0thens%(xs,0)=ys:s%(xs,1)=ys:goto2080
  102. 2060 :ifys>s%(xs,1)thens%(xs,1)=ys:gosub3000:goto2080
  103. 2070 :ifys<s%(xs,0)thens%(xs,0)=ys:gosub3000
  104. 2080 next
  105. 2090 return
  106. 3000 if s%(xs,0)=0 or s%(xs,1)=0 then return
  107. 3010 bx=7 and xs
  108. 3020 for v=s%(xs,0) to s%(xs,1)
  109. 3030 :zm=0:if fa<f%(bx,vand7)then zm=1
  110. 3040 :if bx<0 or bx>319 or v<0 or v>199 goto 3060
  111. 3050 :sys 50182,xs,v,zm
  112. 3060 next v
  113. 3070 return
  114. 3200 for p=0 to 319:s%(p,0)=0:s%(p,1)=0:next:return
  115. 3250 :
  116. 3260 :
  117. 3270 rem ***************************
  118. 3280 rem * winkel zum licht ber.   *
  119. 3290 rem ***************************
  120. 3300 :
  121. 3310 v1=-hh*(h3-h1):v3=ss*((h1+h3)/2-h2):goto 3330
  122. 3320 v1=-hh*(h2-h0):v3=ss*((h0+h2)/2-h1)
  123. 3330 l=sqr(v1*v1+v2*v2+v3*v3):if l=0 then l=.000000001
  124. 3340 co=abs((l1*v1+l2*v2+l3*v3)/l)
  125. 3350 if co>1 then co=1
  126. 3360 fa=co*50
  127. 3370 return
  128. 3450 :
  129. 3460 :
  130. 3470 rem ***************************
  131. 3480 rem *    raster einlesen      *
  132. 3490 rem ***************************
  133. 3500 :
  134. 3510 for i=0 to 7
  135. 3520 :for t=0 to 7
  136. 3530 : read f%(t,i)
  137. 3540 :next t
  138. 3550 next i
  139. 3560 return
  140. 3600 data  0, 8,53,61, 2,10,55,63
  141. 3610 data 16,24,37,45,18,26,39,47
  142. 3620 data 49,57, 4,12,51,59, 6,14
  143. 3630 data 33,41,20,28,35,43,22,30
  144. 3640 data  3,11,54,62, 1, 9,52,60
  145. 3650 data 19,27,38,46,17,25,36,44
  146. 3660 data 50,58, 7,15,48,56, 5,13
  147. 3670 data 34,42,23,31,32,40,21,29
  148.