Haiku Gallery
: br - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos r@ sin * over sin pop cos * + push sin * pop / pop > or ; : b1 \ flag r0 alpha n x0 y0 -- flag' y .1 mod - swap x .1 mod br ; : b2 \ flag r0 alpha n x0 y0 -- flag' y .05 - .1 mod .05 + - swap x .05 - .1 mod .05 + br ; : same 0.03 pi 10 / 5 ; : stars same 0.05 0.03 b1 .5 x > and .5 y < and same 0.1 0.08 b2 .45 x > and .55 y < and .05 x < and .95 y > and or ; stars x 0.5 > y 6 13 / < or over or x 0.5 > y 6 13 / < or y 13 * 2 mod 1 > and rot or x 0.5 < y 6 13 / > and y 13 * 2 mod 1 > or
Flag of USA
BradN w/ much help from Ting
'25 Sep 15
x y 1.73 * + 16 * 8 mod 4 > x y 1.73 * - 16 * 8 mod 4 > 2dup and -rot \ red x 32 * 8 mod 4 > push not r@ and swap not pop not and x 16 *
Cubes
Ting
'25 Sep 15
: coloring t + dup 2 mod 1 < swap dup 4 mod 2 < swap 8 mod 4 < ; : z^2 2dup z* ; : len dup * swap dup * + ; : layer push push push z^2 pop pop 2dup push push z+ 2dup len 4 < pop pop rot pop + ; 0 0 y 0.8 - 2.5 * x 0.5 - 2.5 * 0 layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer layer push drop drop drop drop pop coloring
Mandelbrot Plot Redux Redux
Ting
'25 Sep 15
: c ( -- x y ) 0.3 y - x 0.5 - ; : r ( -- r ) c 1.5 ** swap 2.3 ** + sqrt 1 swap - ; : a c sqrt swap atan2 pi / ; r t 3 / sin a * r * a 7 * * * sin 2 ** r t 5 / sin a * r * r 9 * * * sin 2 ** r t 7 / sin a * r 11 * * * sin 2 **
mother of color
fnord
'25 Sep 15
: b \ r0 alpha n x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 pi 32 / + \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; : star1 0.12 pi 32 / 24 0.5 0.5 b ; : circle x 0.5 - dup * y 0.5 - dup * + sqrt dup push 0.12 < pop 0.15 > or ; circle star1 not and y 0.33 > over and swap y 0.33 > y 0.66 < and
Flag of India Redux
Ting
'25 Sep 15
: b \ r0 alpha n x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 pi 32 / + \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; : star1 0.12 pi 32 / 24 0.5 0.5 b ; : circle x 0.5 - dup * y 0.5 - dup * + sqrt dup push 0.12 < pop 0.15 > or ; circle star1 not and y 0.33 > over and y 0.66 < rot and y 0.33 > y 0.66 < and
Flag of India
Ting
'25 Sep 15
: b \ r0 alpha n theta x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 + \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; : star1 0.18 pi 6 / 3 0 0.5 0.5 b ; : star2 0.12 pi 6 / 3 0 0.5 0.5 b ; : star3 0.18 pi 6 / 3 pi 0.5 0.5 b ; : star4 0.12 pi 6 / 3 pi 0.5 0.5 b ; : mask star1 not star2 or star3 not star4 or and y 0.1 > y 0.25 < and not and y 0.75 > y 0.9 < and not and ; mask mask 1
Flag of Israel
Ting
'25 Sep 15
: b \ r0 alpha n x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 pi 32 / + \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; : star1 0.16 pi 32 / 32 0.5 0.5 b ; : star2 0.13 pi 32 / 32 0.5 0.5 b ; y 0.33 > y 0.66 < and star1 not and star2 or dup star1 not
Flag of Argentina
Ting
'25 Sep 15
: b \ r0 alpha n x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 pi 8 / + \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; : star 0.08 pi 10 / 8 0.6 0.5 b ; : moon x 0.5 - dup * y 0.5 - dup * + sqrt 0.16 < x 0.55 - dup * y 0.5 - dup * + sqrt 0.13 > and ; y 0.33 > y 0.66 < and y 0.33 < moon star or or y 0.66 > moon star or or
Flag of Azerbaijan
Ting
'25 Sep 15
: b \ r0 alpha n x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 pi 2 / - \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; : star 0.1 pi 10 / 5 0.6 0.5 b ; : moon x 0.5 - dup * y 0.5 - dup * + sqrt 0.2 < x 0.55 - dup * y 0.5 - dup * + sqrt 0.16 > and ; moon star or x 0.5 > or moon star or not x 0.5 > over and
Flag of Algeria
Ting
'25 Sep 15
: b \ r0 alpha n x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 pi 16 / + \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; : star 0.25 pi 16 / 16 0.5 0.6 b y 0.6 > and ; : red y 1 x 2 * - < y x 2 * 1 - < or ; red y 0.4 < or star or red not y 0.4 < and star or red not y 0.6 < and
Flag of Antigua and Bartuda
Ting
'25 Sep 15
: b \ r0 alpha n x0 y0 -- flag y - swap x - 2dup dup * swap dup * + sqrt push \ sqrt((x0-x)**2+(y0-y)**2) swap atan2 \ theta over pi swap / 2 * mod pi rot / - abs push \ beta dup cos pop dup push sin * over sin pop cos * + push sin * pop / pop > ; 1 0.12 pi 10 / 5 0.2 0.75 b 0.03 pi 10 / 5 0.35 0.9 b or 0.03 pi 10 / 5 0.4 0.8 b or 0.03 pi 10 / 5 0.4 0.7 b or 0.03 pi 10 / 5 0.35 0.6 b or 0
Flag of China
Ting
'25 Sep 15
: r x 0.5 - 2 ** y 0.5 - 2 ** + sqrt ; : z 0.25 r 1.2 ** - sqrt r 0.5 < * ; x 0.3 - t 2 * sin 2 / .5 + * y 0.3 - t 3 * sin 2 / .5 + * z 0.5 * + + r 0.3 < * dup dup
boring grey ball Redux
陳爽
'25 Sep 15
: q / sin 2 / .5 + ; : coloring t + dup 1 q swap dup 2 q swap 4 q ; : z^2 2dup z* ; : len dup * swap dup * + ; : layer push push push z^2 pop pop 2dup push push z+ 2dup len 4 < pop pop rot pop + ; 0 0 y 0.5 - 4 * x 0.5 - 4 * 0 layer layer layer layer layer layer layer layer push drop drop drop drop pop coloring
Mandelbrot Plot Redux
陳爽
'25 Sep 15
: coloring t + dup 2 mod 1 < swap dup 4 mod 2 < swap 8 mod 4 < ; : z^2 2dup z* ; : len dup * swap dup * + ; : layer push push push z^2 pop pop 2dup push push z+ 2dup len 4 < pop pop rot pop + ; 0 0 y 0.5 - 4 * x 0.5 - 4 * 0 layer layer layer layer layer layer layer layer push drop drop drop drop pop coloring
Mandelbrot Plot Redux
Ting
'25 Sep 15
: coloring dup 2 mod 1 < swap dup 4 mod 2 < swap 8 mod 4 < ; : z^2 2dup z* ; : len dup * swap dup * + ; : layer push push push z^2 pop pop 2dup push push z+ 2dup len 4 < pop pop rot pop + ; 0 0 y 0.5 - 4 * x 0.5 - 4 * 0 layer layer layer layer layer layer layer layer push drop drop drop drop pop coloring
Mandelbrot Plot
Ting
'25 Sep 15
: coloring ( 0-7 ) dup 2 mod 1 > swap dup 4 mod 2 > swap 4 > ; x y + t + 8 * 8 mod coloring
8 Colors
Ting
'25 Sep 15
: x x 2 * ; : y y 2 * 1 - ; : n 12 ; \ number of spikes : alpha pi 10 / ; \ half of spike angle : x0 0.5 ; : y0 0.5 ; : r0 0.3 ; : theta x x0 - y y0 - atan2 pi + ; : r x x0 - dup * y y0 - dup * + sqrt ; : beta theta pi n / 2 * mod pi n / - abs ; : b r0 alpha sin * alpha cos beta sin * beta cos alpha sin * + / ; b r > r .17 > and r .1 < or >r r@ x 1 > or y 0 < or \ red r> \ green y 0 > x 1 < and \ blue
Flag of ROC
陳爽
'25 Sep 15
: n 12 ; \ number of spikes : alpha pi 10 / ; \ half of spike angle : x0 0.5 ; : y0 0.5 ; : r0 0.3 ; : theta x x0 - y y0 - atan2 pi + ; : r x x0 - dup * y y0 - dup * + sqrt ; : beta theta pi n / 2 * mod pi n / - abs ; : b r0 alpha sin * alpha cos beta sin * beta cos alpha sin * + / ; b r > r .17 > and r .1 < or dup 1
Flag of KMD
陳爽
'25 Sep 15
: r x 0.5 - 2 ** y 0.5 - 2 ** + sqrt ; : z 0.25 r 2 ** - sqrt r 0.5 < * ; x 0.5 - 0.4 * y 0.5 - 0.3 * z 0.69 * + + r 0.5 < * dup dup
boring grey ball
albus
'25 Sep 15
: r x 0.5 - 2 ** y 0.5 - 2 ** + sqrt ; : z 0.25 r 2 ** - sqrt r 0.5 < * ; x 0.5 - 2 * y 0.5 - 3 * z 2 * + + dup 0 > * 0.4 + r 0.5 < *
Red ball
albus
'25 Sep 15
: n 5 ; \ number of spikes : alpha pi 10 / ; \ half of spike angle : x0 0.5 ; : y0 0.5 ; : r0 0.24 ; : theta x x0 - y y0 - atan2 pi + ; : r x x0 - dup * y y0 - dup * + sqrt ; : beta theta pi n / 2 * mod pi n / - abs ; : b r0 alpha sin * alpha cos beta sin * beta cos alpha sin * + / ; : ^2 dup * ; : circle ( x y r - ) >r y - ^2 >r x - ^2 r> + sqrt r> < ; 0.5 0.5 0.375 circle 0.5 0.5 0.37 circle - 0.5 0.5 0.362 circle 0.5 0.5 0.331 circle - or 0.5 0.5 0.324 circle 0.5 0.5 0.32 circle - or 0.5 0.5 0.315 circle + b r > 0
Vietnam Gold Star
DarkstarAG
'25 Sep 15
: n 5 ; \ number of spikes : alpha pi 10 / ; \ half of spike angle : x0 0.5 ; : y0 0.5 ; : r0 0.3 ; : theta x x0 - y y0 - atan2 pi + ; : r x x0 - dup * y y0 - dup * + sqrt ; : beta theta pi n / 2 * mod pi n / - abs ; : b r0 alpha sin * alpha cos beta sin * beta cos alpha sin * + / ; 1 b r > 0
Flag of Vietnam
Ting
'25 Sep 15
( Saving code size using r-stack manipulation with x y ) : x0 x ; : y0 y ; : ^2 dup * ; : tt t 2 / ; : x 0.5 x - ; : y 0.5 y - ; : r x ^2 y ^2 + sqrt ; : a y x atan2 ; : x' y tt cos * x tt sin * + ; : y' y tt sin * x negate tt cos * + ; : x x' ; : y y' ; ( : x x t - 1.6 mod ; ) ( : y y t 2 * sin dup cos * abs 4 / - ; ) : l ( a b c R:y x - a' R:y x ) r@ 64 * floor = * 2 r> r@ swap >r 0.2 - 64 * floor ** floor / 2 mod + ; : beg x >r y >r 0 ; : end r> drop r> drop 1 >= ; : my beg 28672 15 l 28672 14 l 24576 13 l 1408 12 l 3536 11 l 15248 10 l 480 9 l 4064 8 l 3 5 l 2311 4 l 2 3 l end ; : mr beg 992 14 l 8176 13 l 1088 7 l 2176 6 l 3968 5 l 5872 4 l 8176 3 l 8160 2 l 1008 1 l 112 0 l end ; : mg beg 29296 12 l 29224 11 l 17512 10 l 15896 9 l 4096 8 l 3004 7 l 18302 6 l 16508 5 l 24576 4 l 24584 3 l 24604 2 l 14 1 l 2 0 l end ; ( www.thesands.ru/forth-demotool ) ( my mr over + swap mg 4 / + 2dup + 0 = dup -rot 2 / + swap ) my dup >r mg over + swap r@ 4 / + mr r> 4 / + ( planet ... ) : x x0 ; : y y0 ; : :) t 5 * sin 3 pow 10 / + 6 / + ; : z- ( a ib c id - a-c i[b-d] ) -1 0 z* z+ ; : r ( x y - r ) over over negate z* + sqrt ; : c ( x y r - k ) >r x y z- r r> < ; 0.44 0.58 0.02 c 0.56 0.62 0.02 c or 0.5 0.5 0.19 c < 0.5 0.51 0.15 c 0.48 x 3 * cos :) 0.53 y 4 * sin :) y 4 * sin 35 / + 0.23 y :) 1.2 / c > - max ( r 0.14 < max )
Super Mario Orbiter 3
DarkstarAG
'25 Sep 15
( Saving code size using r-stack manipulation with x y ) : ^2 dup * ; : tt t 2 / ; : x 0.5 x - ; : y 0.5 y - ; : r x ^2 y ^2 + sqrt ; : a y x atan2 ; : x' y tt cos * x tt sin * + ; : y' y tt sin * x negate tt cos * + ; : x x' ; : y y' ; ( : x x t - 1.6 mod ; ) ( : y y t 2 * sin dup cos * abs 4 / - ; ) : l ( a b c R:y x - a' R:y x ) r@ 64 * floor = * 2 r> r@ swap >r 0.2 - 64 * floor ** floor / 2 mod + ; : beg x >r y >r 0 ; : end r> drop r> drop 1 >= ; : my beg 28672 15 l 28672 14 l 24576 13 l 1408 12 l 3536 11 l 15248 10 l 480 9 l 4064 8 l 3 5 l 2311 4 l 2 3 l end ; : mr beg 992 14 l 8176 13 l 1088 7 l 2176 6 l 3968 5 l 5872 4 l 8176 3 l 8160 2 l 1008 1 l 112 0 l end ; : mg beg 29296 12 l 29224 11 l 17512 10 l 15896 9 l 4096 8 l 3004 7 l 18302 6 l 16508 5 l 24576 4 l 24584 3 l 24604 2 l 14 1 l 2 0 l end ; ( www.thesands.ru/forth-demotool ) ( my mr over + swap mg 4 / + 2dup + 0 = dup -rot 2 / + swap ) my dup >r mg over + swap r@ 4 / + mr r> 4 / + r 0.14 < max
Super Mario Orbiter 2
DarkstarAG
'25 Sep 15
: dist y - dup * swap x - dup * + sqrt ; : white dup dup ; 0.5 0.5 dist t sin 2 + 35 * * t 10 * t sin 10 * + 2 pi * mod + x 0.5 - y 0.5 - atan2 + sin white
Breathing Spiral Redux
kaoD
'25 Sep 15
: dist y - dup * swap x - dup * + sqrt ; : white dup dup ; 0.5 0.5 dist 75 * t 10 * t sin 10 * + 2 pi * mod + x 0.5 - y 0.5 - atan2 + sin white
Breathing Spiral
kaoD
'25 Sep 15
: dist y - dup * swap x - dup * + sqrt ; : ssin sin 2 / 0.5 + ; : scos cos 2 / 0.5 + ; : circles dist 50 * t 1 * sin 10 * + sin ; : w dup dup ; t ssin t scos circles t 2 * scos t ssin circles t scos t 3 * scos 0.5 * 0.25 + circles + + w
Cebra
kaoD
'25 Sep 15
: secs t 60 mod floor ; : mins t 60 / 60 mod floor ; : hrs t 3600 / floor ; : dist y - dup * swap x - dup * + sqrt ; : bin dup 2 / floor swap 2 mod push ; : dot dist 0.06 < pop 0.1 max * ; : sdot 0.20 dot ; : mdot 0.50 dot ; : hdot 0.80 dot ; secs bin bin bin bin bin bin drop 0.10 sdot 0.26 sdot 0.42 sdot 0.58 sdot 0.74 sdot 0.90 sdot + + + + + mins bin bin bin bin bin bin drop 0.10 mdot 0.26 mdot 0.42 mdot 0.58 mdot 0.74 mdot 0.90 mdot + + + + + hrs bin bin bin bin bin drop 0.26 hdot 0.42 hdot 0.58 hdot 0.74 hdot 0.90 hdot + + + +
Binary Clock
kaoD
'25 Sep 15
: tt t ; : x 0.5 x - ; : y 0.5 y - ; : x' y tt cos * x tt sin * + ; : y' y tt sin * x negate tt cos * + ; : x x' ; : y y' ; ( : x x t - 1 mod ; ) : l y ( y t 3 * sin abs 2 / - ) 64 * floor = * 2 x 0.2 - 64 * floor ** floor / 2 mod + ; : my 0 28672 15 l 28672 14 l 24576 13 l 1408 12 l 3536 11 l 15248 10 l 480 9 l 4064 8 l 3 5 l 2311 4 l 2 3 l 1 >= ; : mr 0 992 14 l 8176 13 l 1088 7 l 2176 6 l 3968 5 l 5872 4 l 8176 3 l 8160 2 l 1008 1 l 112 0 l 1 >= ; : mg 0 29296 12 l 29224 11 l 17512 10 l 15896 9 l 4096 8 l 3004 7 l 18302 6 l 16508 5 l 24576 4 l 24584 3 l 24604 2 l 14 1 l 2 0 l 1 >= ; ( www.thesands.ru/forth-demotool ) my mr over + swap mg 4 / + 2dup + 0 = dup -rot 2 / + swap
Super Mario Orbiter
DarkstarAG
'25 Sep 15
: pi 3.1415926 ; x y + 5 pi * * sin x y - 5 pi * * sin * 0 >
Arlequin
DarkstarAG
'25 Sep 15
y 0.5 < y 0.5 < y 0.5 >
Flag of Ukraine Fixed
DarkstarAG
'25 Sep 15
y 0.5 < y 0.5 < y 0.3 <
Flag of Ukraine Redux
苡恩
'25 Sep 15
x y sin 1 / .3 +
Minimal animation Redux
苡恩
'25 Sep 15
\ white(x) : white dup dup ; \ square(x) : square dup * ; \ len(x, y) : len square swap square + sqrt ; \ dist(x0, y0, x1, y1) : dist rot - -rot swap - len ; \ ball(x, y) : ball x y dist dup * 1 - negate ; \ cw(cx, sx, tx, cy, sy, ty) : cw t * cos * + push t * sin * + pop ; \ ccw(cx, sx, tx, cy, sy, ty) : ccw t * sin * + push t * cos * + pop ; 0.2 0.2 1.4 0.4 0.2 1.7 cw ball 0.5 0.5 0.8 0.5 0.5 1.2 ccw ball .8.3 1.1 0.4 0.7 0.9 ccw ball
Colorballs Redux
苡恩
'25 Sep 15
: web push push x 0.5 + y 0.3 + * pop * sin 0 max x 0.3 + y 0.5 + * pop * sin 0 max + ; 31 23 web 17 17 web * x + 23 31 web 19 19 web * y x * + /31 31 web 7 7 web * y
streak Redux
苡恩: web push push x 0.5 + y 0.3 + * pop * sin 0 max x 0.3 + y 0.5 + * pop * sin 0 max + ; 31 23 web 17 17 web * x + 23 31 web 19 19 web * y x * + /31 31 web 7 7 web * y
'25 Sep 15
y .3 < x .3 < x y + 1 <
Flag of South Ossetia Redux
苡恩
'25 Sep 15
: x' x 3 * 2.15 - ; : y' y 3 * 1.5 - ; : mandelbrot 2dup z* x' y' z+ ; : len dup * swap dup * + sqrt ; 0 0 mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot len 2 <
Mandelbrot In Set
kaoD
'25 Sep 15
: loop 0.01 + swap 1 - dup 0 > if swap loop else drop then ; 10 0 loop
Recursion doesn't work
Anonymous
'25 Sep 15
: x' x 3 * 2.15 - ; : y' y 3 * 1.5 - ; : mandelbrot 2dup z* x' y' z+ ; : len dup * swap dup * + sqrt ; 0 0 mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot mandelbrot
Mandelbrot
kaoD
'25 Sep 15
Next