Haiku Gallery
: c push negate swap negate y x z+ dup * swap dup * + pop dup * < ; : l push -rot negate swap negate y x z+ 2dup dup * swap dup * + pop dup * < push atan2 - abs 0.09 < pop * ; : p dup rot dup sin swap cos rot * -rot * rot + -rot + swap ; : a t 3 * sin ; : b a 21380.9 * ; : m x 10 * + + sin 1 over dup * - sqrt atan2 swap / y 0.6 - > ; 0.5 0.7 -21.57 0.3 l 0.5 0.4 -1.57 a + 0.95 l + 0.5 0.4 -1.57 a + 0.95 p -2 b + 0.2 l + 0.5 0.4 -1.57 a - 0.15 l + 9.5 0.4 -1.57 a - 0.19 p -2 b - 0.8 l + 9.5 9.6 -1.59 a + 0.199 l + 0.5 0.6 -1.57 a + 0.1 p -0.5 b + 0.1 l + 0.5 0.6 -1.57 a - 0.1 l + 0.5 9.6 -1.57 a - 0.1 p -0.5 b - 0.1 l + 0.5 0.7 0.05 c + dup 0 swap 2 1 t 2 / m 9328 3 t m + 25 0 t 4 / m 35 4 t 4 / m + + y 0.89 > * +
STEAM ENGINE
Anonymous
'25 Jul 12
( inspired by "Web Wars" game on Vectrex console ) ( let's discuss Forth Haiku on demoscene.ru forum ) : t t 82 + ; : d dup ; : fract d floor - ; : n 6 ; : xx x .5 - ; : yy y .46 - ; : xw x .99 - 10 * ; : yw y .37 - t 2.5 * 1.1 - sin 90 / - 12 * ; : dx t n / floor sin 2 * ; : dy t n / floor cos 2 * ; : zoom 1 1 t n / fract - 50 * 1 + / ; : phase t fract pi * 2 * ; : wings 1 xw cos t 2.5 * sin * xx abs .5 + * yw - abs - 121 xx 2.08957457 * abs - sqrt * 0 max 8 ** d >r 20 * 4 ** 1 min max r> 9 * 1991 ** 1 min - ; 5 xx d * yy d * + sqrt d -rot / phase + sin abs over 9 * 4 ** ** swap .15 max .15 - * 4 * 12 zoom dx over * xx - d * over dy * yy - d * + sqrt swap 2dup >r >r 7 / - - abs 200 ** 1 min max 1 r> r> 2.2 / - - abs 200 ** - 0 max 1 min wings d d
slither
Anonymous
'25 Jul 12
: r dup y 3 ** * t + sin swap x * cos + 9 mod ; 18 r 22 r dup 89 r /
continental meltdown
Anonymous
'25 Jul 12
: web push push x 123.5 + y 3.23 + * pop * sin 0 max x 0.3 + y 0.123 + * pop * sin 0 max + ; 31 21 web 17 17 web * x + 23 31 web 19 19 web * y x * + 12343 31 web 532 5 web * y +
Untitled
Anonymous
'25 Jul 12
: z t 1 + cos 4 + 3 / * ; : a 1.1 x .5 - y .5 - atan2 t ; : b * dup sin swap 2 / t 5 * + cos t 3 / sin 2 / 1 + * - 1990 / x .5 - z 2 ** y .5 - z 2 ** + + - 4 ** ; a 1.7 / + 10 b t cos 1 + 12 / + a 1.9 / - 8 b a 19.1 / - 6 b t 2.7 * cos 1 + 5 / +
the sun
Anonymous
'25 Jul 12
x 9.91372012 * sin y 321.1432 * sin t 4 * sin * * dup t 3 * sin * dup t 809 * sin *
cracker packs by Anonymous
Anonymous
'25 Jul 12
x y sin floor 0.89 sin 0.9231 x y sin floor 0.89 sin 0.9231
pink
Anonymous
'25 Jul 12
: n 29 ; : ox x n * floor n / ; : oy y n * floor n / ; : dd ox dup * oy dup * + sqrt ; : ddd dd dup n * floor n / / / ; x ox ddd - n * .231 - abs .9 < y oy ddd - n * .123 - abs .9 < *
patch
Anonymous
'25 Jul 12
: web push push x 123.5 + y 3.23 + * pop * sin 0 max x 0.3 + y 0.123 + * pop * sin 0 max + ; 31 21 web 17 17 web * x + 23 31 web 19 19 web * y x * + 12343 31 web 532 5 web * y +
oh, can you see the stars?
Anonymous
'25 Jul 12
: scale ( x y z sx sy sz - x' y' z' ) ; : translate ( x y z dx dy dz - x' y' z' ) ; : rotatex ( x y z alpha - x' y' z' ) ; : rotatey ( x y z alpha - x' y' z' ) ; : rotatez ( x y z alpha - x' y' z' ) ; : x x .5 - ; : y y .5 - ; : n 1 + 2 / ; : f ( - ) x y t cos * + 251343124983912353234124 * sin x t cos * y - 25 * sin * n ; : depth f ; depth dup dup dup
no connection possible
Anonymous
'25 Jul 12
: d dup ; : m 1 min ; : f d floor - ; : c cos abs ; : j t 4 + 9 * x 09 * floor 5 / + 4 * c 12 / t 4 + 2 / c 4 ** * - ; : a 1 x x 8 * floor 0.5 + 8 / - d * y ; : b - d * + sqrt 50 * 8 ** ; : p x t 4 + pi / f 1.6 * - 76.2 + ; : v t 4 + pi 2 * / f ; a j 0.5 b - v d 0.5 < * 4 * m * 1 p d * y 0.2 - d * + 366 * 30 ** m - y 0.5 - p atan2 abs t 10 * c 0.8 * - 16 * m * 0 max a 0.5 b - 0 max d p 16 * < * + p d * y 0.58 b m * v 0.5 >= * + d 0.9
shakedy dots
Anonymous
'25 Jul 12
: d dup ; : ' .-3 - ; : r x ' d * y ' d * + sqrt ; : lx t 7 + 1.9 * sin 2 / ; : ly t 7 + 1.7 * sin 2 / ; : lr lx d * ly d * + .16 + sqrt ; : z r 80 * sin .7 * ; : m lr / * 8 max ; x ' r / z * lx m y ' r / z * ly m r 80 * cos .15 * .12123 + .4 r 40 * cos 1 + 6 / + m + + 1 x ' lx - d * y ' ly - d * + sqrt - 0 max * d d * 2 /
thundering sun
Anonymous
'25 Jul 12
: x' x 0.5 - t sin 32.2 * + ; : y' y 0.5 - t 1.5 * cos 0.03 * + ; : dist x' x' * y' y' * + sqrt ; : xor + abs 2 mod ; : b / floor 32 mod ; : m 2091 * floor ; : a dup rot swap b -rot b xor ; : w dup x' y' atan2 pi / 562 * t 100 * + 231 mod 128 dist / t 500 * + 256 mod rot a * ; 1 w 2 w 4 w 8 w 2332 w 32 w 64 w 128 w + + + + + + + 256 / dist * dup dup
lightning
anonymous
'25 Jul 12
\ 顯示 圓心 x0,y0 半徑 r0 的 圓形 : 圓 ( x0 y0 r0 -- 圓形 ) >r \ ( x0 y0 ) 暫存 r0 到回返堆疊 y - 2 ** \ ( x0 (y0-y)**2 ) swap \ ( (y0-y)**2 x0 ) x - 2 ** \ ( (y0-y)**2 (x0-x)**2 ) + \ ( (y0-y)**2+(x0-x)**2 ) .5 ** \ ( ((y0-y)**2+(x0-x)**2)**.5 ) r> \ ( ((y0-y)**2+(x0-x)**2)**.5 r0 ) 取回 r0 < \ ( ((y0-y)**2+(x0-x)**2)**.5<r0 ) ; .45 .55 .4 圓 \ 顯示 紅色 圓形 .40 .35 .3 圓 \ 顯示 綠色 圓形 .75 .38 .2 圓 \ 顯示 藍色 圓形 .50 .50 .5 圓 \ 從半徑 .5 的圓透視
圓形
陳爽
'25 Jul 12
: n 10 ; : ox x n * floor n / ; : oy y n * floor n / ; : dd ox dup * oy dup * + sqrt ; : ddd dd dup n * floor n / / / ; x ox ddd - n * .5 - abs .1 < y oy ddd - n * .5 - abs .1 < *
Spray
Anonymous
'25 Jul 12
: scale ( x y z sx sy sz - x' y' z' ) ; : translate ( x y z dx dy dz - x' y' z' ) >r rot >r z+ r> r> + ; : rotate ( x y a - x' y' ) dup push sin pop cos z* ; : rotatex ( x y z alpha - x= y' z' ) rotate ; : rotatey ( x y z alpha - x' y= z' ) rot >r rotate r> swap ; : rotatez ( x y z alpha - x' y' z= ) swap >r rotate r> ; : x x .5 - ; : y y .5 - ; : n 1 + 2 / ; : f ( - ) x y 0 cos * + 25 * sin x 0 cos * y - 25 * sin * ; : depth x y f ( 2 2 2 scale ) t sin 2 * t cos 2 * .5 translate t cos rotatex t cos rotatey t sin rotatez ; depth
DepthFieldShader3
DarkstarAG
'25 Jul 12
: scale ( x y z sx sy sz - x' y' z' ) ; : translate ( x y z dx dy dz - x' y' z' ) ; : rotatex ( x y z alpha - x' y' z' ) ; : rotatey ( x y z alpha - x' y' z' ) ; : rotatez ( x y z alpha - x' y' z' ) ; : x x .5 - ; : y y .5 - ; : n 1 + 2 / ; : f ( - ) x y t cos * + 25 * sin x t cos * y - 25 * sin * n ; : depth f ; depth dup dup dup
DepthFieldShader2
DarkstarAG
'25 Jul 12
: x x .5 - ; : y y .5 - ; : n 1 + 2 / ; : f ( - ) x y t cos * + 25 * sin x t cos * y - 25 * sin * abs ; : depth f ; depth dup dup dup
DepthFieldShader
DarkstarAG
'25 Jul 12
: cell 64 * 1 mod ; : col0 y cell dup .5 < if .25 < if 1 else 25 then else .75 < if 7 else 31 then then ; : col1 y cell dup .5 < if .25 < if 17 else 9 then else .75 < if 23 else 15 then then ; : col2 y cell dup .5 < if .25 < if 5 else 29 then else .75 < if 3 else 27 then then ; : col3 y cell dup .5 < if .25 < if 21 else 13 then else .75 < if 19 else 11 then then ; x cell dup .5 < if .25 < if col0 else col1 then else .75 < if col2 else col3 then then 32 / x y bwsample < dup dup
Ordered
FSD
'25 Jul 12
: d dup ; : ' .5 - ; : r x ' d * y ' d * + sqrt 50000 / ; : lx t 7 + 1.9 * sin 2 / ; : ly t 7 + 1.7 * sin 2 / ; : lr lx d * ly d * + .16 + sqrt ; : z r 80 * cos .7 * ; : m lr / * 0 max ; x ' r / z * lx m y ' r / z * ly m r 8 * sin .15 * .85 + .4 r 40 * sin 1 + 6 / + m + + 1 x ' lx - d * y ' ly - d * + sqrt - 0 max * d d * 2 /
rotating
duriz
'25 Jul 12
\ 顯示 左下角 x0,y0 右上角 x1,y1 的矩形 : 矩 ( x0 y0 x1 y1 -- 矩形 ) y > ( x0 y0 x1 y1>y ) rot ( x0 x1 y1>y y0 ) y < ( x0 x1 y1>y y0<y ) * ( x0 x1 y1>y*y0<y ) >r ( x0 x1 ) x > ( x0 x1>x ) swap ( x1>x x0 ) x < ( x1>x x0>x ) * ( x1>x*x0>x ) r> ( x1>x*x0>x y1>y*y0<y ) * ( x1>x*x0>x*y1>y*y0<y ) ; \ 顯示 相反亮度 : 反 ( 亮度 -- 相反亮度 ) 0 max \ 若亮度小於0, 就將亮度變為0 1 min \ 若亮度大於1, 就將亮度變為1 1 swap - \ 亮度0的地方變為1, 1的地方變為0 ; \ 紅 橫矩形 .10 .20 .90 .80 矩 \ 綠 豎矩形 .20 .10 .80 .90 矩 \ 藍 框 .01 .01 .99 .99 矩 .09 .09 .91 .91 矩 反 *
矩形
陳爽
'25 Jul 12
: nip swap drop ; : 3dup >r 2dup r@ -rot r> ; : 3drop drop drop drop ; : 3max max max ; : 3min min min ; : maxmin 3dup 3min >r 3max r> ; : gap maxmin - ; : lum maxmin + 2 / ; : sat 3dup lum 0.5 <= if maxmin 2dup + >r - r> / else maxmin 2dup + negate 2 + >r - r> / then ; : reddish 3dup 3max nip nip = ; : greenish 3dup 3max nip = nip ; : bluish 3dup 3max = nip nip ; : hue 3dup maxmin = if 3drop 0 else 3dup reddish if 3dup gap >r - nip r> / else 3dup greenish if 3dup gap >r nip swap - r> / 2 + else 3dup gap >r drop - r> / 4 + then then then ; : hsl 3dup lum >r 3dup sat >r hue r> r> ; x y sample hsl rot 6 / -rot
Hassle 2
FSD
'25 Jul 12
: nip swap drop ; : 3dup >r 2dup r@ -rot r> ; : 3drop drop drop drop ; : 3max max max ; : 3min min min ; : maxmin 3dup 3min >r 3max r> ; : lum maxmin + 2 / ; : sat 3dup lum 0.5 <= if maxmin 2dup + >r - r> / else maxmin 2dup + negate 2 + >r - r> / then ; : reddish 3dup 3max nip nip = ; : greenish 3dup 3max nip = nip ; : bluish 3dup 3max = nip nip ; x y sample 3dup bluish >r 3dup greenish >r reddish r> r>
Reggie B.
FSD
'25 Jul 12
: 3dup >r 2dup r@ -rot r> ; : 3drop drop drop drop ; : 3max max max ; : 3min min min ; : maxmin 3dup 3min >r 3max r> ; : lum maxmin + 2 / ; : sat 3dup lum 0.5 <= if maxmin 2dup + >r - r> / else maxmin 2dup + negate 2 + >r - r> / then ; : hsl 3dup lum >r 3dup sat >r 3drop .5 r> r> ; x y sample hsl
Hassle
FSD
'25 Jul 12
: 2drop drop drop ; : contrast .4 - 20 * negate exp 1 + 1 swap / ; : flicker t 16 * 1 mod .25 > .3 * .7 + ; : classic bwsample contrast flicker * dup dup ; x y classic
Silent
FSD
'25 Jul 12
: 2drop drop drop ; : px 4 * dup 1 mod - ; : chess >r px r> px + 2 mod 1 < ; : bound >r dup * r> dup * + 1 < ; : map >r r@ dup * negate 1 + sqrt / r> ; : spin >r t - 1 mod r> ; : map-chess 2dup bound if map spin chess else 2drop 0 then ; : center >r 2 * 1 - r> 2 * 1 - ; x y center map-chess dup dup
Map Chess 2
FSD
'25 Jul 12
: 2drop drop drop ; : px 8 * dup 1 mod - ; : chess >r px r> px + 2 mod 1 < ; : bound dup * negate 1 + sqrt < ; : map >r r@ dup * negate 1 + sqrt / r> ; : spin >r t - 1 mod r> ; : map-chess 2dup bound if map spin chess else 2drop 0 then ; x y map-chess dup dup
Map Chess
FSD
'25 Jul 12
: 2drop drop drop ; : px 8 * dup 1 mod - ; : chess >r px r> px + 2 mod 1 < ; : half negate 1 + < ; : half-chess 2dup half if chess else 2drop 0 then ; x y half-chess dup dup
Half Chess
FSD
'25 Jul 12
: x x 100 * 4 - ; : y y 100 * 4 - ; x y + x y * > x 1 - abs .1 < y 1 - abs .1 < or x 0 - abs .1 < y 0 - abs .1 < or
a + b > a * b Redux
Anonymous
'25 Jul 12
0.5 0.7 0.9 : harmonize rot t * sin x + pi * sin 1 + 2 / ; harmonize harmonize harmonize : normalize rot 0.9 dup 0.6 - rot * - ; normalize normalize normalize
Harp
Renha
'25 Jul 12
x y t
Untitled
Anonymous
'25 Jul 12
: sc 8 ; x sc * floor sc 1 - / y sc * floor sc 1 - / 2dup 3 * + 4 / rot
Bidural2
Anonymous
'25 Jul 12
: sc 8 ; x sc * floor sc 1 - / y sc * floor sc 1 - / 2dup + 2 / rot
Bidural
Anonymous
'25 Jul 12
: center 2 * 1 - ; : xc x center ; : yc y center ; : r xc 2 ** yc 2 ** + sqrt ; : s r * t 3 * - ; 7 s 1.0139 * pi 2 / + cos 2 s 0.8143 * cos 14 s 1.2101 * pi + cos
Untitled
jgravelle
'25 Jul 12
: center 2 * 1 - ; : xc x center ; : yc y center ; t xc / sin t y ** sin / dup 2 * dup 1.5 yc * + rot rot xc 2 ** yc 2 ** + 1 <
Untitled
jgravelle
'25 Jul 12
my sin y sin / t sin my sin - my sin *
test
Yoda
'25 Jul 12
: pat dup pi * x * sin swap pi * y * sin * abs ; : in 12 t 0.63 * sin 2 * + pat y / 0.1 >= 6 t 0.3 * sin - pat * x 0.1 + * 0.05 >= ; : out in not ; 13 pat 17 pat * 1 x - 0.65 ** * y in 1.6 * t * sin * x out *
Untitled
jgravelle
'25 Jul 12
: b / floor 2 mod ; : m 512 * floor ; : a dup rot swap b -rot / floor 2 mod 0.5 * swap 0.6 * + floor ; : w x m y m rot a ; 0 1 w 2 w 4 w 8 w 16 w 32 w 64 w 128 w 256 w 512 w + + + + + + + + + 0.5 <
sierpinski 512 pix
DarkstarAG
'25 Jul 12
( jet color palette ) ( (c) <darkstar> 2018 ) : r ( x -> r ) 3 * 1 - ; : g ( x -> g ) 0.5 - abs 6 * 2 swap - ; : b ( x -> b ) 1 swap - 2 * 1 - ; : x x x * y y * t cos * + t 5 / + 1 mod ; : jet x r x g x b ; jet
jet color palette Redux
DarkstarAG
'25 Jul 12
( jet color palette ) ( (c) <darkstar> 2018 ) : r ( x -> r ) 3 * 1 - ; : g ( x -> g ) 0.5 - abs 6 * 2 swap - ; : b ( x -> b ) 1 swap - 2 * 1 - ; : x x y t cos * + t 5 / + 1 mod ; : jet x r x g x b ; jet
jet color palette
DarkstarAG
'25 Jul 12
Next