Haiku Gallery
\ n-edge-graph : polygon ( X Y R N -- red_circle n_green_edge ) over >r rot y swap - >r ( X R N | R y-Y ) rot x swap - >r swap ( N R | R y-Y x-X ) pi 2 / dup >r ( N R α | R y-Y x-X α ) sin * ( N R*sin[α] | R y-Y x-X α ) r> rot ( R*sin[α] α N | R y-Y x-X ) pi swap / ( R*sin[α] α h | R y-Y x-X ) dup dup + ( R*sin[α] α h a | R y-Y x-X ) r> r@ ( R*sin[α] α h a x-X y-Y | R y-Y ) over >r ( R*sin[α] α h a x-X y-Y | R y-Y x-X ) atan2 ( R*sin[α] α h a θ | R y-Y x-X ) swap mod ( R*sin[α] α h mod(θ,a) | R y-Y x-X ) swap - ( R*sin[α] α mod(θ,a)-h | R y-Y x-X ) abs ( R*sin[α] α β | R y-Y x-X ) over cos over sin * ( R*sin[α] α β cos[α]*sin[β] | R y-Y x-X ) -rot ( R*sin[α] cos[α]*sin[β] α β | R y-Y x-X ) cos swap sin * + ( R*sin[α] cos[α]*sin[β]+cos[β]*sin[α] | R y-Y x-X ) / ( K | R y-Y x-X ) r> 2 ** r> 2 ** + sqrt ( K r | R ) dup r> .93 * < -rot - ( r<R*.95 K-r | ) abs 1 swap - 199 ** ( r<R*.95 {1-abs[K-r]}**199 | ) ; .5 .5 .2 3 polygon
circle and triangle
sjdiau
'25 Sep 18
: 3dup >r 2dup r@ -rot r> ; : offset >r swap >r + r> r> + ; : between >r swap dup >r <= r> r> < and ; : hor >r .01 .09 between r> -.01 .01 between and ; : ver >r -.01 .01 between r> .01 .09 between and ; : off over <> r> and >r ; : sega >r 0 -.2 offset hor r> 1 >r 1 off 4 off drop r> and ; : segb >r -.1 -.1 offset ver r> 1 >r 5 off 6 off drop r> and ; : segc >r -.1 0 offset ver r> 1 >r 2 off drop r> and ; : segd >r hor r> 1 >r 1 off 4 off 7 off 9 off drop r> and ; : sege >r ver r> 1 >r 1 off 3 off 4 off 5 off 7 off 9 off drop r> and ; : segf >r 0 -.1 offset ver r> 1 >r 1 off 2 off 3 off 7 off drop r> and ; : segg >r 0 -.1 offset hor r> 1 >r 0 off 1 off 7 off drop r> and ; : digit 3dup sega >r 3dup segb r> or >r 3dup segc r> or >r 3dup segd r> or >r 3dup sege r> or >r 3dup segf r> or >r segg r> or ; : 2digit 3dup >r >r >r 10 / floor digit r> .14 - r> r> 10 mod floor digit or ; : sec t 60 mod floor ; : r x .5 - 2 ** y .5 - 2 ** + .5 ** ; \ r .3 < x .36 - y .4 - sec 2digit x y 1 sega
timer Redux
Anonymous
'25 Sep 18
: 2pi pi 2 * ; : a y .5 - x .5 - atan2 2pi / 1 mod ; \ 中心 到 x,y 角度 a .1 - 1 mod \ 36 degree angle
36 degree
sjdiau
'25 Sep 18
: offset >r swap >r - r> r> - ; : norm dup * swap dup * + sqrt ; : theta swap atan2 ; : polar 2dup norm -rot theta ; : rect 2dup cos * -rot sin * ; : shine 80 * 2 ** 1 + 1 swap / ; : swing t 1.6 * pi * dup >r 2 * cos .25 * r> pi .25 * + sin .25 * ; : length swing norm ; : saber x y .5 .5 offset polar swing theta - rect >r dup 0 < if drop r> drop 1000 else dup length <= if drop r> else length - r> norm then then ; saber shine
Darth Vader 2
FSD
'25 Sep 18
: nip swap drop ; : offset >r swap >r - r> r> - ; : norm dup * swap dup * + sqrt ; : theta swap atan2 ; : polar 2dup theta >r norm r> ; : rect 2dup sin * >r cos * r> ; : shine 80 * 2 ** 1 + 1 swap / ; : swing t 0.8 * 2 * pi * dup >r 2 * cos 2 / r> pi 4 / + sin 2 / ; : length swing norm ; : saber x y .5 .5 offset polar swing theta - rect >r dup 0 < if drop r> drop 1000 else dup length <= if drop r> else length - r> norm then then ; saber shine
Darth Vader
FSD
'25 Sep 18
: offset >r swap >r - r> r> - ; : norm dup * swap dup * + sqrt ; : shine 80 * 2 ** 1 + 1 swap / ; : lisa t 2 * pi * dup >r 2 * cos 2 / r> pi 4 / + sin 2 / ; : juice >r x y .5 .5 offset rot r> offset norm shine ; lisa juice
Lisa Juice
FSD
'25 Sep 18
: 3dup >r 2dup r@ -rot r> ; : offset >r swap >r + r> r> + ; : between >r swap dup >r <= r> r> < and ; : hor >r .01 .09 between r> -.01 .01 between and ; : ver >r -.01 .01 between r> .01 .09 between and ; : off over <> r> and >r ; : sega >r 0 -.2 offset hor r> 1 >r 1 off 4 off drop r> and ; : segb >r -.1 -.1 offset ver r> 1 >r 5 off 6 off drop r> and ; : segc >r -.1 0 offset ver r> 1 >r 2 off drop r> and ; : segd >r hor r> 1 >r 1 off 4 off 7 off 9 off drop r> and ; : sege >r ver r> 1 >r 1 off 3 off 4 off 5 off 7 off 9 off drop r> and ; : segf >r 0 -.1 offset ver r> 1 >r 1 off 2 off 3 off 7 off drop r> and ; : segg >r 0 -.1 offset hor r> 1 >r 0 off 1 off 7 off drop r> and ; : digit 3dup sega >r 3dup segb r> or >r 3dup segc r> or >r 3dup segd r> or >r 3dup sege r> or >r 3dup segf r> or >r segg r> or ; : 2digit 3dup >r >r >r 10 / floor digit r> .14 - r> r> 10 mod floor digit or ; : sec t 60 mod floor ; : r x .5 - 2 ** y .5 - 2 ** + .5 ** ; r .3 < x .36 - y .4 - sec 2digit
timer
陳爽
'25 Sep 18
\ n-edge-graph : edge-graph ( X Y R N -- red_circle n_green_edge ) over >r rot y swap - >r ( X R N | R y-Y ) rot x swap - >r swap ( N R | R y-Y x-X ) pi 2 / dup >r ( N R α | R y-Y x-X α ) sin * ( N R*sin[α] | R y-Y x-X α ) r> rot ( R*sin[α] α N | R y-Y x-X ) pi swap / ( R*sin[α] α h | R y-Y x-X ) dup dup + ( R*sin[α] α h a | R y-Y x-X ) r> r@ ( R*sin[α] α h a x-X y-Y | R y-Y ) over >r ( R*sin[α] α h a x-X y-Y | R y-Y x-X ) atan2 ( R*sin[α] α h a θ | R y-Y x-X ) swap mod ( R*sin[α] α h mod(θ,a) | R y-Y x-X ) swap - ( R*sin[α] α mod(θ,a)-h | R y-Y x-X ) abs ( R*sin[α] α β | R y-Y x-X ) over cos over sin * ( R*sin[α] α β cos[α]*sin[β] | R y-Y x-X ) -rot ( R*sin[α] cos[α]*sin[β] α β | R y-Y x-X ) cos swap sin * + ( R*sin[α] cos[α]*sin[β]+cos[β]*sin[α] | R y-Y x-X ) / ( K | R y-Y x-X ) r> 2 ** r> 2 ** + sqrt ( K r | R ) dup r> .93 * < -rot - ( r<R*.95 K-r | ) abs 1 swap - 199 ** ( r<R*.95 {1-abs[K-r]}**199 | ) ; : n t 10 mod floor 4 + ; \ 3 < n < 14 .3 .35 .25 n edge-graph .5 .65 .25 n edge-graph .7 .35 .25 n edge-graph z+ z+
n-edge-graph Redux
陳爽
'25 Sep 18
\ n-edge-graph : edge-graph ( X Y R N -- red_circle n_green_edge ) rot y swap - >r ( X R N | y-Y ) rot x swap - >r swap ( N R | y-Y x-X ) pi 2 / dup >r ( N R α | y-Y x-X α ) sin * ( N R*sin[α] | y-Y x-X α ) r> rot ( R*sin[α] α N | y-Y x-X ) pi swap / ( R*sin[α] α h | y-Y x-X ) dup dup + ( R*sin[α] α h a | y-Y x-X ) r> r@ ( R*sin[α] α h a x-X y-Y | y-Y ) over >r ( R*sin[α] α h a x-X y-Y | y-Y x-X ) atan2 ( R*sin[α] α h a θ | y-Y x-X ) swap mod ( R*sin[α] α h mod(θ,a) | y-Y x-X ) swap - ( R*sin[α] α mod(θ,a)-h | y-Y x-X ) abs ( R*sin[α] α β | y-Y x-X ) over cos over sin * ( R*sin[α] α β cos[α]*sin[β] | y-Y x-X ) -rot ( R*sin[α] cos[α]*sin[β] α β | y-Y x-X ) cos swap sin * + ( R*sin[α] cos[α]*sin[β]+cos[β]*sin[α] | y-Y x-X ) / ( R*sin[α]/{cos[α]*sin[β]+cos[β]*sin[α]} | y-Y x-X ) r> 2 ** r> 2 ** + sqrt dup .23 < -rot - abs 1 swap - 199 ** ; : n t 10 mod floor 4 + ; .3 .35 .25 n edge-graph .5 .65 .25 n edge-graph .7 .35 .25 n edge-graph z+ z+
n-edge-graph
陳爽
'25 Sep 18
: n t 7 mod floor 3 + ; : 2pi/n 2 pi * n / ; : pi/n pi n / ; : spoke 2pi/n mod pi/n - abs ; : r ( x y -- r ) 2 ** swap 2 ** + .5 ** ; : a ( x y -- a ) swap atan2 ; : polar 2dup r -rot a ; : wedge dup cos 1.376 n 5 / 2 ** * \ adjust * swap sin - * .268 <= ; : gram spoke wedge ; : x x .5 - ; : y y .5 - ; x y polar ( r a ) over .4 < ( r a circle ) >r over .3 > ( r a hole ) >r pi 2 / - gram r> r>
Zap Redux
陳爽
'25 Sep 18
: 3dup >r 2dup r@ -rot r> ; : offset >r swap >r + r> r> + ; : between >r swap dup >r <= r> r> < and ; : hor >r .01 .09 between r> -.01 .01 between and ; : ver >r -.01 .01 between r> .01 .09 between and ; : off over <> r> and >r ; : sega >r 0 -.2 offset hor r> 1 >r 1 off 4 off drop r> and ; : segb >r -.1 -.1 offset ver r> 1 >r 5 off 6 off drop r> and ; : segc >r -.1 0 offset ver r> 1 >r 2 off drop r> and ; : segd >r hor r> 1 >r 1 off 4 off 7 off 9 off drop r> and ; : sege >r ver r> 1 >r 1 off 3 off 4 off 5 off 7 off 9 off drop r> and ; : segf >r 0 -.1 offset ver r> 1 >r 1 off 2 off 3 off 7 off drop r> and ; : segg >r 0 -.1 offset hor r> 1 >r 0 off 1 off 7 off drop r> and ; : digit 3dup sega >r 3dup segb r> or >r 3dup segc r> or >r 3dup segd r> or >r 3dup sege r> or >r 3dup segf r> or >r segg r> or ; : 2digit 3dup >r >r >r 10 / floor digit r> .14 - r> r> 10 mod floor digit or ; x .36 - y .4 - 24 2digit dup 0
24
FSD
'25 Sep 18
: d push x - dup * pop y - dup * + sqrt ; : r 2dup push push d 200 * x pop - y pop - atan2 20 * sin 3 * + sin ; : and + abs 2 mod ; .5 .5 r t 10 / dup push sin abs pop cos abs r xor dup dup
Moiré pattern generator #2 Redux
Anonymous
'25 Sep 18
: sq dup * ; : d sq swap sq + sqrt ; : s push - swap pop - 4dup d push atan2 0.01 * pop + 300 * sin ; .8 .4 x y s t sin abs t cos abs x y s + dup dup
Untitled Redux Redux Redux Redux
Anonymous
'25 Sep 18
: sq dup * ; : d sq swap sq + sqrt ; : s push - swap pop - 2dup d push atan2 0.01 * pop + 300 * sin * .5 ; .5 .5 x y s t sin abs t cos abs x y s + dup dup
Untitled Redux Redux Redux
Anonymous
'25 Sep 18
: sq dup * ; : d sq swap sq + sqrt ; : s push - swap pop - 2dup d push atan2 0.01 * pop + 300 * sin * cos / 4 ; .5 .5 x y s t sin abs t cos abs x y s + dup dup
Untitled Redux Redux
Anonymous
'25 Sep 18
: sq dup * ; : d sq swap sq + sqrt ; : s push - swap pop - 2dup d push atan2 0.01 * pop + 300 * sin * cos * 4 ; .5 .5 x y s t sin abs t cos abs x y s + dup dup
Untitled Redux
Anonymous
'25 Sep 18
: sq dup * ; : d sq swap sq + sqrt ; : s push - swap pop - 2dup d push atan2 0.01 * pop + 300 * sin ; .5 .5 x y s t sin abs t cos abs x y s + dup dup
Untitled
Anonymous
'25 Sep 18
: nip swap drop ; : sq dup * ; : offset >r swap >r + r> r> + ; : norm >r sq r> sq + sqrt ; : theta dup 0 >= if swap atan2 else >r negate r> negate swap atan2 pi + then ; : polar 2dup >r >r norm r> r> theta ; : spoke pi .4 * mod pi .2 * - abs ; : wedge dup >r cos 1.376 * r> sin - * .265 <= ; : gram spoke wedge ; x y -.5 -.5 offset polar pi 2 / - gram 0 0
Zap
Duke of New York
'25 Sep 18
y 16 * ceil x * floor 16 /
Interpolator
Manwe
'25 Sep 18
\ 圍棋 1 19 / 0 ! \ delta 0 @ 2 / 1 ! \ half delta 0 2 ! \ start t 3 @ not * 3 @ + 3 ! : 格線 2 @ - 0 @ mod 1 @ - abs .004 < ; : 格盤 ( 亮度 -- 盤 ) x 格線 y 格線 + * ; : 棋盤 0 @ 1 @ .2 格盤 1 @ 2 ! 0 @ 6 * 0 ! 0 @ 2 / 1 ! .1 格盤 + 2 @ -5 * 2 ! 0 @ 3 * 0 ! .3 格盤 + -rot 1 ! 0 ! ; 棋盤 : steps ( ns -- ) 2 + 6 ! t 3 @ - floor 4 ! 0 5 ! 0 ; : , ( p ix iy -- p' ) 0 @ * 1 @ - negate y + \ 任意點到落子位置的縱向距離 dup * swap 0 @ * 1 @ - negate x + \ 任意點到落子位置的橫向距離 dup * + sqrt \ 任意點到落子位置的距離 5 @ 2 mod \ 檢視 步數 是否 奇數 if .022 < \ 奇數步 取 白子 距離小於 .022 的圓 else dup .018 > swap .024 < * \ 偶數步 取 黑子 距離等於 .021 的圈 .006 線徑 then 4 @ 5 @ > * + \ 棋子下到棋盤 5 @ 1 + 5 ! \ 步數遞增 ; : 星位小飛 6 steps 16 16 , 17 14 , 14 16 , 18 16 , 17 17 , 17 11 , ; \ 星位小飛 ( 和平互圍 ) : 星位二間高夾 8 steps 16 04 , 14 03 , 11 04 , 14 05 , 17 06 , 16 02 , 17 03 , 11 02 , ; \ 星位二間高夾 ( 戰鬥夾攻 ) : 星位三三 13 steps 04 04 , 03 03 , 04 03 , 03 04 , 03 05 , 02 05 , 03 06 , 02 06 , 03 07 , 04 02 , 05 02 , 03 02 , 06 03 , ; \ 星位三三 ( 地勢兩分 ) : 星位混合互用 12 steps 04 16 , 06 17 , 08 17 , 03 17 , 04 17 , 03 16 , 04 15 , 04 18 , 05 18 , 03 18 , 05 17 , 03 14 , ; \ 星位混合互用 : cases_begin 9 ! 0 7 ! ; : case 8 @ 7 @ = * + 7 @ 1 + 7 ! ; : cases_end 4 @ 6 @ >= if 8 @ 1 + 9 @ mod 8 ! t 3 ! then ; 2 cases_begin 星位二間高夾 case 星位小飛 case cases_end
圍棋2
陳爽
'25 Sep 18
\ 圍棋 : n 19 ; \ n*n board : d 0 @ ; : d! 0 ! ; 1 n / d! \ delta : h 1 @ ; : h! 1 ! ; d 2 / h! \ half delta : s 2 @ ; : s! 2 ! ; 0 s! \ start : 格線 s - d mod h - abs .004 < ; : 格盤 ( 亮度 -- 盤 ) x 格線 y 格線 + * ; : 棋盤 d >r h >r .2 格盤 h s! d 6 * d! d 2 / h! .1 格盤 + s -5 * s! d 3 * d! .3 格盤 + r> h! r> d! ; 棋盤 : t0 3 @ ; : t0! 3 ! ; t t0 not * t0 + t0! \ t0 0 = if t t0! then : it 4 @ ; : it! 4 ! ; : is 5 @ ; : is! 5 ! ; : ns 6 @ ; : ns! 6 ! ; : ir 7 @ ; : ir! 7 ! ; : ic 8 @ ; : ic! 8 ! ; : nc 9 @ ; : nc! 9 ! ; : r ( ix iy -- r ) d * h - negate y + dup * swap d * h - negate x + dup * + sqrt ; : 之間 ( n a b -- a<=n<b ) >r over r> < >r >= r> and ; : 白子 r .022 < ; : 黑子 r .017 .025 之間 ; : steps ( ns -- ) 2 + ns! t t0 - floor it! 0 is! 0 ; : step ( p p' -- p" ) is it < * + is 1 + is! ; : 星位小飛 6 steps 16 16 黑子 step 17 14 白子 step 14 16 黑子 step 18 16 白子 step 17 17 黑子 step 17 11 白子 step ; \ 星位小飛 ( 和平互圍 ) : 星位二間高夾 8 steps 16 4 黑子 step 14 3 白子 step 11 4 黑子 step 14 5 白子 step 17 6 黑子 step 16 2 白子 step 17 3 黑子 step 11 2 白子 step ; \ 星位二間高夾 ( 戰鬥夾攻 ) : 星位三三 13 steps 4 4 黑子 step 3 3 白子 step 4 3 黑子 step 3 4 白子 step 3 5 黑子 step 2 5 白子 step 3 6 黑子 step 2 6 白子 step 3 7 黑子 step 4 2 白子 step 5 2 黑子 step 3 2 白子 step 6 3 黑子 step ; \ 星位三三 ( 地勢兩分 ) : 星位混合互用 12 steps 4 16 黑子 step 6 17 白子 step 8 17 黑子 step 3 17 白子 step 4 17 黑子 step 3 16 白子 step 4 15 黑子 step 4 18 白子 step 5 18 黑子 step 3 18 白子 step 5 17 黑子 step 3 14 白子 step ; \ 星位混合互用 : cases_begin nc! 0 ir! ; : case ic ir = * + ir 1 + ir! ; : cases_end it ns >= if ic 1 + nc mod ic! t t0! then ; 2 cases_begin 星位二間高夾 case 星位三三 case cases_end
圍棋
陳爽
'25 Sep 18
: ns 1.9 * .45 - 13 * ; : between? >r swap dup >r <= r> r> < and ; : canton? over .4 < over ns 6 13 between? and ; : union drop drop 0 .157 0.4 ; : stripes swap drop ns 2 mod 1 < if .75 .04 .188 else 1 1 1 then ; : flag canton? if union else stripes then ; : sky drop drop 0 .75 1 ; : frame dup .237 .763 between? if flag else sky then ; : wavy over t 2 / + 1 mod 4 * pi * cos .01 * + ; : zzz random dup dup ; t 7 mod 3 < if x y wavy frame else zzz then
Broadcast Day 2
FSD
'25 Sep 18
: no drop drop drop ; : ns y 0.237 - 1.9 * 13 * ; : h 0 ns <= ns 13 < and ; : s h if ns 2 mod 1 < if no .75 .04 .188 else no 1 1 1 then then ; : u 6 ns <= ns 13 < and x .4 < and if no 0 .157 0.4 then ; : f 0 .75 1 s u ; : zz random dup dup ; t 7 mod 2 < if f else zz then
Broadcast Day
FSD
'25 Sep 18
: norm dup * >r dup * r> + ; : r x 0.5 - y 0.5 - norm ; : wave pi * 2 * cos ; : wiggle over swap / wave 0.5 * + ; : c1 r 4 * t 3 wiggle - 1 mod wave ; : c2 r 2 * t 5 wiggle - 1 mod wave ; : c3 r 1 * t 7 wiggle - 1 mod wave ; c1 c2 c3
Supernova
FSD
'25 Sep 18
: x' x .45 - ; : y' y .5 - ; : 2pi 2 pi * ; : atan2 atan2 2pi / 1 mod ; : sin 2pi * sin ; : cos 2pi * cos ; : a' y' x' atan2 ; : r' x' 2 ** y' 2 ** + .5 ** ; : contour ( f y -- contour ) - abs 1 swap - 99 ** ; a' .4 * r' contour x' cos 3 / y' contour 0 y' contour y' abs +
雲遊山水
陳爽
'25 Sep 18
\ n by n frames \ memory 5 saves the index of working frame 0 5 ! : i 5 @ dup 1 + 5 ! ; : n 4 ; \ n by n frames are shown : /mod ( i n -- ir iq ) 2dup / floor push mod floor pop ; \ paste pic at next frame on pic0 as pic1 : | ( pic0 pic -- pic1 ) i n /mod n 1 - swap - y n * floor = swap ( pic0 pic iq=iy ir ) x n * floor = and ( pic0 pic iq=iy&ir=ix ) * + ; : x x n * 1 mod ; : y y n * 1 mod ; 0 : x' x .5 - ; : y' y .5 - ; x .5 < | x .3 > | y .3 < | y .8 > | x y + 1. < | x y - .0 < | x y + 1. > | x y - .0 > | x y * .1 < | x y / 1.5 < | x' abs | x' abs .1 < | y' abs | y' abs .3 > | x' y' * .04 > | x' y' / .6 < |
n by n frames 2
陳爽
'25 Sep 18
\ memory 5 saves the index of working frame 0 5 ! : i 5 @ dup 1 + 5 ! ; : n 4 ; \ n by n frames are shown : /mod ( i n -- ir iq ) 2dup / floor push mod floor pop ; \ paste pic at next frame on pic0 as pic1 : | ( pic0 pic -- pic1 ) i n /mod n 1 - swap - y n * floor = swap ( pic0 pic iq=iy ir ) x n * floor = and ( pic0 pic iq=iy&ir=ix ) * + ; : x x n * 1 mod ; : y y n * 1 mod ; 0 : x' x .5 - ; : y' y .5 - ; 0 | 1 | .8 | pi 10 / | x | y | x y + | x y - | x y * | x y / | x' | y' | x' y' + | x' y' - | x' y' * | x' y' / |
n by n frames
陳爽
'25 Sep 18
\ 雙羅盤 --------------------------------------------------- : 原點! ( X Y -- ) 1 ! 0 ! ; : 原點 ( -- X Y ) 0 @ 1 @ ; : 橫標! ( -- X ) 0 ! ; : 橫標 ( -- X ) 0 @ ; : 縱標! ( -- Y ) 1 ! ; : 縱標 ( -- Y ) 1 @ ; : 軸向! ( A -- ) 2 ! ; : 軸向 ( -- A ) 2 @ ; : 半徑! ( R -- ) 3 ! ; : 半徑 ( -- R ) 3 @ ; 1 半徑! : 暈度! ( H -- ) 4 ! ; : 暈度 ( -- H ) 4 @ ; 150 暈度! : 2pi 5 @ ; 2 pi * 5 ! : atan2 atan2 2pi / 1 mod ; : cos 2pi * cos ; : sin 2pi * sin ; : x x 0 @ - ; : y y 1 @ - ; : r ( -- r ) y 2 ** x 2 ** + .5 ** ; : a ( -- a ) y x atan2 2 @ - 1 mod ; : x ( -- x ) r a cos * ; : y ( -- y ) r a sin * ; : 線半徑 .01 ; : 線 x abs 線半徑 < ; : 暈度 39 ; : 暈 x abs 1 swap - 暈度 ** ; : 絕對值 ( n -- n的絕對值 ) abs ; : 取大 ( n1 n2 -- n ) max ; : 取小 ( n1 n2 -- n ) min ; : 對調 ( n1 n2 -- n2 n1 ) swap ; : 入疊 ( n -- ) >r ; : 出疊 ( -- n ) r> ; : 疊頂 ( -- n ) r@ ; : 複製 ( n -- n n ) dup ; : 負值 ( n -- -n ) negate ; : 反圖 ( 圖 -- 反圖 ) 1 取小 0 取大 1 對調 - ; : 等高線 ( f y -- 線 ) - 絕對值 反圖 暈度 ** ; : 橫線 ( Y -- 線 ) y 等高線 ; : 垂線 ( X -- 線 ) x 等高線 ; : 圈 ( R -- 圈 ) r 等高線 ; : 圓 ( R -- 圓 ) r > ; : 兩點線 ( X1 Y1 X2 Y2 -- 線段 ) 入疊 入疊 ( X1 Y1 ) 原點! 出疊 橫標 - 出疊 縱標 - ( X2-X1 Y2-Y1 ) \ over 2 ** over 2 ** + sqrt 半徑! 對調 atan2 軸向! 0 橫線 ; : 羅盤 ( X Y R -- ) 半徑! 原點! t 60 / 負值 軸向! 0 垂線 0 橫線 + 半徑 1.2 * 圓 * 半徑 圈 + t 10 / 軸向! 半徑 .55 * 入疊 疊頂 橫線 x 疊頂 > * 疊頂 垂線 y 出疊 > * 軸向 .125 + 軸向! 0 橫線 x 0 > * + + r 反圖 2 ** * 半徑 * + 半徑 圓 .1 * + ; : p1 .30 .35 ; : p2 .60 .50 ; \ 羅盤中心點 分別在 P1 與 P2 p1 .2 羅盤 半徑 .8 * 圓 複製 入疊 .1 * + \ 紅 p2 .3 羅盤 半徑 .8 * 圓 複製 入疊 .1 * + \ 綠 p1 p2 兩點線 出疊 出疊 + .5 * + \ 藍 0 0 原點! x y + * \ 透
rollingCompass3
陳爽
'25 Sep 18
\ range changed from [0,2pi] to [0,1] for the angle : 2pi 2 pi * ; : cos 2pi * cos ; : sin 2pi * sin ; : atan2 atan2 2pi / 1 mod ; \ memory used : xo 0 @ ; : xo! 0 ! ; .500 xo! : yo 1 @ ; : yo! 1 ! ; .500 yo! : ao 2 @ ; : ao! 2 ! ; : ro 3 @ ; : ro! 3 ! ; .500 ro! : strength 4 @ ; 0299 4 ! \ the distance from xo,yo to x,y : r' ( -- radius ) x 0 @ - 2 ** y 1 @ - 2 ** + .5 ** ; \ the angle from xo,yo to x,y : a' ( -- angle ) y 1 @ - x 0 @ - atan2 2 @ - 1 mod ; \ relative x',y' at origin xo,yo rotating ao : x' r' a' cos * ; : y' r' a' sin * ; : circle ( Xc Yc -- circle ) x' rot - dup * y' rot - dup * + sqrt ro < ; : 反 0 max 1 min 1 swap - ; : contour ( f y -- line ) - abs 反 strength ** ; : axis 0 x' contour y' 0 > * 0 y' contour + 0 0 circle + ; : between ( n a b -- a<n<b ) push over pop < push > pop * ; : point ( X Y -- ) >r dup r@ circle swap \ dup x' contour y' 0 r@ between * swap r> y' contour swap x' 0 rot between * + + ; \ R .50 xo! .50 yo! .10 ao! .02 ro! axis \ G .35 xo! .20 yo! .00 ao! axis \ B .09 xo! a' .1 < r' .1 contour * .35 xo! .350 .600 point + .50 xo! .50 yo! .10 ao! .338 .124 point +
x+xo,y+yo and x',y'
陳爽
'25 Sep 18
: d dup ; : m 1 min ; : f d floor - ; : c cos abs ; : j t 4 + 3 * x 8 * floor 8 / + 4 * c 2 / t 4 + 2 / c 4 ** * - ; : a 1 x x 8 * floor 0.5 + 8 / - d * y ; : b - d * + sqrt 50 * 99 ** ; : p x t 4 + pi / f 1.6 * - 0.2 + ; : v t 4 + pi 2 * / f ; a j 0.5 b - v d 0.5 < * 4 * m * 1 p d * y 0.5 - d * + 36 * 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.2
PACMAN Redux
Anonymous
'25 Sep 18
: 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.05 < pop * ; : p dup rot dup sin swap cos rot * -rot * rot + -rot + swap ; : a t 3 * sin ; : b a 1.1 * ; : m x 10 * + + sin 1 over dup * - sqrt atan2 swap / y 0.6 - > ; 0.5 0.7 -1.57 0.3 l 0.5 0.4 -1.57 a + 0.45 l + 0.5 0.3 -1.57 a + 0.45 p -2 b + 0.2 l + 0.5 0.3 -1.57 a - 0.45 l + 0.5 0.4 -1.57 a - 0.45 p -2 b - 0.2 l + 0.5 0.6 -1.57 a + 0.1 l + 0.5 0.3 -1.57 a + 0.1 p -0.5 b + 0.1 l + 0.5 0.6 -1.57 a - 0.1 l + 0.5 0.6 -1.57 a - 0.1 p -0.5 b - 0.1 l + 0.5 0.7 0.05 c + dup 0 swap 15 1 t 2 / m 20 3 t m + 25 0 t 4 / m 35 4 t 4 / m + + y 0.2 > * +
Man running with landscape Redux 1
lik
'25 Sep 18
\ clock1 \ angle range changed from [0,2pi] to [0,1] : 2pi 2 pi * ; : cos 2pi * cos ; : sin 2pi * sin ; : atan2 atan2 2pi / 1 mod ; \ the distance from X,Y to any point x,y : r' ( X Y -- radius ) x rot - 2 ** y rot - 2 ** + .5 ** ; : r .5 .5 r' ; \ the angle from X,Y to any point x,y : a' ( X Y -- angle ) y swap - x rot - atan2 ; : a .5 .5 a' ; \ the angle for n seconds : s ( #seconds -- angle ) t floor swap / ; \ the angle for n minutes : m ( #minutes -- angle ) 60 s swap / ; \ the angle for n hours : h ( #hours -- angle ) 60 m swap / ; \ the virtual needle for given angle : v_needle ( angle -- needle ) a + .25 - 1 mod 1 swap - ; \ the real needle for given angle : r_needle ( angle -- needle ) a + dup 1 mod 0 ! dup cos r * abs 1 swap - 150 ** swap sin r * -.08 > * ; \ the needle for given angle and radius : within ( n a b -- a<n<b ) push over pop < push > pop * ; : n ( angle radius -- needle ) dup 1 ! r .008 rot within swap r_needle * r 0 @ .25 - cos * 1 @ .05 - - 2 ** r 0 @ .25 - sin * 2 ** + sqrt .025 - abs 1 swap - 499 ** + ; \ the n ticks to form a whole ring : t ( #ticks/circle -- ticks ) 2 / a * cos 199 ** r .41 .48 within * ; \ the red needle for the hours and seconds and 4 ticks 12 h .23 n 60 s .37 n + 4 t + \ the green needle for the hours and minutes and 12 ticks and 60 ticks 12 h .23 n 60 m .30 n + 12 t + 60 t + \ the blue 60 ticks and background 60 t r 8 * floor 4 / + \ cut out the clock r .5 <
clock1
陳爽
'25 Sep 18
\ the clock using angle as virtual needles \ range changed from [0,2pi] to [0,1] for the angle : 2pi 2 pi * ; : cos 2pi * cos ; : atan2 atan2 2pi / 1 mod ; \ the origin moved to the square center : x x .5 - ; : y y .5 - ; \ the distance from the origin to any point x,y : r ( -- radius ) x 2 ** y 2 ** + .5 ** ; \ the angle from origin to any point x,y : a ( -- angle ) y x atan2 ; \ the angle for n seconds : s ( #seconds -- angle ) t floor swap / ; \ the angle for n minutes : m ( #minutes -- angle ) 60 s swap / ; \ the angle for n hours : h ( #hours -- angle ) 60 m swap / ; \ the virtual needle for given angle and radius : n ( angle radius -- needle ) r > swap a .25 - + 1 mod * ; \ n ticks to form a whole circle : t ( #ticks/circle -- ticks ) 2 / a * cos 999 ** r .45 > * r .49 < * ; \ the red needle for the seconds with 4 ticks 60 s .4 n 4 t + \ the green needle for the minutes with 12 ticks 60 m .3 n 12 t + \ the blue needle for the hours 12 h .2 n
clock0
陳爽
'25 Sep 18
\ 羅盤 : p1 .30 .35 ; : p2 .60 .50 ; : 2pi 2 pi * ; : atan2 atan2 2pi / 1 mod ; : cos 2pi * cos ; : sin 2pi * sin ; : orig ( X Y -- ) 1 ! 0 ! ; : axis ( A -- ) 2 ! ; : radius ( R -- ) 5 ! ; 1 5 ! : Halo_degree ( H -- ) 7 ! ; 149 7 ! \ : thickness ( T -- ) 2 / 6 ! ; .01 6 ! : ts t 99 / sin .5 * .5 + 1 + ; \ : x x .5 - ts * 1 mod ; \ : y y .5 - ts * 1 mod ; : x x 0 @ - ; : y y 1 @ - ; : r ( -- r ) y 2 ** x 2 ** + .5 ** ; : a ( -- a ) y x atan2 2 @ - 1 mod ; : x ( -- x ) r a cos * ; : y ( -- y ) r a sin * ; ( \ rolling colors .5 .5 orig ts axis x .0 > y .0 > r .4 < a 4 * .5 + 1 mod .2 ** \ ) \ rolling colors : 原點 ( X Y -- ) orig ; : 軸向 ( A -- ) axis ; : 半徑 ( R -- ) radius ; \ : 線徑 ( T -- ) thickness ; : 暈度 ( H -- ) Halo_degree ; : 絕對值 ( n -- n的絕對值 ) abs ; : 反圖 ( 圖 -- 反圖 ) 1 min 0 max 1 swap - ; \ : 等值線 ( f y -- 線 ) - 絕對值 6 @ < ; : 等值暈 ( f y -- 線 ) - 絕對值 反圖 7 @ ** ; : 橫線 ( Y -- 線 ) y 等值暈 ; : 垂線 ( X -- 線 ) x 等值暈 ; : 圈 ( R -- 圈 ) r 等值暈 ; : 圓 ( R -- 圓 ) r > ; : 向線 ( R -- 向線 ) .02 橫線 x 0 > * * ; : 垂向線 ( R -- 向線 ) .02 垂線 y 0 > * * ; : 兩點線 ( X1 Y1 X2 Y2 -- 線段 ) >r >r ( X1 Y1 ) 原點 r> 0 @ - r> 1 @ - ( X2-X1 Y2-Y1 ) \ over 2 ** over 2 ** + sqrt 半徑 swap atan2 軸向 0 橫線 ; : 羅盤 ( X Y R -- ) 半徑 原點 t 60 / negate 軸向 0 垂線 0 橫線 + 5 @ 1.2 * 圓 * t 10 / 軸向 5 @ 向線 + 5 @ 垂向線 + 5 @ 圈 + 5 @ 圓 .1 * + ; p1 .2 羅盤 5 @ .8 * 圓 dup >r .1 * + \ 紅 p2 .3 羅盤 5 @ .8 * 圓 dup >r .1 * + \ 綠 p1 p2 兩點線 r> r> + .3 * + \ 藍 0 0 原點 x y + * \ 透
rolling compass 2
陳爽
'25 Sep 18
\ compass : 2pi 2 pi * ; : atan2 atan2 2pi / 1 mod ; : cos 2pi * cos ; : sin 2pi * sin ; : orig ( X Y -- ) 1 ! 0 ! ; : axis ( A -- ) 2 ! ; : wscale ( WS -- ) 3 ! ; 1 3 ! : hscale ( HS -- ) 4 ! ; 1 4 ! : radius ( R -- ) 5 ! ; 1 5 ! : thickness ( T -- ) 2 / 6 ! ; .01 6 ! : Halo_degree ( H -- ) 7 ! ; 149 7 ! : t9 t 99 / sin .5 * .5 + 1 + ; \ : x x .5 - t9 * 1 mod ; \ : y y .5 - t9 * 1 mod ; : x x 0 @ - 3 @ / ; : y y 1 @ - 4 @ / ; : r ( -- r ) y 2 ** x 2 ** + .5 ** ; : a ( -- a ) y x atan2 2 @ - 1 mod ; : x ( -- x ) r a cos * ; : y ( -- y ) r a sin * ; ( \ rolling colors .5 .5 orig ts axis x .0 > y .0 > r .4 < a 4 * .5 + 1 mod .2 ** \ ) \ rolling colors : 原點 ( X Y -- ) orig ; : 軸向 ( A -- ) axis ; : 半徑 ( R -- ) radius ; : 橫向放大 ( WS -- ) wscale ; : 縱向放大 ( HS -- ) hscale ; : 線徑 ( T -- ) thickness ; : 暈度 ( H -- ) Halo_degree ; : 絕對值 ( n -- n的絕對值 ) abs ; : 反圖 ( 圖 -- 反圖 ) 1 min 0 max 1 swap - ; : 等值線 ( f y -- 線 ) - 絕對值 6 @ < ; : 等值暈 ( f y -- 線 ) - 絕對值 反圖 7 @ ** ; : 橫線 ( Y -- 線 ) y 等值暈 ; : 垂線 ( X -- 線 ) x 等值暈 ; : 圈 ( R -- 圈 ) r 等值暈 ; : 點 0 圈 ; : 圓 ( R -- 圓 ) r > ; : 線 0 橫線 ; : 向線 ( R -- 向線 ) 圓 0 橫線 x 0 > * * ; : 垂向線 ( R -- 向線 ) 圓 0 垂線 y 0 > * * ; : 兩點線 ( X1 Y1 X2 Y2 -- 線段 ) >r >r ( X1 Y1 ) 原點 r> 0 @ - r> 1 @ - ( X2-X1 Y2-Y1 ) swap atan2 軸向 線 ; : t1 t 10 / ; : t6 t 60 / negate ; .4 .4 原點 t6 軸向 .00 垂線 線 + t1 軸向 .20 向線 + .20 垂向線 + .2 圈 + .2 圓 dup >r .1 * + .2 1.2 * 圓 * .6 .6 原點 t6 軸向 .00 垂線 線 + t1 軸向 .30 向線 + .30 垂向線 + .3 圈 + .3 1.2 * 圓 * .3 圓 dup >r .1 * + r> r> + .3 * .4 .4 .6 .6 兩點線 + 0 0 原點 x y + * r .2 ** \ ) \ compass
rolling compass
陳爽
'25 Sep 18
: 2pi 2 pi * ; : atan2 atan2 2pi / 1 mod ; : cos 2pi * cos ; : sin 2pi * sin ; : orig ( X Y -- ) 1 ! 0 ! ; : axis ( A -- ) 2 ! ; : wscale ( WS -- ) 3 ! ; 1 3 ! : hscale ( HS -- ) 4 ! ; 1 4 ! : ts t 99 / sin .5 * .5 + 2 * 1 + ; : x x .5 - ts * 1 mod ; : y y .5 - ts * 1 mod ; : x x 0 @ - 3 @ * ; : y y 1 @ - 4 @ * ; : r ( -- r ) y 2 ** x 2 ** + .5 ** ; : a ( -- a ) y x atan2 2 @ - 1 mod ; : x ( -- x ) r a cos * ; : y ( -- y ) r a sin * ; \ ( \ rolling colors .5 .5 orig ts axis x .0 > y .0 > r .4 < a 4 * .5 + 1 mod .2 ** \ ) \ rolling colors
rolling colors
陳爽
'25 Sep 18
: c t 0.01398413 + sin t -0.9132423 + sin ; : iterate 2dup z* c z+ ; : norm dup * swap dup * + ; : j 2dup >r >r norm 4 > + r> r> iterate ; : scale 0.5 - 2 pi * * 0.5 * ; : sclxy scale swap scale swap ; : julia 0 x y sclxy j j j j j j j j j j j j j j j j j j j j drop drop ; julia 16 / dup dup
Julia grayscale v.1 Redux
Anonymous
'25 Sep 18
\ ( \ moving lines : 2pi 2 pi * ; : atan2 atan2 2pi / 1 mod ; : cos 2pi * cos ; : sin 2pi * sin ; \ 設定 直角座標 原點 X,Y 橫軸角度 A 寬高縮放比例 WS HS : orig ( X Y -- ) 1 ! 0 ! ; : axis ( A -- ) 2 ! ; : wscale ( WS -- ) 3 ! ; 1 3 ! : hscale ( HS -- ) 4 ! ; 1 4 ! \ 極座標 徑度 r 角度 a : ts t 60 / sin .5 * 1.5 + 2 * ; : x x ts * 1 mod ; : y y ts * 1 mod ; : x x 0 @ - 3 @ * ; : y y 1 @ - 4 @ * ; : r ( -- r ) y 2 ** x 2 ** + .5 ** ; : a ( -- a ) y x atan2 2 @ - 1 mod ; : x ( -- x ) r a cos * ; : y ( -- y ) r a sin * ; ( \ 測試 r a x y .3 .3 orig .1 axis x .0 > y .0 > r .2 < a .5 ** \ ) : 線徑 .03 ; : 線 ( -- 線 ) y abs 線徑 2 / < ; : 向線 ( -- 向線 ) 線 x 0 > and ; : 線' ( -- h ) y abs 1 swap - 69 ** ; : 向線' ( -- h ) 線' x 0 > * ; \ ( 測試 橫線 向線 橫線' 向線' .4 .4 orig .15 t 10 / + axis 向線 r .4 < * .40 t 60 / - axis 線 + .6 .6 orig .40 t 10 / + axis 向線' r .4 < * .15 t 60 / - axis 線' + 0 1 r - .6 ** \ ) \ ) \ moving lines
moving lines
陳爽
'25 Sep 18
: b t * cos 2 / .6 + y - dup abs .1 < * 24 * cos ; 1 b .4 b .8 b
Untitled
Anonymous
'25 Sep 18
x y t sin t 2 * cos z* 2dup > if x rot else y -rot then
Untitled
Anonymous
'25 Sep 18
Next