\ Mset.f

\ MSET stands for Mandelbrot set.

\ use Mset.script to turnkey Mset application...

\ the main word:  M_SET  or MS (in short)
\ the token word: Mset.token

\ purpose : to compute & display the Mandelbrot set of a given range
\           of values on X and Y axis.

\ The user is asked for the required parameters : resolution, starting
\ X and Y coordinate and the Range.

\ The user has 2 choices of resolutions: 320x200 (low) or 320x400 (high).
\ The user then specifies the X-Y coordinate of the lower left corner of
\    the image to compute.  The input format is floating point.
\ The Range is the length of the image on both X and Y axis from the
\    starting point given earlier.

\ The picture can be converted into an ILBM picture file with a
\   commercial program like GRABBiT.

\ NOTE: the user can stop the program after the current line processing
\       hitting the Escape key with the graphic window active.  Also once
\       the picture is completed; the program waits for the user to hit
\       Escape on the keyboard before closing the custom graphic screen.

\ These values will create the whole Mandelbrot-set :
\        start X : -2.0  start Y : -1.25
\        range   : 2.5
\ You can Zoom into any part of the Picture by specifying other
\        values for the parameters.

find FLOATING.POINT not
iftrue
   include aux:tools/ffp	\ the fast floating point interface...
ifend

find .time$ not
iftrue
   include aux:tools/date&time  \ the date&time words...
ifend

find mark not
iftrue
   include aux:tools/timer      \ the timer facility...
ifend

find ?open.console not
iftrue
   include aux:tools/myconsole.f   \ console i/o facility
ifend


anew Mset_marker

    Global x_res  320 to x_res	\ resolution on x (fixed)
    Global y_res		\ resolution on y (200/400)

    fvariable x_coord	\ start x coord
    fvariable y_coord	\ start y coord
    fvariable plage
    fvariable x_gap	\ increment per pixel on x
    fvariable y_gap	\ increment per pixel on y


\ ======================
\ define screen & window
\ ======================

  Global CurrentVP	\ current view port
  Global CurrentRP	\ current rast port

  struct NewScreen MyScreen    MyScreen NewScreen erase

		320	MyScreen +nsWidth  w!
		5	MyScreen +nsDepth  w!
		1	MyScreen +nsDetailPen c!
		2	MyScreen +nsBlockPen  c!
	SCREENQUIET CUSTOMSCREEN |
			MyScreen +nsType   w!

  struct NewWindow MyWindow   MyWindow NewWindow erase

	MyScreen +nsWidth  w@	MyWindow +nwWidth  w!
			-1	MyWindow +nwDetailPen c!
			-1	MyWindow +nwBlockPen  c!

	VANILLAKEY RMBTRAP |	MyWindow +nwIDCMPFlags !

	SMART_REFRESH BACKDROP | BORDERLESS |
	NOCAREREFRESH |	ACTIVATE |
			MyWindow +nwFlags !

	CUSTOMSCREEN		MyWindow +nwType w!

\ =========================
\ color table & color setup
\ =========================
\ There is one element in the colortable for each of the 32 colors.
\ Each element is a 16 bit number divided in 4 nibbles coded as a
\ Red, Green and Blue color.
\ The first nibble (most significant) is unused and is always zero.
\ The second one is the color Red  (0-15)
\ The Third one is the color Green  (0-15)
\ The Fourth is the color Blue  (0-15)

  32 constant NC	\ nb. of colors.
  NC 2 1array ColorTable

create Init_Words        \ just a marker

  variable CurrentColor  \ just to ease initalisation

: RGB! ( r\g\b -- )  locals| b g r |
	r 16* g + 16* b +             \ combine RGB into 16 bit value
	CurrentColor @ ColorTable w!  \ store it in current element
	1 CurrentColor +! ;           \ for next one

