home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 100.lha / FramSet / mset.f < prev    next >
Encoding:
FORTH Source  |  1986-11-21  |  9.7 KB  |  406 lines
  1. \ Mset.f
  2.  
  3. \ MSET stands for Mandelbrot set.
  4.  
  5. \ use Mset.script to turnkey Mset application...
  6.  
  7. \ the main word:  M_SET  or MS (in short)
  8. \ the token word: Mset.token
  9.  
  10. \ purpose : to compute & display the Mandelbrot set of a given range
  11. \           of values on X and Y axis.
  12.  
  13. \ The user is asked for the required parameters : resolution, starting
  14. \ X and Y coordinate and the Range.
  15.  
  16. \ The user has 2 choices of resolutions: 320x200 (low) or 320x400 (high).
  17. \ The user then specifies the X-Y coordinate of the lower left corner of
  18. \    the image to compute.  The input format is floating point.
  19. \ The Range is the length of the image on both X and Y axis from the
  20. \    starting point given earlier.
  21.  
  22. \ The picture can be converted into an ILBM picture file with a
  23. \   commercial program like GRABBiT.
  24.  
  25. \ NOTE: the user can stop the program after the current line processing
  26. \       hitting the Escape key with the graphic window active.  Also once
  27. \       the picture is completed; the program waits for the user to hit
  28. \       Escape on the keyboard before closing the custom graphic screen.
  29.  
  30. \ These values will create the whole Mandelbrot-set :
  31. \        start X : -2.0  start Y : -1.25
  32. \        range   : 2.5
  33. \ You can Zoom into any part of the Picture by specifying other
  34. \        values for the parameters.
  35.  
  36. find FLOATING.POINT not
  37. iftrue
  38.    include aux:tools/ffp    \ the fast floating point interface...
  39. ifend
  40.  
  41. find .time$ not
  42. iftrue
  43.    include aux:tools/date&time  \ the date&time words...
  44. ifend
  45.  
  46. find mark not
  47. iftrue
  48.    include aux:tools/timer      \ the timer facility...
  49. ifend
  50.  
  51. find ?open.console not
  52. iftrue
  53.    include aux:tools/myconsole.f   \ console i/o facility
  54. ifend
  55.  
  56.  
  57. anew Mset_marker
  58.  
  59.     Global x_res  320 to x_res    \ resolution on x (fixed)
  60.     Global y_res        \ resolution on y (200/400)
  61.  
  62.     fvariable x_coord    \ start x coord
  63.     fvariable y_coord    \ start y coord
  64.     fvariable plage
  65.     fvariable x_gap    \ increment per pixel on x
  66.     fvariable y_gap    \ increment per pixel on y
  67.  
  68.  
  69. \ ======================
  70. \ define screen & window
  71. \ ======================
  72.  
  73.   Global CurrentVP    \ current view port
  74.   Global CurrentRP    \ current rast port
  75.  
  76.   struct NewScreen MyScreen    MyScreen NewScreen erase
  77.  
  78.         320    MyScreen +nsWidth  w!
  79.         5    MyScreen +nsDepth  w!
  80.         1    MyScreen +nsDetailPen c!
  81.         2    MyScreen +nsBlockPen  c!
  82.     SCREENQUIET CUSTOMSCREEN |
  83.             MyScreen +nsType   w!
  84.  
  85.   struct NewWindow MyWindow   MyWindow NewWindow erase
  86.  
  87.     MyScreen +nsWidth  w@    MyWindow +nwWidth  w!
  88.             -1    MyWindow +nwDetailPen c!
  89.             -1    MyWindow +nwBlockPen  c!
  90.  
  91.     VANILLAKEY RMBTRAP |    MyWindow +nwIDCMPFlags !
  92.  
  93.     SMART_REFRESH BACKDROP | BORDERLESS |
  94.     NOCAREREFRESH |    ACTIVATE |
  95.             MyWindow +nwFlags !
  96.  
  97.     CUSTOMSCREEN        MyWindow +nwType w!
  98.  
  99. \ =========================
  100. \ color table & color setup
  101. \ =========================
  102. \ There is one element in the colortable for each of the 32 colors.
  103. \ Each element is a 16 bit number divided in 4 nibbles coded as a
  104. \ Red, Green and Blue color.
  105. \ The first nibble (most significant) is unused and is always zero.
  106. \ The second one is the color Red  (0-15)
  107. \ The Third one is the color Green  (0-15)
  108. \ The Fourth is the color Blue  (0-15)
  109.  
  110.   32 constant NC    \ nb. of colors.
  111.   NC 2 1array ColorTable
  112.  
  113. create Init_Words        \ just a marker
  114.  
  115.   variable CurrentColor  \ just to ease initalisation
  116.  
  117. : RGB! ( r\g\b -- )  locals| b g r |
  118.     r 16* g + 16* b +             \ combine RGB into 16 bit value
  119.     CurrentColor @ ColorTable w!  \ store it in current element
  120.     1 CurrentColor +! ;           \ for next one
  121.  
  122. hex  0 CurrentColor !  \ init counter
  123.  
  124.     0 0 0 RGB!  \ black
  125.     9 0 B RGB!  \ violet
  126.     7 0 C RGB!
  127.     4 0 D RGB!
  128.     1 0 E RGB!  \ around blue
  129.     0 2 F RGB!
  130.     0 4 F RGB!
  131.     0 6 F RGB!
  132.     0 8 E RGB!
  133.     0 A E RGB!
  134.     0 C E RGB!
  135.     0 D C RGB!
  136.     0 D 8 RGB!
  137.     0 C 6 RGB!
  138.     0 B 3 RGB!
  139.     0 B 0 RGB!  \ around green
  140.     3 C 0 RGB!
  141.     5 D 0 RGB!
  142.     9 D 0 RGB!
  143.     C E 0 RGB!
  144.     F E 0 RGB!  \ around yellow
  145.     F C 0 RGB!
  146.     F B 0 RGB!
  147.     F 9 0 RGB!
  148.     F 8 0 RGB!
  149.     F 7 0 RGB!
  150.     F 6 0 RGB!  \ into orange
  151.     F 5 0 RGB!
  152.     F 4 0 RGB!
  153.     F 2 0 RGB!
  154.     F 1 0 RGB!
  155.     F 0 0 RGB!   \ deep red
  156.  
  157. decimal   forget Init_Words
  158.  
  159. : Set_Colors ( -- )    \ load the colortable into viewport...
  160.     CurrentVP 0 ColorTable NC LoadRGB4
  161.     CurrentRP JAM1 SetDrMd ;
  162.  
  163.  
  164. \ ==============================
  165. \ window and screen open / close
  166. \ ==============================
  167.  
  168.  
  169. : Open_Screen&Window ( -- )
  170.     \ set Y resolution from user's value
  171.     y_res 400 = IF LACE 400  ELSE 0 200  THEN
  172.     dup MyScreen +nsHeight w!   MyWindow +nwHeight w!
  173.         MyScreen +nsViewModes w!
  174.  
  175.     MyScreen OpenScreen VerifyScreen
  176.     CurrentScreen @ MyWindow +nwScreen !
  177.     MyWindow OpenWindow VerifyWindow
  178.     \ set values of some usefull structures...
  179.     CurrentScreen @    dup +scViewPort to CurrentVP
  180.                 +scRastPort to CurrentRP
  181.     \ init colormap in viewport
  182.     Set_Colors ;
  183.  
  184. : Close_Screen&Window ( -- )
  185.     CurrentWindow @ ?dup IF CloseWindow THEN
  186.     CurrentScreen @ ?dup IF CloseScreen THEN
  187.     CurrentWindow off
  188.     CurrentScreen off ;
  189.  
  190.  
  191. \ ===================
  192. \ handle IDCMP events
  193. \ ===================
  194.  
  195. : Hit_Escape?   ( -- flag ) \ did the user hit Escape key
  196.     CurrentWindow @ 0= not  \ avoid GetEvent if no window open...
  197.     if  GetEvent ( -- 0 | class )
  198.         VANILLAKEY =
  199.         if
  200.            ThisEvent +eCode w@ 27 =  \ is it escape ?
  201.         else
  202.            false
  203.         then
  204.     else
  205.        false
  206.     then ;
  207.  
  208.  
  209. : wait_for_exit ( -- )  \ loop until user hit escape
  210.     Begin
  211.       pause pause   \ leave plenty of CPU time for others
  212.       pause pause
  213.       hit_escape?
  214.     Until ;
  215.  
  216.  
  217. \ ===================
  218. \ get user parameters
  219. \ ===================
  220.  
  221.  
  222. : input.float ( $addr -- f )
  223.     locals| question |
  224.     begin
  225.        question count type
  226.        pad 15 input.string pad count 1- $>number
  227.     until  >f ;
  228.  
  229.  
  230. \ ask a question and wait for a one char answer as char1 or char2.
  231.  
  232. : one.char.answer ( $addr\char1\char2 -- char )
  233.     locals| char2 char1 question |
  234.     begin
  235.        question count type \ display question
  236.        pad 15 input.string \ get answer
  237.        pad count upper     \ convert to uppercase
  238.        pad 1+ c@           \ get answer
  239.        dup char1 = swap char2 = or \ check 
  240.     until
  241.     pad 1+ c@ ;
  242.  
  243.  
  244. : get-resolution ( -- )
  245.     cr " Resolution on Y axis (L=200/H=400) ? "
  246.     ascii H ascii L  one.char.answer
  247.     ascii H = IF 400 ELSE 200 THEN to y_res ;
  248.  
  249. : get-start-x-y-&-range ( -- )
  250.     " Enter start X coord   (ex: 2.01) : " input.float x_coord !
  251.     " Enter start Y coord   (ex: 2.01) : " input.float y_coord !
  252.     " Enter the Range       (ex: 2.01) : " input.float plage !
  253.     plage @ x_res FLOAT F/  x_gap !
  254.     plage @ y_res FLOAT F/  y_gap ! ;
  255.  
  256.  
  257. \ ===========================
  258. \ compute estimated time left
  259. \ ===========================
  260.  
  261.  
  262. : elapsed ( -- milisecs )  \ elapsed time since last mark
  263.     tickcount timer @ - 16667 1000 */ ;
  264.  
  265. : cursor.up ( -- )     escape" [A" ;
  266.  
  267. \ compute estimated time left till end of process using time required
  268. \ for last loop and multiplying it by nb. of loops left to do.
  269.  
  270. : .time.left$ ( total\done -- )
  271.     locals| done total |
  272.     elapsed total done - 1000 */ fmt.time$ 8 min type
  273.     mark ;
  274.  
  275.  
  276. \ =========================
  277. \  Plot the pixel on screen
  278. \ =========================
  279.  
  280.  
  281. : Light_Pixel  ( intensity\x_coord\y_coord -- )
  282.     locals| yy xx |
  283.     dup 1000 =
  284.     IF   drop 31      \ force deep red if intensity = 1000
  285.     ELSE 31 and       \ map in 0-31 color code
  286.     THEN
  287.     CurrentRP swap  SetAPen     \ set Pen color
  288.     CurrentRP xx yy WritePixel  \ light the pixel
  289. ;
  290.  
  291.  
  292. \ =====================
  293. \    Compute the set
  294. \ =====================
  295.  
  296. float.on +floating
  297.  
  298.   Global Got_Break   \ did we got a signal while processing ?
  299.  
  300. : main_loop ( -- )
  301.     0e0 0e0 0e0 0e0 0e0 0e0 locals| size ac a b b1 bc |
  302.     cr ." Time at Startup : " .time$ cr cr cr
  303.     false to Got_Break
  304.     mark    \ mark starting time
  305.     plage @ y_coord @   F+  y_coord !
  306.     y_res 0
  307.     DO
  308.        cursor.up cursor.up
  309.        ." Computing row " i 1+ . ." / " y_res . cr cr
  310.        y_coord @ i FLOAT  y_gap @ F* F- TO bc
  311.  
  312.        x_res 0
  313.        DO
  314.           x_coord @ i FLOAT x_gap @ F* F+ dup TO ac TO a
  315.           bc  TO b
  316.           0e0 TO size
  317.           0        \ leave counter on TOS
  318.           BEGIN
  319. \         original non-optimized version... ( 40 words)
  320. \             a b 2e0 F* F* TO b1
  321. \             a dup F*  b dup F*  F- ac F+  TO a
  322. \             b1 bc F+  TO b
  323. \             b dup F* a dup F*  F+  TO size
  324. \             1+
  325. \             dup 1000 >   size 4e0 F> or
  326.  
  327. \         equivalent optimized version... ( 34 words)
  328.              1+              \ count + 1
  329.              a b 2e0 F* F*   \ leave b1 on TOS
  330.              a dup F*  b dup F*  F- ac F+  TO a
  331.              bc F+ dup TO b  \ use b1 from TOS and leave copy of b
  332.              dup F*  a dup F*  F+ \ use b from TOS leave size on TOS
  333.              4e0 F>  over 1000 >  or
  334.           UNTIL
  335.           1-               \ TOS = intensity value.
  336.           i j Light_Pixel  \ plot the pixel
  337.        LOOP
  338.        cursor.up ." Time left at current rate : "
  339.        y_res i .time.left$ cr
  340.        Hit_Escape?
  341.        if
  342.           ." ***BREAK" cr
  343.           true to Got_Break
  344.           leave
  345.        then
  346.     LOOP
  347.     ." Time at End     : " .time$
  348. ;
  349.  
  350.  
  351. \ ================================================
  352. \ the main program for creating the mandelbrot set
  353. \ ================================================
  354.  
  355. : seconds ( seconds -- delay_units)
  356.     1000 20 */ ;
  357.  
  358. : <M_set> ( -- )
  359.     on.error
  360.        cr ." Error occured."
  361.        Close_Screen&Window 
  362.        exit                \ return to calling word
  363.     resume
  364.  
  365.     cr ." Creating a Mandelbrot set v1.1"
  366.     cr ." Written in CSI Multi-Forth for the Amiga v1.21" cr
  367.  
  368.     get-resolution
  369.     get-start-x-y-&-range
  370.     cr
  371.     ." Hit Esc key to exit." cr
  372.     ." You can use screen drag & depth gadgets." cr
  373.     5 seconds delay
  374.  
  375.     Open_Screen&Window
  376.     main_loop
  377.     Got_Break not if Wait_for_Exit then
  378.     Close_Screen&Window ;
  379.  
  380.  
  381. : cleanup ( -- )
  382.     float.off -floating ;
  383.  
  384. token.for cleanup before.bye !
  385.  
  386.  
  387. : M_set ( -- )
  388.     on.error
  389.        cr ." Unable to execute."
  390.        ?close.console
  391.        ?turnkey if bye else abort then       
  392.     resume
  393.  
  394.     decimal  float.on  +floating \ open & start FFP
  395.     0" CON:0/11/500/120/ M_SET " ?open.console
  396.     begin
  397.        <M_set>
  398.        cr cr " Create another set ? (Y/N) "
  399.        ascii Y ascii N one.char.answer
  400.        ascii Y = not
  401.     until
  402.     ?close.console
  403.     ?turnkey if bye else abort then ;
  404.  
  405.  
  406.