diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index d229b19a0e..5e1700c6e2 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -48,5 +48,4 @@ DEFER: bake : bake-items ( seq -- ) [ bake-item ] each ; : bake ( seq -- seq ) - [ reset-building save-exemplar bake-items finish-baking ] with-scope ; - + [ reset-building save-exemplar bake-items finish-baking ] with-scope ; \ No newline at end of file diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 5099a5e0a7..0ad7c5e26d 100644 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -19,8 +19,8 @@ math.functions math.parser io.files colors.hsv ; : ( nb-cols -- map ) dup [ - 360 * swap 1+ / 360 / sat val - hsv>rgb scale-rgb + 360 * swap 1+ / sat val + 3array hsv>rgb first3 scale-rgb ] curry* map ; : iter ( c z nb-iter -- x ) diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index cbb7417640..f007e9f757 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -2,36 +2,43 @@ USING: kernel alien.c-types combinators namespaces arrays sequences sequences.lib namespaces.lib splitting math math.functions math.vectors math.trig - opengl.gl opengl.glu ui ui.gadgets.slate vars mortar slot-accessors - random-weighted cfdg.hsv cfdg.gl ; + opengl.gl opengl.glu opengl ui ui.gadgets.slate + combinators.lib vars + random-weighted colors.hsv cfdg.gl ; IN: cfdg ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: +! hsba { hue saturation brightness alpha } - - { "hue" "saturation" "brightness" "alpha" } accessors -define-independent-class - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: hsv>rgb* ( h s v -- r g b ) 3array hsv>rgb first3 ; - -: gl-set-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glColor4d ; - -: gl-clear-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glClearColor ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 4array ; VAR: color -: init-color ( -- ) 0 0 0 1 new >color ; +! ( -- val ) -: hue ( num -- ) color> tuck $hue + 360 mod >>hue drop ; +: hue>> 0 color> nth ; +: saturation>> 1 color> nth ; +: brightness>> 2 color> nth ; +: alpha>> 3 color> nth ; -: h ( num -- ) hue ; +! ( val -- ) + +: >>hue 0 color> set-nth ; +: >>saturation 1 color> set-nth ; +: >>brightness 2 color> set-nth ; +: >>alpha 3 color> set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ; + +: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ; + +: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! if (adjustment < 0) ! base + base * adjustment @@ -41,17 +48,20 @@ VAR: color : adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ; -: saturation ( num -- ) color> dup $saturation rot adjust >>saturation drop ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: sat ( num -- ) saturation ; +: hue ( num -- ) hue>> + 360 mod >>hue ; -: brightness ( num -- ) color> dup $brightness rot adjust >>brightness drop ; +: saturation ( num -- ) saturation>> swap adjust >>saturation ; +: brightness ( num -- ) brightness>> swap adjust >>brightness ; +: alpha ( num -- ) alpha>> swap adjust >>alpha ; -: b ( num -- ) brightness ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: alpha ( num -- ) color> dup $alpha rot adjust >>alpha drop ; - -: a ( num -- ) alpha ; +: h hue ; +: sat saturation ; +: b brightness ; +: a alpha ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -59,38 +69,19 @@ VAR: color-stack : init-color-stack ( -- ) V{ } clone >color-stack ; -: clone-color ( hsba -- hsba ) object-values first4 new ; - -: push-color ( -- ) -color> color-stack> push -color> clone-color >color ; +: push-color ( -- ) color> color-stack> push color> clone >color ; : pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : check-size ( modelview-matrix -- num ) -! { 0 1 4 5 } swap [ double-nth ] curry map -! [ abs ] map -! [ <=> ] maximum ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! : check-size ( modelview-matrix -- num ) -! { 0 1 4 5 } swap [ double-nth ] curry map -! [ abs ] map -! biggest ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ; -: check-size ( modelview-matrix -- num ) - { 0 1 4 5 } double-nth* [ abs ] map biggest ; +: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ; VAR: threshold -: iterate? ( -- ? ) get-modelview-matrix check-size threshold get > ; +: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -101,65 +92,65 @@ VAR: threshold ! column major order -: gl-flip ( angle -- ) deg>rad -{ [ dup 2 * cos ] [ dup 2 * sin ] 0 0 - [ dup 2 * sin ] [ 2 * cos neg ] 0 0 - 0 0 1 0 - 0 0 0 1 } make* >c-double-array glMultMatrixd ; +: gl-flip ( angle -- ) deg>rad dup dup dup + [ 2 * cos , 2 * sin , 0 , 0 , + 2 * sin , 2 * cos neg , 0 , 0 , + 0 , 0 , 1 , 0 , + 0 , 0 , 0 , 1 , ] + { } make >c-double-array glMultMatrixd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : circle ( -- ) -color> gl-set-hsba -gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ; + color> gl-set-hsba + gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ; : triangle ( -- ) -color> gl-set-hsba -GL_POLYGON glBegin - 0 0.577 glVertex2d - 0.5 -0.289 glVertex2d - -0.5 -0.289 glVertex2d -glEnd ; + color> gl-set-hsba + GL_POLYGON glBegin + 0 0.577 glVertex2d + 0.5 -0.289 glVertex2d + -0.5 -0.289 glVertex2d + glEnd ; : square ( -- ) -color> gl-set-hsba -GL_POLYGON glBegin - -0.5 0.5 glVertex2d - 0.5 0.5 glVertex2d - 0.5 -0.5 glVertex2d - -0.5 -0.5 glVertex2d -glEnd ; + color> gl-set-hsba + GL_POLYGON glBegin + -0.5 0.5 glVertex2d + 0.5 0.5 glVertex2d + 0.5 -0.5 glVertex2d + -0.5 -0.5 glVertex2d + glEnd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : size ( scale -- ) dup 1 glScaled ; -: s ( scale -- ) size ; - : size* ( scale-x scale-y -- ) 1 glScaled ; -: s* ( scale-x scale-y -- ) size* ; - : rotate ( angle -- ) 0 0 1 glRotated ; -: r ( angle -- ) rotate ; - : x ( x -- ) 0 0 glTranslated ; : y ( y -- ) 0 swap 0 glTranslated ; : flip ( angle -- ) gl-flip ; -: f ( angle -- ) flip ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: s size ; +: s* size* ; +: r rotate ; +: f flip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : do ( quot -- ) -push-modelview-matrix -push-color -call -pop-modelview-matrix -pop-color ; + push-modelview-matrix + push-color + call + pop-modelview-matrix + pop-color ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -171,10 +162,10 @@ pop-color ; VAR: background -: initial-background ( -- hsba ) 0 0 1 1 new ; +: set-initial-background ( -- ) { 0 0 1 1 } clone >color ; : set-background ( -- ) - initial-background >color + set-initial-background background> call color> gl-clear-hsba ; @@ -186,23 +177,10 @@ VAR: viewport ! { left width bottom height } VAR: start-shape -: initial-color ( -- hsba ) 0 0 0 1 new ; +: set-initial-color ( -- ) { 0 0 0 1 } clone >color ; : display ( -- ) -! GL_LINE_SMOOTH glEnable -! GL_BLEND glEnable -! GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc -! GL_POINT_SMOOTH_HINT GL_NICEST glHint - -! GL_FOG glEnable -! GL_FOG_MODE GL_LINEAR glFogi -! GL_FOG_COLOR { 0.5 0.5 0.5 1.0 } >c-double-array glFogfv -! GL_FOG_DENSITY 0.35 glFogf -! GL_FOG_HINT GL_DONT_CARE glHint -! GL_FOG_START 1.0 glFogf -! GL_FOG_END 5.0 glFogf - GL_PROJECTION glMatrixMode glLoadIdentity viewport> first dup viewport> second + @@ -218,14 +196,14 @@ VAR: start-shape init-modelview-matrix-stack init-color-stack - initial-color >color + set-initial-color color> gl-set-hsba start-shape> call ; : cfdg-window* ( -- ) -[ display ] closed-quot + [ display ] closed-quot { 500 500 } over set-slate-dim dup "CFDG" open-window ; diff --git a/extra/cfdg/gl/gl.factor b/extra/cfdg/gl/gl.factor index e40576907a..35e7de0bb7 100644 --- a/extra/cfdg/gl/gl.factor +++ b/extra/cfdg/gl/gl.factor @@ -4,14 +4,13 @@ USING: kernel alien.c-types namespaces sequences opengl.gl ; IN: cfdg.gl : get-modelview-matrix ( -- alien ) -GL_MODELVIEW_MATRIX 16 "GLdouble" tuck glGetDoublev ; + GL_MODELVIEW_MATRIX 16 "GLdouble" tuck glGetDoublev ; SYMBOL: modelview-matrix-stack -: init-modelview-matrix-stack ( -- ) -V{ } clone modelview-matrix-stack set ; +: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ; : push-modelview-matrix ( -- ) -get-modelview-matrix modelview-matrix-stack get push ; + get-modelview-matrix modelview-matrix-stack get push ; : pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ; \ No newline at end of file diff --git a/extra/cfdg/hsv/hsv.factor b/extra/cfdg/hsv/hsv.factor deleted file mode 100644 index 3714416d2e..0000000000 --- a/extra/cfdg/hsv/hsv.factor +++ /dev/null @@ -1,39 +0,0 @@ - -USING: kernel combinators arrays sequences math combinators.lib ; - -IN: cfdg.hsv - - - -! h [0,360) -! s [0,1] -! v [0,1] - -: hsv>rgb ( hsv -- rgb ) -dup Hi -{ { 0 [ [ V ] [ t ] [ p ] tri ] } - { 1 [ [ q ] [ V ] [ p ] tri ] } - { 2 [ [ p ] [ V ] [ t ] tri ] } - { 3 [ [ p ] [ q ] [ V ] tri ] } - { 4 [ [ t ] [ p ] [ V ] tri ] } - { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ; diff --git a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor index 08c4308159..a87b3602d9 100644 --- a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor +++ b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor @@ -8,17 +8,21 @@ IN: cfdg.models.chiaroscuro DEFER: white : black ( -- ) iterate? [ -{ { 60 [ [ 0.6 s circle ] do - [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } - { 1 [ white black ] } } -random-weighted* call + { { 60 [ [ 0.6 s circle ] do + [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } + { 1 [ white black ] } } + call-random-weighted ] when ; : white ( -- ) iterate? [ -{ { 60 [ [ 0.6 s circle ] do - [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do ] } - { 1 [ black white ] } } -random-weighted* call + { { 60 [ + [ 0.6 s circle ] do + [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do + ] } + { 1 [ + black white + ] } } + call-random-weighted ] when ; : chiaroscuro ( -- ) [ 0.5 b black ] do ; diff --git a/extra/colors/hsv/hsv.factor b/extra/colors/hsv/hsv.factor index 88c8c2f427..102f45ce8a 100644 --- a/extra/colors/hsv/hsv.factor +++ b/extra/colors/hsv/hsv.factor @@ -1,29 +1,41 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2007 Eduardo Cavazos ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math ; + +USING: kernel combinators arrays sequences math combinators.lib ; + IN: colors.hsv r swap rot >r 2dup r> 6 * r> - ; -: p ( v s x -- v p x ) >r dupd neg 1 + * r> ; -: q ( v s f -- q ) * neg 1 + * ; -: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ; +: H ( hsv -- H ) first ; + +: S ( hsv -- S ) second ; + +: V ( hsv -- V ) third ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: Hi ( hsv -- Hi ) H 60 / floor 6 mod ; + +: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ; + +: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ; + +: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ; + +: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ; PRIVATE> -: mod-cond ( p vector -- ) - #! Call p mod q'th entry of the vector of quotations, where - #! q is the length of the vector. The value q remains on the - #! stack. - [ dupd length mod ] keep nth call ; +! h [0,360) +! s [0,1] +! v [0,1] -: hsv>rgb ( h s v -- r g b ) - pick 6 * >fixnum { - [ f_ t_ p swap ] ! v p t - [ f_ q p -rot ] ! q v p - [ f_ t_ p swapd ] ! p v t - [ f_ q p rot ] ! p q v - [ f_ t_ p swap rot ] ! t p v - [ f_ q p ] ! v p q - } mod-cond ; +: hsv>rgb ( hsv -- rgb ) +dup Hi +{ { 0 [ [ V ] [ t ] [ p ] tri ] } + { 1 [ [ q ] [ V ] [ p ] tri ] } + { 2 [ [ p ] [ V ] [ t ] tri ] } + { 3 [ [ p ] [ q ] [ V ] tri ] } + { 4 [ [ t ] [ p ] [ V ] tri ] } + { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ; diff --git a/extra/random-weighted/random-weighted.factor b/extra/random-weighted/random-weighted.factor index 0ec366beb0..cc050eb4df 100644 --- a/extra/random-weighted/random-weighted.factor +++ b/extra/random-weighted/random-weighted.factor @@ -1,10 +1,10 @@ -USING: kernel quotations sequences math math.vectors random ; +USING: kernel namespaces arrays quotations sequences assocs combinators + mirrors math math.vectors random combinators.lib macros bake ; IN: random-weighted -: probabilities ( weights -- probabilities ) -dup sum [ / ] curry map ; +: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ; : layers ( probabilities -- layers ) dup length 1+ [ head ] curry* map 1 tail [ sum ] map ; @@ -13,4 +13,8 @@ dup length 1+ [ head ] curry* map 1 tail [ sum ] map ; probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ; : random-weighted* ( seq -- elt ) -dup [ second ] map swap [ first ] map random-weighted swap nth ; \ No newline at end of file +dup [ second ] map swap [ first ] map random-weighted swap nth ; + +MACRO: call-random-weighted ( exp -- ) + [ keys ] [ values >alist ] bi swap + [ , random-weighted , case ] bake ; diff --git a/extra/gap-buffer/authors.txt b/unmaintained/gap-buffer/authors.txt similarity index 100% rename from extra/gap-buffer/authors.txt rename to unmaintained/gap-buffer/authors.txt diff --git a/extra/gap-buffer/cursortree/authors.txt b/unmaintained/gap-buffer/cursortree/authors.txt similarity index 100% rename from extra/gap-buffer/cursortree/authors.txt rename to unmaintained/gap-buffer/cursortree/authors.txt diff --git a/extra/gap-buffer/cursortree/cursortree-tests.factor b/unmaintained/gap-buffer/cursortree/cursortree-tests.factor similarity index 100% rename from extra/gap-buffer/cursortree/cursortree-tests.factor rename to unmaintained/gap-buffer/cursortree/cursortree-tests.factor diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/unmaintained/gap-buffer/cursortree/cursortree.factor similarity index 100% rename from extra/gap-buffer/cursortree/cursortree.factor rename to unmaintained/gap-buffer/cursortree/cursortree.factor diff --git a/extra/gap-buffer/cursortree/summary.txt b/unmaintained/gap-buffer/cursortree/summary.txt similarity index 100% rename from extra/gap-buffer/cursortree/summary.txt rename to unmaintained/gap-buffer/cursortree/summary.txt diff --git a/extra/gap-buffer/gap-buffer-tests.factor b/unmaintained/gap-buffer/gap-buffer-tests.factor similarity index 100% rename from extra/gap-buffer/gap-buffer-tests.factor rename to unmaintained/gap-buffer/gap-buffer-tests.factor diff --git a/extra/gap-buffer/gap-buffer.factor b/unmaintained/gap-buffer/gap-buffer.factor similarity index 100% rename from extra/gap-buffer/gap-buffer.factor rename to unmaintained/gap-buffer/gap-buffer.factor diff --git a/extra/gap-buffer/summary.txt b/unmaintained/gap-buffer/summary.txt similarity index 100% rename from extra/gap-buffer/summary.txt rename to unmaintained/gap-buffer/summary.txt diff --git a/extra/gap-buffer/tags.txt b/unmaintained/gap-buffer/tags.txt similarity index 100% rename from extra/gap-buffer/tags.txt rename to unmaintained/gap-buffer/tags.txt diff --git a/extra/trees/authors.txt b/unmaintained/trees/authors.txt similarity index 100% rename from extra/trees/authors.txt rename to unmaintained/trees/authors.txt diff --git a/extra/trees/avl-tree/avl-tree-tests.factor b/unmaintained/trees/avl-tree/avl-tree-tests.factor similarity index 100% rename from extra/trees/avl-tree/avl-tree-tests.factor rename to unmaintained/trees/avl-tree/avl-tree-tests.factor diff --git a/extra/trees/avl-tree/avl-tree.factor b/unmaintained/trees/avl-tree/avl-tree.factor similarity index 100% rename from extra/trees/avl-tree/avl-tree.factor rename to unmaintained/trees/avl-tree/avl-tree.factor diff --git a/extra/trees/bst/bst-tests.factor b/unmaintained/trees/bst/bst-tests.factor similarity index 100% rename from extra/trees/bst/bst-tests.factor rename to unmaintained/trees/bst/bst-tests.factor diff --git a/extra/trees/bst/bst.factor b/unmaintained/trees/bst/bst.factor similarity index 100% rename from extra/trees/bst/bst.factor rename to unmaintained/trees/bst/bst.factor diff --git a/extra/trees/summary.txt b/unmaintained/trees/summary.txt similarity index 100% rename from extra/trees/summary.txt rename to unmaintained/trees/summary.txt diff --git a/extra/trees/tags.txt b/unmaintained/trees/tags.txt similarity index 100% rename from extra/trees/tags.txt rename to unmaintained/trees/tags.txt diff --git a/extra/trees/trees.factor b/unmaintained/trees/trees.factor similarity index 100% rename from extra/trees/trees.factor rename to unmaintained/trees/trees.factor