hex  0 CurrentColor !  \ init counter

	0 0 0 RGB!  \ black
	9 0 B RGB!  \ violet
	7 0 C RGB!
	4 0 D RGB!
	1 0 E RGB!  \ around blue
	0 2 F RGB!
	0 4 F RGB!
	0 6 F RGB!
	0 8 E RGB!
	0 A E RGB!
	0 C E RGB!
	0 D C RGB!
	0 D 8 RGB!
	0 C 6 RGB!
	0 B 3 RGB!
	0 B 0 RGB!  \ around green
	3 C 0 RGB!
	5 D 0 RGB!
	9 D 0 RGB!
	C E 0 RGB!
	F E 0 RGB!  \ around yellow
	F C 0 RGB!
	F B 0 RGB!
	F 9 0 RGB!
	F 8 0 RGB!
	F 7 0 RGB!
	F 6 0 RGB!  \ into orange
	F 5 0 RGB!
	F 4 0 RGB!
	F 2 0 RGB!
	F 1 0 RGB!
	F 0 0 RGB!   \ deep red

decimal   forget Init_Words

: Set_Colors ( -- )	\ load the colortable into viewport...
	CurrentVP 0 ColorTable NC LoadRGB4
	CurrentRP JAM1 SetDrMd ;


\ ==============================
\ window and screen open / close
\ ==============================


: Open_Screen&Window ( -- )
	\ set Y resolution from user's value
	y_res 400 = IF LACE 400  ELSE 0 200  THEN
	dup MyScreen +nsHeight w!   MyWindow +nwHeight w!
	    MyScreen +nsViewModes w!

	MyScreen OpenScreen VerifyScreen
	CurrentScreen @ MyWindow +nwScreen !
	MyWindow OpenWindow VerifyWindow
	\ set values of some usefull structures...
	CurrentScreen @	dup +scViewPort to CurrentVP
			    +scRastPort to CurrentRP
	\ init colormap in viewport
	Set_Colors ;

: Close_Screen&Window ( -- )
	CurrentWindow @ ?dup IF CloseWindow THEN
	CurrentScreen @ ?dup IF CloseScreen THEN
	CurrentWindow off
	CurrentScreen off ;


\ ===================
\ handle IDCMP events
\ ===================

: Hit_Escape?   ( -- flag ) \ did the user hit Escape key
	CurrentWindow @ 0= not  \ avoid GetEvent if no window open...
	if  GetEvent ( -- 0 | class )
	    VANILLAKEY =
	    if
	       ThisEvent +eCode w@ 27 =  \ is it escape ?
	    else
	       false
	    then
	else
	   false
	then ;


: wait_for_exit ( -- )  \ loop until user hit escape
	Begin
	  pause pause   \ leave plenty of CPU time for others
	  pause pause
	  hit_escape?
	Until ;


\ ===================
\ get user parameters
\ ===================


: input.float ( $addr -- f )
	locals| question |
	begin
	   question count type
	   pad 15 input.string pad count 1- $>number
	until  >f ;


\ ask a question and wait for a one char answer as char1 or char2.

: one.char.answer ( $addr\char1\char2 -- char )
	locals| char2 char1 question |
	begin
	   question count type \ display question
	   pad 15 input.string \ get answer
	   pad count upper     \ convert to uppercase
	   pad 1+ c@           \ get answer
	   dup char1 = swap char2 = or \ check 
	until
	pad 1+ c@ ;


: get-resolution ( -- )
	cr " Resolution on Y axis (L=200/H=400) ? "
	ascii H ascii L  one.char.answer
	ascii H = IF 400 ELSE 200 THEN to y_res ;

: get-start-x-y-&-range ( -- )
	" Enter start X coord   (ex: 2.01) : " input.float x_coord !
	" Enter start Y coord   (ex: 2.01) : " input.float y_coord !
	" Enter the Range       (ex: 2.01) : " input.float plage !
	plage @ x_res FLOAT F/  x_gap !
	plage @ y_res FLOAT F/  y_gap ! ;


\ ===========================
\ compute estimated time left
\ ===========================


: elapsed ( -- milisecs )  \ elapsed time since last mark
	tickcount timer @ - 16667 1000 */ ;

