home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
100.lha
/
FramSet
/
mset.f
< prev
next >
Wrap
Text File
|
1986-11-20
|
10KB
|
406 lines
\ 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 ;