home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / prog1 / 4th_86.lzh / MAND.PRO < prev    next >
Text File  |  1989-02-15  |  6KB  |  192 lines
  1. ( The following is two routines -- MAND -- and JULIA -- written in UCC Forth.
  2.    They are essentially the same as the C code in Jan/Feb '88 
  3.    MicroCornucopia, but they use the modulus value to determine the plot
  4.    color rather than the loop count. This gives pictures much closer to
  5.    those in Peitgen & Richter.
  6.       The default iteration count is 20 rather than 1000, as this gives 
  7.    faster plotting, and pictures which are quite reasonable. A new value of 
  8.    iteration count can be entered on the command line -- 1000 MAND --.
  9.     The original code has been "tweaked" in various places, and -- 
  10.    compared with the conventional C-programmed implementations which take 
  11.    from several hours to a day to complete -- this code is quite speedy.)
  12.  
  13. ( forget new
  14. : new ; )
  15. off printload
  16.  
  17. : sqr ,dup f* ;
  18.  
  19. 640 const maxcol ( for EGA card)
  20. 350 const maxrow
  21. 7 const maxcolr ( forget high intensity colours - not used anyway)
  22. 2 block MINCOL ( to be bumped between multiple passes)
  23. 2 block minrow ( likewise)
  24. 2 block maxit ( max number of iterations - entered on command line)
  25. 1.0 ,const maxsiz 
  26.  
  27. 2 block colr ( single precision variables)
  28. 2 block row
  29. 2 block col
  30.  
  31. 4 block P ( floating point variables)
  32. 4 block Q
  33. 4 block modulus
  34. 4 block deltaP
  35. 4 block deltaQ
  36. 4 block Xcur 
  37. 4 block Xlast
  38. 4 block xlasts
  39. 4 block Ycur
  40. 4 block Ylast
  41. 4 block ylasts
  42.  
  43. 4 block deltaX
  44. 4 block deltaY
  45. 4 block Pmax
  46. 4 block Pmin
  47. 4 block Qmax
  48. 4 block Qmin
  49. 4 block Pinc
  50. 4 block Qinc
  51.  
  52. 4 block Xmax
  53. 4 block Xmin
  54. 4 block Ymax
  55. 4 block Ymin
  56.  
  57. : init
  58.  
  59. 0 mincol !
  60. 0 minrow !
  61. 20 maxit ! ( just in case)
  62.  
  63. -2.00   Pmin ,!  ( alternative values can be loaded from file)
  64. 0.5    Pmax ,!
  65. -1.25    Qmin ,!
  66. 1.25   Qmax ,! 
  67.  
  68. -1.8         Xmin ,!
  69. 1.8         Xmax ,!
  70. -1.8        Ymin ,!
  71. 1.8         Ymax ,! 
  72. -0.74543    P    ,!
  73. 0.11301       Q    ,!
  74.  
  75. ;
  76.  
  77. : fred           ( loop to evaluate z = z**2 + c )
  78.      (  xlast ,@ ,dup f* xlasts ,! ylast ,@ ,dup f* ylasts ,! )
  79.                getsts if norm q-u-it then 
  80.       repeat modulus ,@  4.0 ,< colr @ maxit @ < and 
  81.     while 
  82.       xlast ,@ ylast ,@ f- xlast ,@ ylast ,@ f+ f* P ,@ f+
  83.                         ( P + xsq - ysq on stack) 
  84.      xlast ,@  ,dup  f+ ylast ,@ f* Q ,@ f+ 
  85.                         ( Q + 2xy on stack)
  86.      colr @ 1+ colr ! ( needed ONLY for 'while' limit above)
  87.      ylast ,!
  88.      ,dup ,dup xlast ,! 
  89.                    f*  ylast ,@ ,dup f* f+ modulus ,! 
  90.     endwhile 
  91.  
  92.     modulus ,@ 10.0 f* integer single ( convert modulus to color value)
  93.      case 
  94.           of[ 0 THRU 1 ] drop 0 colr ! endof
  95.           of[ 1 THRU 2 ] drop 1 colr ! endof
  96.           of[ 2 THRU 3 ] drop 2 colr ! endof
  97.           of[ 3 THRU 4 ] drop 3 colr ! endof
  98.           of[ 4 THRU 5 ] drop 4 colr ! endof
  99.           of[ 5 THRU 6 ] drop 5 colr ! endof
  100.           of[ 6 THRU 7 ] drop 6 colr ! endof
  101.           of[ 7 THRU 8 ] drop 6 colr ! endof 
  102.  
  103. (          0 of 0 colr ! endof
  104.           1 of 0 colr ! endof
  105.           2 of 1 colr ! endof
  106.           3 of 2 colr ! endof
  107.           4 of 3 colr ! endof
  108.           5 of 4 colr ! endof
  109.           6 of 5 colr ! endof
  110.           7 of 6 colr ! endof )
  111.         drop 6 colr ! endcase  ;
  112.  
  113. : draw ( symmetrical draw about horizontal axis )
  114.     3 pick maxrow 4 pick - 2 + 3 pick ( mirror parameters)
  115.             mincol @ if dpix else d4pix then  ( draw bottom to centre)
  116.             mincol @ if dpix else d4pix then ; ( draw top to centre)
  117.     ( dpix draws one pixel - d4pix draws 4 in a row)
  118.  
  119. : mandd  Pmin ,@ P ,!
  120.   maxcol mincol @ do           ( col is j is P   row is i is Q )
  121.  
  122.      Qmin ,@ Q ,! 
  123.  
  124.     maxrow 2 / 1+  minrow @ do ( calculate half screen only)
  125.  
  126.           Pmin ,@ j double float deltaP ,@ f* f+ P ,! 
  127.             Qmin ,@ i double float deltaQ ,@ f* f+ Q ,! 
  128.  
  129.       ,0 xlast ,! 
  130.       ,0 ylast ,! 
  131.       ,0 modulus ,! 0 colr ! fred
  132.  
  133.  
  134.     j i colr @ dup if draw else 3 kill ( exit ) then 
  135.                            ( no need to draw black pixels)
  136.  
  137. (                    Q ,@ Qinc ,@ f+ Q ,! )
  138.  
  139.    8 +loop
  140. (     P ,@ Pinc ,@ f+ P ,! )
  141. 8 +loop ; ( draw coarse pattern rapidly - then fill in with multiple passes)
  142.  
  143. : mand init ( depth 0= if 20 then maxit ! ) ( enter parameter on command line)
  144.                                      ( or use 20 as default)
  145.       egam ( set EGA card to 640 x 350 and blank screen)
  146.  
  147.  Pmax ,@ Pmin ,@ f-  maxcol double float 1.0 f- f/  deltap ,! 
  148.  Qmax ,@ Qmin ,@ f-  maxrow double float 1.0 f- f/  deltaq ,!
  149.  
  150.       Pmin ,@ P ,!    8.0 deltaP ,@ f* Pinc ,!
  151.       Qmin ,@ Q ,!    8.0 deltaQ ,@ f* Qinc ,! 
  152.  
  153.  
  154.   8 0 do ( multiple staggered passes of mandd loop)
  155.   7 0 do         mandd 
  156.  
  157. minrow @ 1 + minrow !            1 +loop 
  158. mincol @ dup 0= if 4 + else 1+ then mincol ! 0 minrow ! 1 +loop ;
  159.  
  160.  
  161. : jul 
  162.  
  163.   maxcol mincol @ do           ( col is j is P   row is i is Q )
  164.     maxrow minrow @ do
  165.     0.0 modulus ,! 0 colr !
  166.       Xmin ,@ j double float deltaX ,@ f* f+ Xlast ,!
  167.       Ymin ,@ i double float deltaY ,@ f* f+ Ylast ,! 
  168.  
  169.      fred 
  170.  
  171.     j i colr @ dup if  
  172.             mincol @ if dpix else d4pix then
  173.                 else 3 kill then 
  174.  
  175.    8 +loop
  176. 8 +loop ;
  177.  
  178. : julia init ( depth 0= if 20 then maxit ! ) egam
  179.  
  180.  Xmax ,@ Xmin ,@ f-  maxcol double float 1.0 f- f/  deltax ,! 
  181.  Ymax ,@ Ymin ,@ f-  maxrow double float 1.0 f- f/  deltay ,!
  182.  
  183.   8 0 do 
  184.   7 0 do         jul
  185.  
  186. minrow @ 1 + minrow !            1 +loop 
  187. mincol @ dup 0= if 4 + else 1+ then mincol ! 0 minrow ! 1 +loop ;
  188.  
  189.  
  190.  
  191. : aaa mand ;
  192.