Haiku Gallery
: n 8 ; \ n 為 立方柱 的 數目 : q 1 n / 2 * mod 1 n / > ; : y' y 1.75 * ; : x' x 2 * ; : 反 x y' + q ; : 斜 x y' - q ; : 菱 反 斜 and ; : 豎 x' q ; 菱 斜 not 豎 and 反 not 豎 not and
Cubes Redux
陳爽
'25 May 24
: n 6 ; ( n Columns ) : a 1 n / ; : q a 2 * mod a > ; x y 1.75 * + q x y 1.75 * - q 2dup and -rot x 2 * q push not r@ and swap not pop not and
Cubes Redux
陳爽
'25 May 24
: 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 .08 mod br ; : b2 \ flag r0 alpha n x0 y0 -- flag' y .05 - .1 mod .05 + - swap x .05 - .08 mod .05 + br ; : same 0.025 pi 10 / 5 ; : stars same 0.05 0.03 b1 .5 x > and .5 y < and same 0.09 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 - 50 stars
Ting
'25 May 24
: 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 May 24
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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
( 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 May 24
( 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: 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 May 24
: pi 3.1415926 ; x y + 5 pi * * sin x y - 5 pi * * sin * 0 >
Arlequin
DarkstarAG
'25 May 24
y 0.5 < y 0.5 < y 0.5 >
Flag of Ukraine Fixed
DarkstarAG
'25 May 24
y 0.5 < y 0.5 < y 0.3 <
Flag of Ukraine Redux
苡恩
'25 May 24
x y sin 1 / .3 +
Minimal animation Redux
苡恩
'25 May 24
\ 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 May 24
: 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 May 24
y .3 < x .3 < x y + 1 <
Flag of South Ossetia Redux
苡恩
'25 May 24
Next