: cursor.up ( -- )     escape" [A" ;

\ compute estimated time left till end of process using time required
\ for last loop and multiplying it by nb. of loops left to do.

: .time.left$ ( total\done -- )
	locals| done total |
	elapsed total done - 1000 */ fmt.time$ 8 min type
	mark ;


\ =========================
\  Plot the pixel on screen
\ =========================


: Light_Pixel  ( intensity\x_coord\y_coord -- )
	locals| yy xx |
	dup 1000 =
	IF   drop 31      \ force deep red if intensity = 1000
	ELSE 31 and       \ map in 0-31 color code
	THEN
	CurrentRP swap  SetAPen     \ set Pen color
	CurrentRP xx yy WritePixel  \ light the pixel
;


\ =====================
\    Compute the set
\ =====================

float.on +floating

  Global Got_Break   \ did we got a signal while processing ?

: main_loop ( -- )
	0e0 0e0 0e0 0e0 0e0 0e0 locals| size ac a b b1 bc |
	cr ." Time at Startup : " .time$ cr cr cr
	false to Got_Break
	mark    \ mark starting time
	plage @ y_coord @   F+  y_coord !
	y_res 0
	DO
	   cursor.up cursor.up
	   ." Computing row " i 1+ . ." / " y_res . cr cr
	   y_coord @ i FLOAT  y_gap @ F* F- TO bc

	   x_res 0
	   DO
	      x_coord @ i FLOAT x_gap @ F* F+ dup TO ac TO a
	      bc  TO b
	      0e0 TO size
	      0		\ leave counter on TOS
	      BEGIN
\		 original non-optimized version... ( 40 words)
\	         a b 2e0 F* F* TO b1
\	         a dup F*  b dup F*  F- ac F+  TO a
\	         b1 bc F+  TO b
\	         b dup F* a dup F*  F+  TO size
\	         1+
\	         dup 1000 >   size 4e0 F> or

\		 equivalent optimized version... ( 34 words)
	         1+              \ count + 1
	         a b 2e0 F* F*   \ leave b1 on TOS
	         a dup F*  b dup F*  F- ac F+  TO a
	         bc F+ dup TO b  \ use b1 from TOS and leave copy of b
	         dup F*  a dup F*  F+ \ use b from TOS leave size on TOS
	         4e0 F>  over 1000 >  or
	      UNTIL
	      1-               \ TOS = intensity value.
	      i j Light_Pixel  \ plot the pixel
	   LOOP
	   cursor.up ." Time left at current rate : "
	   y_res i .time.left$ cr
	   Hit_Escape?
	   if
	      ." ***BREAK" cr
	      true to Got_Break
	      leave
	   then
	LOOP
	." Time at End     : " .time$
;


\ ================================================
\ the main program for creating the mandelbrot set
\ ================================================

: seconds ( seconds -- delay_units)
	1000 20 */ ;

: <M_set> ( -- )
	on.error
	   cr ." Error occured."
	   Close_Screen&Window 
	   exit                \ return to calling word
	resume

	cr ." Creating a Mandelbrot set v1.1"
	cr ." Written in CSI Multi-Forth for the Amiga v1.21" cr

	get-resolution
	get-start-x-y-&-range
	cr
	." Hit Esc key to exit." cr
	." You can use screen drag & depth gadgets." cr
	5 seconds delay

	Open_Screen&Window
	main_loop
	Got_Break not if Wait_for_Exit then
	Close_Screen&Window ;


: cleanup ( -- )
	float.off -floating ;

token.for cleanup before.bye !


: M_set ( -- )
	on.error
	   cr ." Unable to execute."
	   ?close.console
	   ?turnkey if bye else abort then	   
	resume

	decimal  float.on  +floating \ open & start FFP
	0" CON:0/11/500/120/ M_SET " ?open.console
	begin
	   <M_set>
	   cr cr " Create another set ? (Y/N) "
	   ascii Y ascii N one.char.answer
	   ascii Y = not
	until
	?close.console
	?turnkey if bye else abort then ;


