Haiku Gallery
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
陳爽
'24 Nov 26
: 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
陳爽
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: coloring ( 0-7 ) dup 2 mod 1 > swap dup 4 mod 2 > swap 4 > ; x y + t + 8 * 8 mod coloring
8 Colors
Ting
'24 Nov 26
: 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
陳爽
'24 Nov 26
: 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
陳爽
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
( 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
'24 Nov 26
( 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: 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
'24 Nov 26
: pi 3.1415926 ; x y + 5 pi * * sin x y - 5 pi * * sin * 0 >
Arlequin
DarkstarAG
'24 Nov 26
y 0.5 < y 0.5 < y 0.5 >
Flag of Ukraine Fixed
DarkstarAG
'24 Nov 26
y 0.5 < y 0.5 < y 0.3 <
Flag of Ukraine Redux
苡恩
'24 Nov 26
x y sin 1 / .3 +
Minimal animation Redux
苡恩
'24 Nov 26
\ 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
苡恩
'24 Nov 26
: 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
'24 Nov 26
y .3 < x .3 < x y + 1 <
Flag of South Ossetia Redux
苡恩
'24 Nov 26
: 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
'24 Nov 26
: loop 0.01 + swap 1 - dup 0 > if swap loop else drop then ; 10 0 loop
Recursion doesn't work
Anonymous
'24 Nov 26
: 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
'24 Nov 26
: foo pi swap x y + 1 - * 3 * pow t 0.2 * + 5 mod 0.2 * ; : glass push push push x pop * sin foo y pop * sin foo * x y * pop * sin foo * ; 7 33 19 glass dup 17 33 7 glass + dup 33 7 21 glass + swap
jello glass Redux
Anonymous
'24 Nov 26
\ 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 0.7 0.3 1.1 0.4 0.4 0.3 ccw ball
Colorballs
kaoD
'24 Nov 26
( Who draw the national flag of the Kingdom of Saudi Arabia ? ) : :) 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.4 0.6 0.02 c 0.6 0.65 0.02 c or 0.5 0.5 0.25 c < 0.5 0.51 0.2 c 0.48 x 3 * cos :) 0.58 y 4 * sin :) y 4 * sin 35 / + 0.23 y :) c > -
Who Draws Flag of Arabia ? :)
DarkstarAG
'24 Nov 26
: a ( -- angle ) x y atan2 ; : p ( i -- angle ) 10 / pi * ; : s ( b e -- f ) a swap p < a rot p > and ; 1 4 s 1 2 s 3 5 s or 0 1 s 3 4 s or
Flag of Seychelles Redux Redux
陳爽
'24 Nov 26
: 平移放大 ( 舊值 位置 倍數 -- 新值 ) >r - r> * ; : x ( -- x新值 ) x .5 2.4 平移放大 ; \ x 改以 .5 為中心 並放大 2.4 倍 \ x 範圍 從 0 到 1 變為 (0-.5)*2.4 到 (1-.5)*2.4 : y ( -- y新值 ) y .75 2.8 平移放大 ; \ y 改以 .7 為中心 並放大 2.4 倍 \ y 範圍 從 0 到 1 變為 (0-.7)*2.4 到 (1-.7)*2.4 : dot ( x y -- r*r ) dup * swap dup * + ; : l dup -0.04 * r> r> 2dup * 2 * x + >r 2dup z* drop y + r> 2dup >r >r dot + abs rot min swap rot over 1.32457 * t + r> r> 2dup >r >r rot dup cos -2 * swap sin -2 * z+ dot min -rot 1 + ; y x >r >r 4 4 t .05 * sin 5 * .1 + l l l l l l l l l drop log 8 / negate swap log 8 / negate swap dup >r 2 ** over 3 ** + r> 1.7 ** 1 r> - .04 ** * .2 ** r> drop x x * y .4 + dup * + sqrt 1.5 swap - 1.5 * ( based on shader by Guil )
Emerald Necklace Redux
陳爽
'24 Nov 26
x \ 紅光亮度橫向變化從左到右從 0 到 1 y \ 綠光亮度縱向變化從下到上從 0 到 1 t dup floor - \ 藍光亮度每秒變化從 0 到 1
Ricky's first Haiku Redux Redux
陳爽
'24 Nov 26
Next