home *** CD-ROM | disk | FTP | other *** search
/ No Fragments Archive 10: Diskmags / nf_archive_10.iso / MAGS / ST_USER / 1989 / USER1089.MSA / LANDSCAP.LST < prev    next >
File List  |  1985-11-19  |  7KB  |  331 lines
  1. Rem GFA Basic Landscape Creator
  2. Rem By C.Stratford
  3. Rem (c) Atari ST User
  4. Dim A$(16)
  5. Dim Hx%(4)
  6. Dim Hy%(4)
  7. Openw 0
  8. Deffill 0,1,3
  9. Rem Set palette
  10. Setcolor 0,0,0,0
  11. Setcolor 1,0,0,7
  12. Setcolor 2,0,7,0
  13. Setcolor 15,7,7,7
  14. Rem Set default values
  15. Size%=25
  16. Plane%=4
  17. Waterlevel%=0
  18. Quake%=5
  19. Rem Set menus
  20. For I%=0 To 16
  21. Read A$(I%)
  22. Next I%
  23. Menu A$()
  24. Menu 15,2
  25. On Menu  Gosub Branch
  26. Do
  27. On Menu
  28. Loop
  29. Rem Branch routine
  30. Procedure Branch
  31. Menu Off
  32. If A$(Menu(0))=" About Quake " Then
  33. Alert 0,"Fault Line     | Generator    |Written by|C.Straford |",1,"Continue",Z
  34. Endif
  35. If A$(Menu(0))=" Simulate       " Then
  36. Gosub Simulate
  37. Endif
  38. If A$(Menu(0))=" Set Parameters " Then
  39. Gosub Parameters
  40. Endif
  41. If A$(Menu(0))=" Save Picture   " Then
  42. Gosub Picsave
  43. Endif
  44. If A$(Menu(0))=" Quit           " Then
  45. Gosub Quit
  46. Endif
  47. If A$(Menu(0))=" Change depth " Then
  48. Gosub Depthchange
  49. Endif
  50. Return
  51. Rem Quit
  52. Procedure Quit
  53. Alert 3,"Are you absolutely certain|that you want to do this?",2," Yes | No ",Yesno%
  54. If Yesno%=1 Then
  55. Setcolor 0,7,7,7
  56. Setcolor 15,0,0,0
  57. Edit
  58. Endif
  59. Return
  60. Rem Depth change
  61. Procedure Depthchange
  62. Gosub Change(*Waterlevel%,"waterlevel")
  63. Gosub Display
  64. Return
  65. Rem Set Parameters
  66. Procedure Parameters
  67. Change$="|Do you wish to change this?"
  68. M$="The current size for the|grid is:"+Str$(Size%)+Change$
  69. Alert 2,M$,1,"Yes|No",Ans
  70. If Ans=1
  71. Gosub Change(*Size%,"grid size")
  72. Endif
  73. M$="The current number of|planes is:"+Str$(Plane%)+Change$
  74. Alert 2,M$,1,"Yes|No",Ans
  75. If Ans=1
  76. Gosub Change(*Plane%,"number of planes")
  77. Endif
  78. M$="The current number of|fault lines is:"+Str$(Quake%)+Change$
  79. Alert 2,M$,1,"Yes|No",Ans
  80. If Ans=1
  81. Gosub Change(*Quake%,"number of fault lines")
  82. Endif
  83. M$="The current|waterlevel is:"+Str$(Waterlevel%)+Change$
  84. Alert 2,M$,1,"Yes|No",Ans
  85. If Ans=1
  86. Gosub Change(*Waterlevel%,"waterlevel")
  87. Endif
  88. Menu 15,2
  89. Return
  90. Rem Change
  91. Procedure Change(Item%,Message$)
  92. Rem save part of current screen
  93. Get 30,80,290,132,Storage$
  94. Rem Draw box to put text in
  95. Deffill 1,1,1
  96. Pbox 30,80,290,120
  97. Deffill 0,1,1
  98. Pbox 31,81,289,119
  99. Deffill 0,1,1
  100. Text 33,95,"What do you wish to change"
  101. M$="the "+Message$+" to?"
  102. Text 33,103,M$
  103. Print At(5,14);
  104. Input ">",Change%
  105. *Item%=Change%
  106. Rem Put original screen back
  107. Put 30,80,Storage$
  108. Return
  109. Rem Saves picture in Neo format
  110. Procedure Picsave
  111. Fileselect "*.*","",Filename$
  112. If Filename$<>"" Then
  113. Rem Save colours
  114. Rem May be a few extra colours in Neochrome
  115. Rem as not all of the colour registers are cleared
  116. Dpoke Xbios(2)-124,0
  117. Dpoke Xbios(2)-122,&H7
  118. Dpoke Xbios(2)-120,&H70
  119. Dpoke Xbios(2)-94,&H777
  120. For I=Xbios(2)-92 To Xbios(2)-1
  121. Poke I,0
  122. Next I
  123. Bsave Filename$,Xbios(2)-128,32128
  124. Endif
  125. Return
  126. Rem Simulate routine
  127. Procedure Simulate
  128. Hidem
  129. Erase Map%()
  130. Erase Totalmap%()
  131. Cls
  132. Co=0.866
  133. Setcolor 2,0,7,0
  134. Setcolor 1,0,1,7
  135. Color 1
  136. Rem Set up arrays used for storing landscape
  137. Dim Map%(Plane%,Size%,Size%)
  138. Dim Totalmap%(Size%,Size%)
  139. Rem Clear arrays
  140. Arrayfill Totalmap%(),0
  141. Arrayfill Map%(),0
  142. Cls
  143. For K%=1 To Plane%
  144. For I%=1 To Quake%
  145. Rem Choose random fault line
  146. X1=Rnd*Size%
  147. X2=Rnd*Size%
  148. Y1=Rnd*Size%
  149. Y2=Rnd*Size%
  150. While X1=X2
  151. X1=Rnd*Size%
  152. Wend
  153. M=(Y2-Y1)/(X2-X1)
  154. Y%=Int(Rnd*Size%)
  155. X%=Int(Rnd*Size%)
  156. C%=Y%-M*X%
  157. Rem Choose which land mass moves up and which moves down
  158. Value%=Random(101)
  159. If Odd(Value%) Then
  160. Updown%=-1
  161. Else
  162. Updown%=1
  163. Endif
  164. For X%=0 To Size%
  165. L%=Int((M*X%)+C%)
  166. For Y%=0 To Size%
  167. Rem Shift landmasses up or down
  168. If Y%>=L% Then
  169. Map%(K%,X%,Y%)=Map%(K%,X%,Y%)+Updown%
  170. Else
  171. Map%(K%,X%,Y%)=Map%(K%,X%,Y%)-Updown%
  172. Endif
  173. Next Y%
  174. Next X%
  175. Next I%
  176. Rem draw array in 3D plane
  177. Cls
  178. Print K%;"/";Plane%
  179. Xscale=319/(Size%*(1+Co))
  180. Yscale=179/Size%*0.5
  181. Mscale%=5
  182. Rem Draw lines across
  183. For Y%=0 To Size%
  184. Plot Y%*Co*Xscale,125-(Y%+Map%(K%,0,Y%))*Yscale
  185. For X%=1 To Size%
  186. Draw  To (Y%*Co+X%)*Xscale,125-(Y%+Map%(K%,X%,Y%))*Yscale
  187. Next X%
  188. Next Y%
  189. Rem Draw lines down
  190. For X%=0 To Size%
  191. Plot X%*Xscale,125-(Map%(K%,X%,0)*Yscale)
  192. For Y%=0 To Size%
  193. Draw  To (Y%*Co+X%)*Xscale,125-(Y%+Map%(K%,X%,Y%))*Yscale
  194. Next Y%
  195. Next X%
  196. Next K%
  197. Rem Add planes together
  198. For X%=0 To Size%
  199. For Y%=0 To Size%
  200. For K%=1 To Plane%
  201. Totalmap%(X%,Y%)=Totalmap%(X%,Y%)+Map%(K%,X%,Y%)
  202. Next K%
  203. Totalmap%(X%,Y%)=Totalmap%(X%,Y%)*2/Plane%
  204. Next Y%
  205. Next X%
  206. Gosub Display
  207. Showm
  208. Return
  209. Rem Display planes
  210. Procedure Display
  211. Hidem
  212. Deffill 3,1,3
  213. Cls
  214. For Y%=Size% Downto 0
  215. For X%=0 To Size%
  216. If X%=Size% Then
  217. X1%=X%
  218. Else
  219. X1%=X%+1
  220. Endif
  221. If Y%=0 Then
  222. Y1%=Y%
  223. Else
  224. Y1%=Y%-1
  225. Endif
  226. Rem Load arrays ready for the Polyfill/Polyline instructions
  227. Hx%(0)=(Y%*Co+X%)*Xscale
  228. Hy%(0)=125-(Y%+Totalmap%(X%,Y%))*Yscale
  229. Hx%(1)=((Y1%)*Co+X%)*Xscale
  230. Hy%(1)=125-((Y1%)+Totalmap%(X%,Y1%))*Yscale
  231. Hx%(2)=((Y1%)*Co+(X1%))*Xscale
  232. Hy%(2)=125-((Y1%)+Totalmap%(X1%,Y1%))*Yscale
  233. Hx%(3)=(Y%*Co+(X1%))*Xscale
  234. Hy%(3)=125-(Y%+Totalmap%(X1%,Y%))*Yscale
  235. Hx%(4)=Hx%(0)
  236. Hy%(4)=Hy%(0)
  237. Polyfill 5,Hx%(),Hy%()
  238. Polyline 5,Hx%(),Hy%()
  239. If Totalmap%(X%,Y%)<Waterlevel% Then
  240. Hy%(0)=125-(Y%+Waterlevel%)*Yscale
  241. Hy%(1)=125-(Y1%+Waterlevel%)*Yscale
  242. Hy%(2)=Hy%(1)
  243. Hy%(3)=Hy%(0)
  244. Hy%(4)=Hy%(0)
  245. Deffill 2,1,3
  246. Polyfill 5,Hx%(),Hy%()
  247. Deffill 3,1,3
  248. Endif
  249. Next X%
  250. Next Y%
  251. Rem fill in gaps at edges
  252. Deffill 3,1,3
  253. For Y%=Size%-1 Downto 0
  254. Hx%(0)=(Y%*Co+Size%)*Xscale
  255. Hy%(0)=125-(Y%+Waterlevel%)*Yscale
  256. Hx%(1)=((Y%+1)*Co+Size%)*Xscale
  257. Hy%(1)=125-((Y%+1)+Waterlevel%)*Yscale
  258. Hx%(2)=Hx%(1)
  259. Hy%(2)=125-((Y%+1)+Totalmap%(Size%,Y%+1))*Yscale
  260. Hx%(3)=Hx%(0)
  261. Hy%(3)=125-(Y%+Totalmap%(Size%,Y%))*Yscale
  262. Hx%(4)=Hx%(0)
  263. Hy%(4)=Hy%(0)
  264. Polyfill 5,Hx%(),Hy%()
  265. Polyline 5,Hx%(),Hy%()
  266. Next Y%
  267. For X%=0 To Size%-1
  268. Hx%(0)=X%*Xscale
  269. Hy%(0)=125-Waterlevel%*Yscale
  270. Hx%(1)=(X%+1)*Xscale
  271. Hy%(1)=125-Waterlevel%*Yscale
  272. Hx%(2)=Hx%(1)
  273. Hy%(2)=125-Totalmap%(X%+1,0)*Yscale
  274. Hx%(3)=Hx%(0)
  275. Hy%(3)=125-Totalmap%(X%,0)*Yscale
  276. Hx%(4)=Hx%(0)
  277. Hy%(4)=Hy%(0)
  278. Polyfill 5,Hx%(),Hy%()
  279. Polyline 5,Hx%(),Hy%()
  280. Next X%
  281. Rem Blank out the filled edges to give picture appearence of a flat plane
  282. Rem floating in space. The section can be removed
  283. Rem <-- Cut Here
  284. Deffill 0,1,3
  285. Pbox 0,125-Waterlevel%*Yscale,640,200
  286. Hx%(0)=Size%*Xscale
  287. Hy%(0)=125-Waterlevel%*Yscale
  288. Hx%(1)=(Size%*Co+Size%)*Xscale
  289. Hy%(1)=125-(Size%+Waterlevel%)*Yscale
  290. Hx%(2)=640
  291. Hy%(2)=Hy%(1)
  292. Hx%(3)=640
  293. Hy%(3)=Hx%(0)
  294. Hx%(4)=Hx%(0)
  295. Hy%(4)=Hy%(0)
  296. Polyfill 5,Hx%(),Hy%()
  297. Rem Draw stars for decoration
  298. For I%=1 To 40
  299. X%=Random(639)
  300. Y%=Random(199)
  301. While Point(X%,Y%)<>0
  302. X%=Random(639)
  303. Y%=Random(199)
  304. Wend
  305. Plot X%,Y%
  306. Next I%
  307. Rem <-- Cut to here
  308. Showm
  309. Menu 15,3
  310. Return
  311. Rem Menu data
  312. Rem Remember spaces, otherwise menus look untidy
  313. Data Info
  314. Data " About Quake "
  315. Data -
  316. Data -
  317. Data -
  318. Data -
  319. Data -
  320. Data ""
  321. Data Options
  322. Data " Simulate       "
  323. Data " Set Parameters "
  324. Data " Save Picture   "
  325. Data " Quit           "
  326. Data ""
  327. Data " Depth "
  328. Data " Change depth "
  329. Data ""
  330.  
  331.