home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d0xx / d015 / polyfractals.lha / Polyfractals / fractals.bas < prev    next >
Encoding:
BASIC Source File  |  1986-03-08  |  7.3 KB  |  237 lines
  1. 5     clr:screen 0,5
  2. 6     drawmode 0
  3. 10    dim picture%(12000),regsave%(500),mandelinfo(500)
  4. 12    dim aa(10)
  5. 52    filename$="titlefractal":gosub 17060
  6. 55    flag=1:count = 50:speed%=1:gosub 25070
  7. 60    flag = 0
  8. 70    talk$=translate$("USE QUESTION MARK,FOR LIST OF COMMANDS!")
  9. 80    q%=narrate(talk$)
  10. 100   rem **** MAIN LOOP ****
  11. 110   get a$
  12. 120   if a$="D" or a$="d" then gosub 12000
  13. 140   if a$="L" or a$="l" then gosub 17000
  14. 150   if a$="S" or a$="s" then gosub 15000
  15. 160   if a$="C" or a$="c" then gosub 25000
  16. 170   if a$="Q" or a$="q" then goto 16000
  17. 180   if a$="?" or a$="/" then gosub 11000
  18. 200   if a$="M" or a$="m" then gosub 30000
  19. 500   goto 110
  20. 9999  rem **** DEFINE AREA TO MAGNIFY ****
  21. 10000 talk$ = translate$("PLACE POINTER AT THE REAL, AND, IMAGINARY CENTER!"):q% = narrate(talk$)
  22. 10002 talk$ = translate$("THEN, HOLD DOWN MOUSE BUTTUN, AND OUT LINE SECTION, TO MAGNIFY!")
  23. 10003 q%=narrate(talk$)
  24. 10005 gosub 10040
  25. 10010 ask mouse x%,y%,b%
  26. 10016 if a$<>"" then return
  27. 10020 if b% = 0 goto 10010
  28. 10030 goto 10005
  29. 10040 drawmode 2
  30. 10050 ask mouse x%,y%,b%
  31. 10055 x1%=x%:y1%=y%
  32. 10060 if b% = 0 goto 10050
  33. 10070 x2% = x1% : y2% = y1%
  34. 10080 ask mouse xx%,yy%,b%
  35. 10090 if xx% = x2% goto 10080
  36. 10092 if x%-abs(xx%-x%) < 0 or xx% > 302 then 10080
  37. 10093 if y%-(abs(xx%-x%)*.62) < 0 or y%+(abs(xx%-x%)*.62) > 186 then 10080
  38. 10095 x3%=xx%
  39. 10100 if b%=0 then 10150
  40. 10110 box (x1%,y1%;x2%,y2%)
  41. 10120 x1%=x%-abs(xx%-x%):x2%=xx%
  42. 10122 y1%=y%-(abs(xx%-x%)*.62):y2%=y%+(abs(xx%-x%)*.62)
  43. 10130 box(x1%,y1%;x2%,y2%)
  44. 10140 if b% <> 0 goto 10080
  45. 10150 drawmode 0
  46. 10155 peno 1:box(x1%,y1%;x2%,y2%)
  47. 10156 erase aa:dim aa(500)
  48. 10160 aa(1)=mandelinfo(5)+(x%*mandelinfo(7))
  49. 10170 aa(2)=(x2%-x1%)*mandelinfo(7)
  50. 10180 aa(3)=mandelinfo(6)+((186-y%)*mandelinfo(8))
  51. 10190 aa(4)=aa(2)*.77
  52. 10200 aa(5)=aa(1)-(aa(2)/2)
  53. 10210 aa(6)=aa(3)-(aa(4)/2)
  54. 10220 aa(7)=aa(2)/302
  55. 10230 aa(8)=aa(4)/186
  56. 10250 return
  57. 11000 rem **** MENU ****
  58. 11010 window #1,0,0,180,160,"   MENU    "
  59. 11020 cmd #1
  60. 11030 ? " "
  61. 11040 ? " C... Cycle Colors"
  62. 11050 ? " D... Define area"
  63. 11060 ? "      to magnify."
  64. 11070 ? " L... Load a Picture"
  65. 11080 ? " M... Draw magnified"
  66. 11085 ? "      area."
  67. 11090 ? " Q... Quit"
  68. 11100 ? " S... Save a Picture"
  69. 11110 ? " ?... This Menu"
  70. 11115 ?:? "Click mouse twice":? "in window to":? "continue!"
  71. 11120 ask mouse x%,y%,b%
  72. 11130 if b%=0 then 11120
  73. 11140 cmd #0:close #1:return
  74. 12000 rem **** DEFINE MANUALLY OR WITH MOUSE ****
  75. 12010 window #1,70,100,180,200,"  DEFINE  "
  76. 12020 cmd #1
  77. 12030 ?:? "**  DEFINE AREA  **"
  78. 12040 ?:? "  1... MANUALLY"
  79. 12050 ?:? "  2... WITH MOUSE"
  80. 12060 ?:?:input "  Enter Choice: ";choice$
  81. 12070 if choice$ = "2" then cmd #0:close #1:goto 10000
  82. 12080 cmd #0:close #1:window #1,0,0,320,200,"     MANUAL  DEFINE     "
  83. 12085 CMD #1
  84. 12090 ?:?:input "Real number center: ";aa(1)
  85. 12100 ?:input "Real number range: ";aa(2)
  86. 12102 aa(5)=aa(1)-aa(2)/2
  87. 12104 xe=aa(5)+aa(2)
  88. 12106 aa(7)=(xe-aa(5))/302
  89. 12110 ?:input "Imaginary number center: ";aa(3)
  90. 12120 ?:input "Autoscale Imaginary Axis (Y/N) ";char$
  91. 12130 if char$="Y" or char$="y" then 12170
  92. 12140 ?:input "Imaginary number range: ";aa(4)
  93. 12150 aa(6)=aa(3)-aa(4)/2
  94. 12160 ye=aa(6)+aa(4):goto 12190
  95. 12170 aa(6)=aa(3)-(aa(2)*.77)/2
  96. 12180 ye=aa(6)+aa(2)*.77
  97. 12190 aa(8)=(ye-aa(6))/186
  98. 12200 cmd #0:close #1:return
  99. 15000 rem **** SAVE A FRACTAL PICTURE ****
  100. 15020 x1%=0:y1%=0
  101. 15050 x2%=305:y2%=188
  102. 15070 erase picture%
  103. 15080 size% = int(((x2%-x1%)/16)+2)
  104. 15090 size% = size%*(y2%-y1%)
  105. 15100 size% = ((((size%*5)+4)/2)+10)
  106. 15110 dim picture%(size%)
  107. 15120 sshape (x1%,y1%;x2%,y2%),picture%()
  108. 15130 window #1,10,50,300,35,"   SAVE    "
  109. 15140 cmd #1
  110. 15150 print "SIZE= ";size%:input "Enter a Filename: ";filename$
  111. 15160 close #1:cmd #0
  112. 15165 if filename$="" then 15400
  113. 15170 bsave filename$,varptr(picture%(0)),4*size%
  114. 15180 colorfile$=filename$+"_dat"
  115. 15190 ct=0
  116. 15200 for i%=0 to 31
  117. 15210 ask rgb i%,red%,green%,blue%
  118. 15220 regsave%(ct)=red%:regsave%(ct+1)=green%:regsave%(ct+2)=blue%
  119. 15230 ct=ct+3
  120. 15240 next i%
  121. 15250 bsave colorfile$,varptr(regsave%(0)),400
  122. 15260 infofile$=filename$+"_info"
  123. 15270 bsave infofile$,varptr(mandelinfo(0)),100
  124. 15400 return
  125. 15999 rem **** I QUIT ****
  126. 16000 talk$=translate$("I QUIT!"):q% = narrate(talk$)
  127. 16010 SCREEN 0,4:RGB 15,0,0,0:END
  128. 16999 rem **** LOAD A FRACTAL PICTURE ****
  129. 17000 window #1,0,0,320,200,"    LOAD    "
  130. 17001 cmd #1
  131. 17002 input "Which drive are pictures on: ";a$
  132. 17004 if a$ < "0" or a$ > "1" then ?:? "Drive must be ( 0 or 1 ) !":goto 17002
  133. 17006 if a$ = "0" then shell "list pat #?(_info) quick"
  134. 17010 cmd #1
  135. 17011 if a$ = "1" then shell "list df1: pat #?(_info) quick"
  136. 17015 ?:? "DO NOT include <_info> in filename!":?
  137. 17020 input "Enter a filename: ";filename$
  138. 17030 cmd #0:close #1
  139. 17035 if filename$ = "" then return
  140. 17060 x%=0:y%=0
  141. 17080 erase picture%:dim picture%(11000)
  142. 17082 on error goto 58000
  143. 17084 colorfile$=filename$+"_dat":infofile$=filename$+"_info"
  144. 17085 name$=colorfile$
  145. 17086 bload colorfile$,varptr(regsave%(0))
  146. 17087 name$=infofile$
  147. 17088 bload infofile$,varptr(mandelinfo(0))
  148. 17089 name$=filename$
  149. 17090 bload filename$,varptr(picture%(0))
  150. 17095 scnclr
  151. 17100 gshape (x%,y%),picture%()
  152. 17125 ON ERROR GOTO 0
  153. 17130 ct=0
  154. 17140 for i%=0 to 31
  155. 17150 rgb i%,regsave%(ct),regsave%(ct+1),regsave%(ct+2)
  156. 17160 ct=ct+3
  157. 17170 next i%
  158. 17400 return
  159. 25000 rem **** CYCLE COLORS ****
  160. 25010 window #1,0,20,300,50,"  CYCLE COLORS   "
  161. 25020 cmd #1
  162. 25055 input "Speed of rotation: ";speed%
  163. 25060 cmd #0:close #1
  164. 25070 ask rgb 1,r%,g%,b%
  165. 25080 for i%=14 to 1 step -1
  166. 25090 ask rgb i%,r1%,g1%,b1%
  167. 25100 rgb i%,r%,g%,b%
  168. 25110 r%=r1%:g%=g1%:b%=b1%
  169. 25120 ask mouse x%,y%,button%:if button%=4 then goto 25200
  170. 25121 get a$:if a$<>"" then 25200
  171. 25125 sleep(speed%)
  172. 25130 next i%
  173. 25135 if flag = 0 then 25140
  174. 25136 count=count - 1:if count = 0 then 25200
  175. 25140 goto 25070
  176. 25200 ct=0
  177. 25210 for i% = 0 to 31
  178. 25220 rgb i%,regsave%(ct),regsave%(ct+1),regsave%(ct+2)
  179. 25230 ct=ct+3
  180. 25240 next i%
  181. 25250 return
  182. 30000 rem **** compute fractal variables ****
  183. 30005 for i%=0 to 10:swap mandelinfo(i%),aa(i%):next i%
  184. 30010 xs=mandelinfo(1)
  185. 30020 rrange = mandelinfo(2)
  186. 30030 xs=xs-rrange/2
  187. 30040 xe=xs+rrange
  188. 30050 xstep=(xe-xs)/302
  189. 30060 ys=mandelinfo(3)
  190. 30070 ys=ys-(rrange*.77)/2
  191. 30080 ye=ys+rrange*.77
  192. 30090 ystep=(ye-ys)/186
  193. 30095 scnclr
  194. 30100 ?:?:? "  Low iteration values allow the map":? "to be drawn faster,but lose accuracy."
  195. 30110 ? "  A value of 100 takes several hours.
  196. 30120 ?:input "Enter Iteration limit: ";climit
  197. 30122 if climit=0 then for i%=0 to 10:swap mandelinfo(i%),aa(i%):next i%
  198. 30130 cdivfac=climit/15
  199. 30140 gosub 60000:gosub 15000:return
  200. 58000 window #1,0,50,300,100,"    ERROR    "
  201. 58010 cmd #1
  202. 58020 if err=53 then print "SORRY, but I can't find":? "         ";name$:goto 58040
  203. 58030 print "DISK ERROR #";err
  204. 58035 ?:? "             ";name$
  205. 58040 ?:? "PRESS any key to continue."
  206. 58050 getkey char$
  207. 58060 cmd #0:close #1
  208. 58070 resume 100
  209. 60000 scnclr:x=xs
  210. 60010 for xp%=0 to 302
  211. 60020 y=ys
  212. 60030 for yp%=186 to 0 step -1
  213. 60040 az=0:bz=0:ac=x:bc=y
  214. 60050 count%=0:size=0
  215. 60060 while count%<climit and size<2
  216. 60070 atq=az*az-bz*bz
  217. 60080 btq=az*bz*2
  218. 60090 az=atq+ac:bz=btq+bc
  219. 60100 tsiz=az*az+bz*bz
  220. 60110 sqin=tsiz
  221. 60120 sqout=sqr(sqin)
  222. 60130 size=sqout
  223. 60140 count%=count%+1
  224. 60150 wend
  225. 60160 pcolor%=count%/cdivfac
  226. 60170 if pcolor%>15 then pcolor%=15
  227. 60180 pena pcolor%
  228. 60190 draw (xp%,yp%)
  229. 60200 get char$
  230. 60210 if char$<>"" then xp%=320:yp%=-1
  231. 60220 y=y+ystep
  232. 60230 next yp%
  233. 60240 x=x+xstep
  234. 60250 next xp%
  235. 60260 pena 15
  236. 60270 return
  237.