colorforth v2.0a - copyright 2008, technology properties limited - chuck moore blocks 0-143 20 load 22 load 24 load colors 26 load
env 34 winver 2* + ; env ironmental load 28 load 90 3 loads 98 load
rest 36 block 2 24 reads ; the rest utilities
usb 82 3 loads ; usb flash
dump 40 load ; background dump
icons 42 load ; edit chars
png 46 load ; png file format
file 30 load ; file io util
north 50 load ; view northbridge registers
floppy 52 load ; format, archive, set video
c-a-c 54 load ; ascii qwerty
mand 190 load ; mandelbrot set , fixed point
manju 144 load ; fractal viewer , mandelbrot or julia sets , floating point mark empty mark marks words not forgotten by empty.
compile pentium colorforth
memory map: block is 1 kbyte
0 kernal 12k fonts 6k bytes
500 c18 compiled object code
595 deleted words - reinsert with i
640 top of stacks
1024 dictionary
7424 video frame buffer
32768 okad tables
524288 512 megabytes
dump compile memory display background task
icons compile icon editor
png screen image to usb flash drive
file compile dos file utility
north compile north-bridge pci bus display
---
editor
sct yrg* all-caps cap lower-case yellow red green * toggles shadow comment block
fj ludr find jump left up down right
.. -mc+ dec-block magenta cyan inc-block
x.i delete exit insert
. jump jumps between -edited- blocks
f finds next word from find word
:144: fractal viewer empt macro
if0 75 2, here ;
?f c021 2, ;
shl ?lit e0c1 2, 1, ;
shr ?lit e8c1 2, 1, ;
b! ?lit 589 2, , drop ; forth
car* for emit next ;
cf20a 0 dup at red 1 3 c 3 3a 5 car* green 14 2 1 3 3e 5 car* 0 emit 5 24 37 26 65 5 car* 0 emit ; frame 8912896 168 winver 2 * + load wf+
fill for 0 , next ;
string pop ;
dfl align string 36 fill
d-ad 2 * dfl 4 / + ;
d@ dup @ swap 1 + @ ;
d! swap over 1 + ! ! ; macro
f@ 8504dd 3, 0 , drop ;
f! 851cdd 3, 0 , drop ;
f+ c1de 2, ;
f- e9de 2, ;
f* c9de 2, ;
f/ f9de 2, ; 146 load
wf+ write a pixel and move pointer for next pixel
fill n- allot n words
dfl area for :18 double or float variables
d-ad n-ad give byte address of double or float variable
d@ d! doubles operators
f@ f! f+ f- f* f/ floats operators
:146: forth
cstep 0 d-ad ;
cxb 1 d-ad ;
cyb 2 d-ad ;
cxf 3 d-ad ;
cyf 4 d-ad ;
zx 5 d-ad ;
zy 6 d-ad ;
fl2 7 d-ad ;
fl4 8 d-ad ;
fzero 9 d-ad ;
ftemp 10 d-ad ;
zxstep 11 d-ad ;
mstep 12 d-ad ;
mcxb 13 d-ad ;
mcyb 14 d-ad ;
jstep 15 d-ad ;
jcxb 16 d-ad ;
jcyb 17 d-ad ; 148 load
cxf cyf fvariables , real and imaginary parts of a complex number
cstep cxb cyb ftemp .... fvariables
fl4 .... fconstants
:148: zr 270064216 zi 270064236 cxr 270064151 cyi 270064145 macro
zinit 5dd 2, here cyi ! 0 , 5dd 2, here cxr ! 0 , ;
mag4? c1d9 2, cad8 2, c1d9 2, cad8 2, c0d9 2, c2d8 2, 5dd 2, fl4 4 * , c9d9 2, d9de 2, e0df 2, 45e480 3, ;
mag4- e9de 2, 5dd 2, here zr ! 0 , c1de 2, c9d9 2, cad8 2, 5dd 2, fl2 4 * , c9de 2, 5dd 2, here zi ! 0 , c1de 2, c2dd 2, ;
mag4+ c0dd 2, f7d9 2, c0dd 2, f7d9 2, c0dd 2, f7d9 2, c0dd 2, f7d9 2, ;
fs2- c0dd 2, f7d9 2, c0dd 2, f7d9 2, ;
d2f 852cdf 3, 0 , drop ;
rot -74fba175 , 46e892e , -3c74f977 , ; forth
s2d dup 0 + ?f drop -if -1 ; then 0 ;
s2f s2d ftemp d! ftemp d2f ;
fcinit 4 s2f fl4 f! 2 s2f fl2 f! ; fcinit 150 load
- zr , zi , cxr , cyi vectors to switch computation for mandelbrot or julia set
- macros -
zinit init complex computation
mag4? compute complex squared magnitude
mag4- compute next complex value
mag4+ leave and clear floats stack
fs2- clear 2 items on floats stack
d2f convert double to float
- forth -
s2d convert single to double
s2f convert single to float
:150: depth 128 pxr 32 pxg 56 pxb 160 hole 0
cstart 128 depth ! 32 pxr ! 56 pxg ! 160 pxb ! 0 hole ! ;
o2rgb negate depth @ swap + dup 8 * pxr @ + swap dup 8 * pxg @ + swap 8 * pxb @ + ;
rgb2t rot 16 shl rot 8 shl + + ;
cf- dup f@ cstep f@ f- f! ;
cf+ dup f@ cstep f@ f+ f! ;
cxf- cxf cf- ;
cxf+ cxf cf+ ;
cyf+ cyf cf+ ;
cyf- cyf cf- ; lc 3164336
orbit zinit depth @ 1 max for mag4? if mag4- *next fs2- hole @ ; then mag4+ pop o2rgb rgb2t ;
2pix cxf- orbit lc @ over lc ! or drop if0 lc @ dup wf+ wf+ ; then cxf+ orbit cxf- wf+ lc @ wf+ ;
mh cxb f@ cxf f! orbit dup lc ! wf+ cxf- 511 for 2pix cxf- next orbit wf+ ; 152 winver 2 * + load
orbit orbit of x2+c , return a color , in variable :hole: if in the set , based on iterations otherwise
o2rgb orbit to rgb
rgb2t rgb to truecolor
2pix pixels interpolation in a line
mh draw one scan line
:152
mh+ 1024 frame +! ;
poc@ frame @ -2048 + @ ;
cpxe cxf+ cyf- orbit cyf+ cxf- ;
cpxo cyf- orbit cyf+ ;
px! frame @ -1024 + ! ;
pxe? poc@ lc @ or drop if0 lc @ px! ; then cpxe px! ;
pxo? poc@ lc @ or drop if0 lc @ px! ; then cpxo px! ;
4pix cxf- orbit lc @ over lc ! or drop if0 pxe? lc @ wf+ pxo? lc @ wf+ ; then pxe? cxf+ orbit cxf- wf+ pxo? lc @ wf+ ;
2mh cxb f@ cxf f! orbit lc ! pxo? lc @ wf+ cxf- 511 for 4pix cxf- next orbit lc ! pxe? lc @ wf+ ;
mv cyb f@ cyf f! mh cyf+ 383 for mh+ cyf+ 2mh cyf+ next mh ; native version
cfver ffff00 color 4 17 7 2 5 54 6 car* 0 emit 6 3 7 8 1 4 65 7 car* ; 156 load
mh+ move to next line
poc@ a-c get color at pixel address in last line computed
cpxe compute orbit even pixel from previous line
cpxo compute orbit odd pixel from previous line
px! set color at pixel address in previous line
pxe? copy color or compute color even pixel
pxo? copy color or compute color odd pixel
4pix put :4 pixels in framebuffer with interpolation or computation
2mh draw :2 scan lines with lines interpolation
mv draw the set with lines interpolation
cfver display : native version :
:154
mv cyb f@ cyf f! 768 for mh cyf+ next ; windows version
cfver ffff00 color 8 15 3 16 6 7 63 7 car* 0 emit 6 3 7 8 1 4 65 7 car* ; 156 load
mv draw the set
. because i don:t know how to read in the windows dib , i can:t draw the set with lines interpolation
cfver display : windows version :
:156 fract 0
+d 16 depth +!
-d -8 depth +! depth @ 1 max depth !
draw wfinit mv cf20a cfver ;
fstart -4 s2f 1024 s2f f/ cstep f! ;
mhome -276318390 s2f 100000000 s2f f/ cxb f! 157996925 s2f 100000000 s2f f/ cyb f! ;
pmand 0 s2f fzero f! cxf 4 * zr @ b! cyf 4 * zi @ b! fzero 4 * dup cxr @ b! cyi @ b! ; pmand 0 fract !
jhome 5 s2f 10000 s2f f/ zxstep f! 136 s2f 1000 s2f f/ zx f! 6 s2f 10 s2f f/ zy f! -20876 s2f 10000 s2f f/ cxb f! 15876 s2f 10000 s2f f/ cyb f! ;
pjul zx 4 * zr @ b! zy 4 * zi @ b! cxf 4 * cxr @ b! cyf 4 * cyi @ b! ;
mov- dup f@ cstep f@ 32 s2f f* f- f! draw ;
mov+ dup f@ cstep f@ 32 s2f f* f+ f! draw ;
l cxb mov- ;
u cyb mov+ ;
d cyb mov- ;
r cxb mov+ ; 158 load
commands to
. calculs initialization
. images initialization
. move images
:158 step 8 8 step !
?limit push i @ 256 min 0 max pop ! ;
-r step @ negate pxr +! pxr ?limit draw ;
+r step @ pxr +! pxr ?limit draw ;
-g step @ negate pxg +! pxg ?limit draw ;
+g step @ pxg +! pxg ?limit draw ;
-b step @ negate pxb +! pxb ?limit draw ;
+b step @ pxb +! pxb ?limit draw ;
rh ff0000 hole ! ;
gh ff00 hole ! ;
bh ff hole ! ;
k+ zxstep f@ zx f@ f+ zx f! ;
k- zx f@ zxstep f@ f- zx f! ;
+z cxb f@ cstep f@ 1024 8 / s2f f* f- cxb f! cyb f@ cstep f@ 768 8 / s2f f* f+ cyb f! cstep f@ 3 s2f f* 4 s2f f/ cstep f! draw ;
-z cstep f@ 4 s2f f* 3 s2f f/ cstep f! cxb f@ cstep f@ 1024 8 / s2f f* f+ cxb f! cyb f@ cstep f@ 768 8 / s2f f* f- cyb f! draw ; 160 load
commands to
. change colors
. zoom
:160 src 67515603 dest 67515579
fmove dest ! src ! for src @ i -1 + 2* + d@ dest @ i -1 + 2* + d! next ;
savem 3 cstep mstep fmove ;
loadm 3 mstep cstep fmove ;
savej 3 cstep jstep fmove ;
loadj 3 jstep cstep fmove ;
home cstart fstart mhome savem jhome savej fract @ ?f drop if jhome ; then mhome ; home
varsave push fract @ i ! pxr @ i 1 + ! pxg @ i 2 + ! pxb @ i 3 + ! depth @ i 4 + ! hole @ pop 5 + ! ;
varload push i @ fract ! i 1 + @ pxr ! i 2 + @ pxg ! i 3 + @ pxb ! i 4 + @ depth ! pop 5 + @ hole ! ;
hh home draw ;
hj fract @ 1 less -if fract ! drop savem loadj pjul draw ; then drop drop ;
hm fract @ ?f drop if 0 fract ! savej loadm pmand draw ; then ;
restart fract @ ?f drop if pjul ; then pmand ; 162 load
commands to
. start , save , load and restart
:162 caps 0
car1 4 shr unpack ;
bl 0 caps ! car1 emit ;
ty bl ffff00 color ;
tg bl green ;
tc bl ffff color ;
tw bl white ;
twc tw unpack 48 + emit ;
twac tw 48 caps ! ;
tm bl ff00ff color ;
ext car1 drop ;
rcr bl red cr ;
w? f and jump ext ty nul rcr tg nul nul tc nul tw twc twac tm nul nul nul
wtype dup w? begin unpack while caps @ + emit end then drop drop ; hblok 173 173 hblok !
help cr cr hblok @ block begin dup @ ?f while wtype 1 + end then drop drop ; ?hlp 1
?help ?hlp @ ?f drop if help ; then ;
hok 1 ?hlp ! ;
hno 0 ?hlp ! ; 164 load ok h
utility to read help
wtype unpack a word and display it
help display all the words of a block
:164
fsave 18 cstep 166 block 10 + push i fmove pop 36 + varsave ;
fload 18 166 block 10 + push i cstep fmove pop 36 + varload restart draw ;
quit logo accept ;
?hblk hblok @ 173 less nip if hblok ! ; then drop ;
mhblk hblok @ 181 less nip if drop ; then hblok ! ;
dh- ?hlp @ ?f drop if -2 hblok +! ?hblk ; then -d ;
dh+ ?hlp @ ?f drop if 2 hblok +! mhblk ; then +d ;
ok c home hok show draw ?help keyboard ;
h pad nul hno quit hok dh- hj hm dh+ l u d r -z hh fload +z -r rh k+ +r -g gh k- +g -b bh fsave +b 361744 , 2b395223 , 110160c , 2b3c3123 , 2b540123 , 2b240d23 , 2b381323 ,
user interface
:166: dont edit data are saved herew/ -406f24e0 cryntod dr si; -195648c e ryeedt?j:d e t lwe
tp1cd d bwis f ermte 1069639794
ooooooo
o?ryooee r 1imgo8 1061184077 -406f24e0 fagip8drro ; itaxo@ e ryoat -406f24e0 cryntod dr si; -195648c e ryeed 1 e l s 0
wf+ write in the framebuffer
:170 - wf+ windows version
wfinit 0 0 at ; wfinit
?1024 1023 less if drop ; then drop drop 1 + -1 ;
f++ xy @ 65536 /mod ?1024 1 + swap ;
wf+ color f++ 1 + box f++ at ;
wf+ write in the windows dib
help - screen.1 - is in the shadow block
fractal viewer
.
. help - part 1 -
.
. qwerty keys : app keys : actions
.
. n : n : escape from help
.
. alt : h : show this help
.
. p : + : next help screen
.
. u : - : previous help screen
.
. spacebar : q : quit application
.
. word : manju : start or restart application
help - screen.2 - is in the shadow block
help - part 2 -
.
. mandelbrot set is default
.
. qwerty keys : app keys : actions
.
. i : j : show julia set
.
. o : m : show mandelbrot set
.
. m : - : unzoom
.
. / : + : zoom
.
. , : r : restart to default
.
. c : s : save session in block 166
.
. . : l : load session previously saved
help - screen.3 - is in the shadow block
help - part 3 -
.
. qwerty keys : app keys : actions
.
. j : l : move image left
.
. k : u : move image up
.
. l : d : move image down
.
. ; : r : move image right
.
. next two functions are active only
. when :help: is no active
.
. u : - : decrease calcul depth
.
. p : + : increase calcul depth
.
. default calcul depth is 128 , see
. block 150, word : cstart : to
. modify initials depth and colors
help - screen.4 - is in the shadow block
help - part 4 -
.
. qwerty keys : app keys : actions
.
. default color of the set is black
. you can change it with
.
. w : r : to red
.
. s : g : to green
.
. x : b : to blue
.
. outside the set, default is a scale of
. colors beginning in blue; the rgb components
. of the initial color can be changed with
.
. q : - : or r : + : modify red component
.
. a : - : or f : + : modify green ::
.
. z : - : or v : + : modify blue ::
help - screen.5 - is in the shadow block
help - part 5 -
.
. qwerty keys : app keys : actions
.
. two functions for julia set only
.
. e : k : increase complexity factor of julia
.
. d : k : decrease complexity factor of julia
.
. ...... a propos ......
.
. fractal viewer with floating point
. written by j.francois calpe jfcalpe@free.fr
. 2008/08/04
.
. thanks to chuck moore, okad development
. team, howerd oakford, ray st. marie
. and all the colorforthers
app: mandelbrot set empt x -110191488 y 7146848 inc 34990 dep 128 hole 0 frame 8912896
home 10000000 768 / dup 1024 * 2/ negate x ! 8000000 y ! inc ! 128 dep ! ; macro
shr ?lit e8c1 2, 1, ;
f* 2ef7 2, 26 shr e2c1 2, 6 1, c20b 2, nip ; forth 168 winver 2 * + load wf+
hue 31416 * ;
vlen dup f* swap dup f* + ;
vdup over over ;
vndup push push vdup pop pop ;
itr over dup f* over dup f* negate + push f* 2* pop swap v+ ;
x: c- emit 0 emit ;
data text 0 0 at 21 x: x @ . 11 x: y @ . 7 x: inc @ . 6 x: dep @ . ; 192 load ok h
display the mandelbrot set with modified colors to update quickly
mandelbrot set
o 0 0 dep @ 1 max for vndup itr vdup vlen -10000000 + drop -if *next drop drop hole @ ; then drop drop pop hue ;
mh x @ swap 1024 for o wf+ inc @ u+ next nip ;
mv y @ 768 for mh inc @ negate + next drop ;
+d 2 dep +!
-d -1 dep +! dep @ 1 max dep !
draw wfinit mv data ;
ok c show draw keyboard ;
ko logo accept ;
l inc @ 1024 8 */ negate x +! draw ;
u inc @ 768 8 */ y +! draw ;
d inc @ 768 8 */ negate y +! draw ;
r inc @ 1024 8 */ x +! draw ;
+z inc @ 3 max dup 1024 8 */ x +! dup 768 8 */ negate y +! 3 4 */ 3 max inc ! draw ;
-z inc @ 10000000 min dup 1024 8 */ negate x +! dup 768 8 */ y +! 4 3 */ inc ! draw ;
hh home draw ;
h pad nul nul ko nul -d nul nul +d l u d r -z nul hh +z nul nul nul nul nul nul nul nul nul nul nul nul 2500 , 2b000023 , 110160c , 2b140023 , 0 , 0 , 0 ,