Category : Forth Source Code
Archive   : FIFTH.ZIP
Filename : MANDEL.FIV
CREATE MACHINE
EDIT
( TI=0 / IBM=1 Machine flag)
1 constant machine
~UP
CREATE XMAX
CREATE X
EDIT
( Maximum X for this machine)
: x machine if 320 else 720 endif ;
~UP
EDIT
( Maximum X value)
x constant xmax
~UP
CREATE YMAX
CREATE Y
EDIT
: y machine if 200 else 300 endif ;
~UP
EDIT
y constant ymax
~UP
CREATE GCLS
EDIT
: GCLS cls 4 vmode
0 0 0 xmax 1- ymax 1- FILLBOX
;
~UP
CREATE DIS
EDIT
: dis
8 0 do
i 0 palette
loop
;
~UP
CREATE H#
EDIT
\ Hex constant
: h# base @ 16 base ! ' ['] literal execute base ! ; immediate
~UP
CREATE R87
EDIT
\ Parse a following 8087 register ==> stack element 0-7.
: r87
' dup 8 u< not abort" Register must be 0-7"
;
~UP
CREATE POP?
EDIT
\ 8087 operation & POP if trailing P : FADD P1 ==> FADDP ST(1)
: pop?
>in @
begin
dup c@@ dup 32 = over 13 = or over 10 = or swap 9 = or while
1+ repeat
dup c@@ dup 80 = swap 112 = or
if 1+ >in ! h# DE c,
else drop h# D8 c, endif
;
~UP
CREATE FINIT
EDIT
\ Initilize 8087
: finit
h# DB c, h# E3 c, ; immediate
~UP
CREATE FLD
EDIT
\ Load real to 8087 stack & pop Fifth stack
: fld
h# 9B c, \ FWAIT
h# D9 c, h# 46 c, h# 00 c, \ FLD [BP+0]
h# 83 c, h# C5 c, h# 04 c, \ ADD BP,4
h# 9B c, \ FWAIT
; immediate
~UP
CREATE FSTP
EDIT
\ Push 8087 real to Fifth stack, pop from 8087.
: fstp
h# 9B c, \ FWAIT
h# 83 c, h# C5 c, h# FC c, \ ADD BP,-4
h# D9 c, h# 5E c, h# 00 c, \ FSTP [BP+0]
h# 9B c, \ FWAIT
; immediate
~UP
CREATE FPICK
EDIT
\ PICK a value on the 8087 stack, must be 0-7: FPICK87 3
: fpick
r87
h# 9B c, \ FWAIT
h# D9 c, h# C0 + c, \ FLD ST(i)
; immediate
~UP
CREATE FSWAP
EDIT
\ Exchange 8087 TOS with the nth register, must be 0-7
: fswap
r87
h# 9B c, \ FWAIT
h# D9 c, h# C8 + c, \ FXCH ST(i)
; immediate
~UP
CREATE FPOP
EDIT
\ Drop an 8087 value
: fpop
h# 9B c, \ FWAIT
h# D9 c, h# D8 c, \ FSTP ST(0)
; immediate
~UP
CREATE FADD
EDIT
\ Add two 8087 numbers
: fadd
h# 9B c, \ FWAIT
pop? r87 h# C0 + c, \ FADD ST(i)
; immediate
~UP
CREATE FMUL
EDIT
\ Multiply two 8087 numbers
: fmul
h# 9B c, \ FWAIT
pop? r87 h# C8 + c, \ FMUL ST(i)
; immediate
~UP
CREATE FSUB
EDIT
\ Subtract two 8087 numbers
: fsub
h# 9B c, \ FWAIT
pop? r87 h# E0 + c, \ FSUB ST(i)
; immediate
~UP
CREATE FSUBR
EDIT
\ Subtract reversed two 8087 numbers
: fsubr
h# 9B c, \ FWAIT
pop? r87 h# E8 + c, \ FSUBR ST(i)
; immediate
~UP
CREATE FDIV
EDIT
\ Divide two 8087 numbers
: fdiv
h# 9B c, \ FWAIT
pop? r87 h# F0 + c, \ FDIV ST(i)
; immediate
~UP
CREATE FDIVR
EDIT
\ Divide reversed two 8087 numbers
: fdivr
h# 9B c, \ FWAIT
pop? r87 h# F8 + c, \ FDIVR ST(i)
; immediate
~UP
CREATE H
EDIT
variable h
~UP
CREATE SPEED
EDIT
create speed 1 ,
~UP
CREATE DRAW
CREATE X
EDIT
\ Real part start
-2. constant x
~UP
CREATE Y
EDIT
\ Imaginary part start
-2. constant y
~UP
CREATE SX
EDIT
\ Size of real part
4. constant sx
~UP
CREATE SY
EDIT
\ Size of imagniary part
4. constant sy
~UP
CREATE GX
EDIT
\ Real pixel gap
sx xmax i->f f/ constant gx
~UP
CREATE GY
EDIT
\ Imaginary pixel gap
sy ymax i->f f/ constant gy
~UP
CREATE CNTABLE
EDIT
\ Count of iterations, determines color
create cntable
10 , \ Black
20 , \ Blue
40 , \ Red
80 , \ Purple
160 , \ Green
320 , \ Light blue
640 , \ Yellow
1280 , \ White
~UP
CREATE XC
EDIT
\ real corner of pixel in progress
variable xc
~UP
CREATE YC
EDIT
\ imaginary corner of pixel in progress
variable yc
~UP
CREATE CNT
EDIT
\ count of iterations until z explodes
variable cnt
~UP
EDIT
\ Exploring the Mandelbrot set
: draw
speed !
xmax 0 do
gx i i->f f* x f+ xc !
ymax 0 do
gy i i->f f* y f+ yc !
63 cnt !
0. 0.
63 0 do
finit
fld fld fpick 0 fmul 0 fpick 2 fmul 0 fpick 1 fadd 1 fstp
fsubr p1 xc @ fld fadd p1 fstp
fmul p1 -2. fld fmul p1 yc @ fld fadd p1 fstp
rot 4. f< if else i cnt ! leave endif
loop
2drop
cnt @ \ dup pad c! pad 1 h @ write 2drop
j i pset
speed @ +loop
?term if key dup 49 = if 1 speed +! else
dup 48 = if -1 speed +! speed @ 0= if 1 speed ! endif else
abort endif endif endif
speed @ +loop
;
~UP
CREATE LOOK
EDIT
: look
" m.dat " 1+ 0 open if h ! else ." open error " . quit endif
100000 0 do
pad 1 h @ read 2drop
pad @ . cr
loop
;
~UP
CREATE PLAY
CREATE DATA
CREATE DATA1
EDIT
create data1 33000 allot
~UP
CREATE DATA2
EDIT
create data2 33000 allot
~UP
CREATE DATA3
EDIT
create data3 33000 allot
~UP
CREATE DATA4
EDIT
create data4 33000 allot
~UP
CREATE DATA5
EDIT
create data5 33000 allot
~UP
CREATE DATA6
EDIT
create data6 33000 allot
~UP
CREATE DATA7
EDIT
create data7 33000 allot
~UP
CREATE WHICH
CREATE TABLE
EDIT
create table
data1 , 32768 0 * ,
data2 , 32768 1 * ,
data3 , 32768 2 * ,
data4 , 32768 3 * ,
data5 , 32768 4 * ,
data6 , 32768 5 * ,
data7 , 32768 6 * ,
~UP
CREATE LOAD
CREATE TRY
EDIT
: try
0
10 0 do
i . dup . 32767 + dup . 1+ cr
loop
drop
;
~UP
EDIT
: load
" m.dat" 1+ 0 open if h ! else ." open error (which) " . quit endif
data1 32768 h @ read ." data1 " . . cr
data2 32768 h @ read ." data2 " . . cr
data3 32768 h @ read ." data3 " . . cr
data4 32768 h @ read ." data4 " . . cr
data5 32768 h @ read ." data5 " . . cr
data6 32768 h @ read ." data6 " . . cr
data7 [ 216000 32768 6 * - ] literal h @ read ." data7 " . . cr
h @ close if else ." close error (which) " . quit endif
;
~UP
EDIT
: which
3 shl table + dup @ swap 4 + @ - +
;
load
~UP
EDIT
: data
dup 15 shr which c@
;
~UP
CREATE MAP
CREATE DEFINE
CREATE LOG
EDIT
: log
20 - abs
0 begin over while 1+ swap 2 / swap repeat
swap drop
;
~UP
EDIT
: define create
256 0 do i log 8 mod dup . c, loop
does>
swap 255 and + c@
;
~UP
EDIT
define map
~UP
CREATE MSET
CREATE ROTATE
EDIT
: rotate
0 vmode
1000 0 do
i
8 0 do
dup 7 and i swap palette
1+
?term if quit endif
loop
drop 1000 0 do loop
loop
;
~UP
EDIT
: mset
4 vmode
0
xmax 0 do
ymax 0 do
dup data map j i pset
1+
loop
?term if quit endif
loop
key drop
;
~UP
EDIT
~UP
EDIT
: mandel
gcls
\ " m.dat" 1+ 1 open if h ! else ." open failed " . quit then 1 draw
begin 1 while
speed @ draw
repeat
key drop
;
~UP
ABORT
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/