home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / forth / fifth.arc / MANDEL.FIV < prev    next >
Encoding:
Text File  |  1986-05-27  |  6.7 KB  |  416 lines
  1. CREATE MANDEL
  2. CREATE MACHINE
  3. EDIT
  4. ( TI=0 / IBM=1 Machine flag)
  5. 0 constant machine
  6. ~UP
  7. CREATE XMAX
  8. CREATE X
  9. EDIT
  10. ( Maximum X for this machine)
  11. : x machine if 320 else 720 endif ;
  12. ~UP
  13. EDIT
  14. ( Maximum X value)
  15. x constant xmax
  16. ~UP
  17. CREATE YMAX
  18. CREATE Y
  19. EDIT
  20. : y machine if 200 else 300 endif ;
  21. ~UP
  22. EDIT
  23. y constant ymax
  24. ~UP
  25. CREATE GCLS
  26. EDIT
  27. : GCLS  cls 4 vmode
  28.         0 0 0 xmax 1- ymax 1- FILLBOX
  29. ;
  30. ~UP
  31. CREATE DIS
  32. EDIT
  33. : dis
  34.  
  35. 8 0 do
  36.   i 0 palette
  37. loop
  38. ;
  39. ~UP
  40. CREATE H#
  41. EDIT
  42. \ Hex constant
  43. : h# base @ 16 base ! ' ['] literal execute base ! ; immediate
  44. ~UP
  45. CREATE R87
  46. EDIT
  47. \ Parse a following 8087 register ==> stack element 0-7.
  48. : r87
  49.   ' dup 8 u< not abort" Register must be 0-7"
  50.   ;
  51. ~UP
  52. CREATE POP?
  53. EDIT
  54. \ 8087 operation & POP if trailing P : FADD P1 ==> FADDP ST(1)
  55. : pop?
  56.   >in @
  57.   begin
  58.     dup c@@ dup 32 = over 13 = or over 10 = or swap 9 = or while
  59.     1+ repeat
  60.   dup c@@ dup 80 = swap 112 = or
  61.   if 1+ >in ! h# DE c,
  62.   else drop h# D8 c, endif
  63.   ;
  64. ~UP
  65. CREATE FINIT
  66. EDIT
  67. \ Initilize 8087
  68. : finit
  69.   h# DB c, h# E3 c, ; immediate
  70. ~UP
  71. CREATE FLD
  72. EDIT
  73. \ Load real to 8087 stack & pop Fifth stack
  74. : fld
  75.   h# 9B c,                      \ FWAIT
  76.   h# D9 c, h# 46 c, h# 00 c,    \ FLD [BP+0]
  77.   h# 83 c, h# C5 c, h# 04 c,    \ ADD BP,4
  78.   h# 9B c,                      \ FWAIT
  79.   ; immediate
  80. ~UP
  81. CREATE FSTP
  82. EDIT
  83. \ Push 8087 real to Fifth stack, pop from 8087.
  84. : fstp
  85.   h# 9B c,                      \ FWAIT
  86.   h# 83 c, h# C5 c, h# FC c,    \ ADD BP,-4
  87.   h# D9 c, h# 5E c, h# 00 c,    \ FSTP [BP+0]
  88.   h# 9B c,                      \ FWAIT
  89.   ; immediate
  90. ~UP
  91. CREATE FPICK
  92. EDIT
  93. \ PICK a value on the 8087 stack, must be 0-7: FPICK87 3
  94. : fpick
  95.   r87
  96.   h# 9B c,              \ FWAIT
  97.   h# D9 c, h# C0 + c,   \ FLD ST(i)
  98.   ; immediate
  99. ~UP
  100. CREATE FSWAP
  101. EDIT
  102. \ Exchange 8087 TOS with the nth register, must be 0-7
  103. : fswap
  104.   r87
  105.   h# 9B c,              \ FWAIT
  106.   h# D9 c, h# C8 + c,   \ FXCH ST(i)
  107.   ; immediate
  108. ~UP
  109. CREATE FPOP
  110. EDIT
  111. \ Drop an 8087 value
  112. : fpop
  113.   h# 9B c,              \ FWAIT
  114.   h# D9 c, h# D8 c,     \ FSTP ST(0)
  115.   ; immediate
  116. ~UP
  117. CREATE FADD
  118. EDIT
  119. \ Add two 8087 numbers
  120. : fadd
  121.   h# 9B c,              \ FWAIT
  122.   pop? r87 h# C0 + c,   \ FADD ST(i)
  123.   ; immediate
  124. ~UP
  125. CREATE FMUL
  126. EDIT
  127. \ Multiply two 8087 numbers
  128. : fmul
  129.   h# 9B c,              \ FWAIT
  130.   pop? r87 h# C8 + c,   \ FMUL ST(i)
  131.   ; immediate
  132. ~UP
  133. CREATE FSUB
  134. EDIT
  135. \ Subtract two 8087 numbers
  136. : fsub
  137.   h# 9B c,              \ FWAIT
  138.   pop? r87 h# E0 + c,   \ FSUB ST(i)
  139.   ; immediate
  140. ~UP
  141. CREATE FSUBR
  142. EDIT
  143. \ Subtract reversed two 8087 numbers
  144. : fsubr
  145.   h# 9B c,              \ FWAIT
  146.   pop? r87 h# E8 + c,   \ FSUBR ST(i)
  147.   ; immediate
  148. ~UP
  149. CREATE FDIV
  150. EDIT
  151. \ Divide two 8087 numbers
  152. : fdiv
  153.   h# 9B c,              \ FWAIT
  154.   pop? r87 h# F0 + c,   \ FDIV ST(i)
  155.   ; immediate
  156. ~UP
  157. CREATE FDIVR
  158. EDIT
  159. \ Divide reversed two 8087 numbers
  160. : fdivr
  161.   h# 9B c,              \ FWAIT
  162.   pop? r87 h# F8 + c,   \ FDIVR ST(i)
  163.   ; immediate
  164. ~UP
  165. CREATE H
  166. EDIT
  167. variable h
  168. ~UP
  169. CREATE SPEED
  170. EDIT
  171. create speed 1 ,
  172. ~UP
  173. CREATE DRAW
  174. CREATE X
  175. EDIT
  176. \ Real part start
  177. -2. constant x
  178. ~UP
  179. CREATE Y
  180. EDIT
  181. \ Imaginary part start
  182. -2. constant y
  183. ~UP
  184. CREATE SX
  185. EDIT
  186. \ Size of real part
  187. 4. constant sx
  188. ~UP
  189. CREATE SY
  190. EDIT
  191. \ Size of imagniary part
  192. 4. constant sy
  193. ~UP
  194. CREATE GX
  195. EDIT
  196. \ Real pixel gap
  197. sx xmax i->f f/ constant gx
  198. ~UP
  199. CREATE GY
  200. EDIT
  201. \ Imaginary pixel gap
  202. sy ymax i->f f/ constant gy
  203. ~UP
  204. CREATE CNTABLE
  205. EDIT
  206. \ Count of iterations, determines color
  207. create cntable
  208. 10 ,    \ Black
  209. 20 ,    \ Blue
  210. 40 ,    \ Red
  211. 80 ,    \ Purple
  212. 160 ,   \ Green
  213. 320 ,   \ Light blue
  214. 640 ,   \ Yellow
  215. 1280 ,  \ White
  216. ~UP
  217. CREATE XC
  218. EDIT
  219. \ real corner of pixel in progress
  220. variable xc
  221. ~UP
  222. CREATE YC
  223. EDIT
  224. \ imaginary corner of pixel in progress
  225. variable yc
  226. ~UP
  227. CREATE CNT
  228. EDIT
  229. \ count of iterations until z explodes
  230. variable cnt
  231. ~UP
  232. EDIT
  233. \ Exploring the Mandelbrot set
  234. : draw
  235. speed !
  236. xmax 0 do
  237.   gx i i->f f* x f+ xc !
  238.   ymax 0 do
  239.     gy i i->f f* y f+ yc !
  240.     63 cnt !
  241.     0. 0.
  242.     63 0 do
  243.       finit
  244.       fld fld fpick 0 fmul 0 fpick 2 fmul 0 fpick 1 fadd 1 fstp
  245.       fsubr p1 xc @ fld fadd p1 fstp
  246.       fmul p1 -2. fld fmul p1 yc @ fld fadd p1 fstp
  247.       stack abc|bca 4. f< if else i cnt ! leave endif
  248.       loop
  249.     drop drop
  250.     cnt @     \                       dup pad c! pad 1 h @ write drop drop
  251.  
  252.     j i pset
  253.     speed @ +loop
  254.   ?term if key dup 49 = if 1 speed +! else
  255.                dup 48 = if -1 speed +! speed @ 0= if 1 speed ! endif else
  256.                abort endif endif endif
  257.   speed @ +loop
  258.   ;
  259. ~UP
  260. CREATE LOOK
  261. EDIT
  262. : look
  263.   " m.dat " 1+ 0 open if h ! else ." open error " . quit endif
  264.   100000 0 do
  265.     pad 1 h @ read  drop drop
  266.    pad @ . cr
  267.   loop
  268. ;
  269. ~UP
  270. CREATE PLAY
  271. CREATE DATA
  272. CREATE DATA1
  273. EDIT
  274. create data1 33000 allot
  275. ~UP
  276. CREATE DATA2
  277. EDIT
  278. create data2 33000 allot
  279. ~UP
  280. CREATE DATA3
  281. EDIT
  282. create data3 33000 allot
  283. ~UP
  284. CREATE DATA4
  285. EDIT
  286. create data4 33000 allot
  287. ~UP
  288. CREATE DATA5
  289. EDIT
  290. create data5 33000 allot
  291. ~UP
  292. CREATE DATA6
  293. EDIT
  294. create data6 33000 allot
  295. ~UP
  296. CREATE DATA7
  297. EDIT
  298. create data7 33000 allot
  299. ~UP
  300. CREATE WHICH
  301. CREATE TABLE
  302. EDIT
  303. create table
  304.  
  305.  data1 , 32768 0 * ,
  306.  data2 , 32768 1 * ,
  307.  data3 , 32768 2 * ,
  308.  data4 , 32768 3 * ,
  309.  data5 , 32768 4 * ,
  310.  data6 , 32768 5 * ,
  311.  data7 , 32768 6 * ,
  312. ~UP
  313. CREATE LOAD
  314. CREATE TRY
  315. EDIT
  316. : try
  317.  
  318. 0
  319. 10 0 do
  320.   i . dup . 32767 + dup . 1+ cr
  321. loop
  322. drop
  323. ;
  324. ~UP
  325. EDIT
  326. : load
  327.  
  328. " m.dat" 1+ 0 open  if h ! else ." open error (which) " . quit endif
  329. data1 32768 h @ read ." data1 " . . cr
  330. data2 32768 h @ read ." data2 " . . cr
  331. data3 32768 h @ read ." data3 " . . cr
  332. data4 32768 h @ read ." data4 " . . cr
  333. data5 32768 h @ read ." data5 " . . cr
  334. data6 32768 h @ read ." data6 " . . cr
  335. data7 [ 216000 32768 6 * - ] literal h @ read ." data7 " . . cr
  336. h @ close if else ." close error (which) " . quit endif
  337.  
  338. ;
  339. ~UP
  340. EDIT
  341. : which
  342. 3 shl table + dup @ swap 4 + @ - +
  343. ;
  344. load
  345. ~UP
  346. EDIT
  347. : data
  348.   dup 15 shr which c@
  349. ;
  350. ~UP
  351. CREATE MAP
  352. CREATE DEFINE
  353. CREATE LOG
  354. EDIT
  355. : log
  356. 20 - abs
  357. 0 begin over while 1+ swap 2 / swap repeat
  358. swap drop
  359. ;
  360. ~UP
  361. EDIT
  362. : define create
  363.  
  364. 256 0 do i log 8 mod dup . c, loop
  365.  
  366. does>
  367.      swap 255 and + c@
  368. ;
  369. ~UP
  370. EDIT
  371. define map
  372. ~UP
  373. CREATE MSET
  374. CREATE ROTATE
  375. EDIT
  376. : rotate
  377.  
  378. 0 vmode
  379. 1000 0 do
  380. i
  381. 8 0 do
  382. dup 7 and i swap palette
  383. 1+
  384. ?term if quit endif
  385. loop
  386. drop  1000 0 do loop
  387. loop
  388. ;
  389. ~UP
  390. EDIT
  391. : mset
  392. 4 vmode
  393. 0
  394. xmax 0 do
  395.   ymax 0 do
  396.     dup data map j i pset
  397.     1+
  398.   loop
  399.   ?term if quit endif
  400. loop
  401. key drop
  402. ;
  403. ~UP
  404. EDIT
  405. ~UP
  406. EDIT
  407. : mandel
  408.  gcls
  409. \   " m.dat" 1+ 1 open if h ! else ." open failed " . quit then 1 draw
  410. begin 1 while
  411. speed @ draw
  412. repeat
  413. key drop
  414. ;
  415. ~UP
  416. ABORT
  417.