home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FIFTH21.ZIP / MANDEL.FIV < prev    next >
Encoding:
Text File  |  1986-04-23  |  4.6 KB  |  268 lines
  1. CREATE MANDEL
  2. CREATE MACHINE
  3. EDIT
  4. ( TI=0 / IBM=1 Machine flag)
  5. 1 constant machine
  6. ~UP
  7. CREATE XMAX
  8. CREATE X
  9. EDIT
  10. ( Maximum X for this machine)
  11. : x machine if 225 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 DRAW
  170. CREATE X
  171. EDIT
  172. \ Real part start
  173. -2. constant x
  174. ~UP
  175. CREATE Y
  176. EDIT
  177. \ Imaginary part start
  178. -2. constant y
  179. ~UP
  180. CREATE SX
  181. EDIT
  182. \ Size of real part
  183. 4. constant sx
  184. ~UP
  185. CREATE SY
  186. EDIT
  187. \ Size of imagniary part
  188. 4. constant sy
  189. ~UP
  190. CREATE GX
  191. EDIT
  192. \ Real pixel gap
  193. sx xmax i->f f/ constant gx
  194. ~UP
  195. CREATE GY
  196. EDIT
  197. \ Imaginary pixel gap
  198. sy ymax i->f f/ constant gy
  199. ~UP
  200. CREATE XC
  201. EDIT
  202. \ real corner of pixel in progress
  203. variable xc
  204. ~UP
  205. CREATE YC
  206. EDIT
  207. \ imaginary corner of pixel in progress
  208. variable yc
  209. ~UP
  210. CREATE CNT
  211. EDIT
  212. \ count of iterations until z explodes
  213. variable cnt
  214. ~UP
  215. CREATE SETUP
  216. EDIT
  217. : setup  finit  2. fld -2. dup fld fld 0. dup fld fld ;
  218. ~UP
  219. CREATE .FS
  220. EDIT
  221. : .fs
  222.   fstp fstp fstp fstp
  223.   dup . fld   dup . fld   dup . fld   dup . fld   ;
  224. ~UP
  225. CREATE FOUR
  226. EDIT
  227. 4. constant four
  228. ~UP
  229. CREATE DRAW2
  230. EDIT
  231. \ Exploring the Mandelbrot set
  232. : draw2
  233.       fpick 0 fmul 0 fpick 2 fmul 0 fpick 0 fadd 2 fstp
  234.       fsub p1 fadd 3
  235.       fpick 5 fmul 2 fmul  3 fadd 5
  236.       fswap 3 fpop fswap 1 fpop
  237.       .fs     ;
  238. ~UP
  239. EDIT
  240. \ Exploring the Mandelbrot set
  241. : draw
  242. xmax 0 do  y gy f- yc !
  243.   gx i i->f f* x f+
  244.   ymax 0 do  dup
  245.     gy yc @ f+ dup yc !
  246.     finit  -2. fld   fld  fld  0 fld 0 fld
  247.     64 cnt !
  248.     64 1 do
  249.       fpick 0 fmul 0 fpick 2 fmul 0 fpick 0 fadd 2 fstp
  250.       fsub p1 fadd 3
  251.       fpick 5 fmul 2 fmul  3 fadd 5
  252.       fswap 3 fpop fswap 1 fpop
  253.       four > if i cnt ! leave endif   loop
  254.     cnt @ j i pset
  255.       loop  drop   ?term if key drop abort endif
  256.    loop
  257.   ;
  258. ~UP
  259. EDIT
  260. : mandel
  261.  gcls
  262. begin 1 while
  263. draw
  264. repeat
  265. key drop
  266. ;
  267. ~UP
  268. ABORT