From 3bbc9835fcf509e3f2e626f46c0e831d06266649 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 12:43:44 -0500 Subject: [PATCH] add a new "make-tuple" combinator for cleaving values into tuple slots by name. make render-set read-only and update gpu demos to use make-tuple --- extra/combinators/tuple/tuple-docs.factor | 43 ++++++++++++++++++++++ extra/combinators/tuple/tuple.factor | 29 +++++++++++++++ extra/gpu/demos/bunny/bunny.factor | 45 +++++++++++------------ extra/gpu/demos/raytrace/raytrace.factor | 19 +++++----- extra/gpu/render/render.factor | 25 +++++++++---- 5 files changed, 119 insertions(+), 42 deletions(-) create mode 100644 extra/combinators/tuple/tuple-docs.factor create mode 100644 extra/combinators/tuple/tuple.factor diff --git a/extra/combinators/tuple/tuple-docs.factor b/extra/combinators/tuple/tuple-docs.factor new file mode 100644 index 0000000000..aedb013129 --- /dev/null +++ b/extra/combinators/tuple/tuple-docs.factor @@ -0,0 +1,43 @@ +! (c)2009 Joe Groff bsd license +USING: assocs classes help.markup help.syntax kernel math +quotations strings ; +IN: combinators.tuple + +HELP: 2make-tuple +{ $values + { "x" object } { "y" object } { "class" class } { "assoc" assoc } + { "tuple" tuple } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ; + +HELP: 3make-tuple +{ $values + { "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } + { "tuple" tuple } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ; + +HELP: make-tuple +{ $values + { "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } + { "tuple" tuple } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ; + +HELP: nmake-tuple +{ $values + { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ; + +{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words + +ARTICLE: "combinators.tuple" "Tuple-constructing combinators" +"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects." +{ $subsection make-tuple } +{ $subsection 2make-tuple } +{ $subsection 3make-tuple } +{ $subsection nmake-tuple } +; + +ABOUT: "combinators.tuple" diff --git a/extra/combinators/tuple/tuple.factor b/extra/combinators/tuple/tuple.factor new file mode 100644 index 0000000000..c4e0ef40a1 --- /dev/null +++ b/extra/combinators/tuple/tuple.factor @@ -0,0 +1,29 @@ +! (c)2009 Joe Groff bsd license +USING: accessors assocs classes.tuple generalizations kernel +locals quotations sequences ; +IN: combinators.tuple + +> assoc at [ + slot initial>> :> initial + { n ndrop initial } >quotation + ] unless* ; + +PRIVATE> + +MACRO:: nmake-tuple ( class assoc n -- ) + class all-slots [ assoc n (tuple-slot-quot) ] map :> quots + class :> \class + { quots n ncleave \class boa } >quotation ; + +: make-tuple ( x class assoc -- tuple ) + 1 nmake-tuple ; inline + +: 2make-tuple ( x y class assoc -- tuple ) + 2 nmake-tuple ; inline + +: 3make-tuple ( x y z class assoc -- tuple ) + 3 nmake-tuple ; inline + diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index ea15dc7884..a1b42d9f12 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: accessors alien.c-types arrays combinators combinators.short-circuit game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images @@ -229,16 +230,14 @@ BEFORE: bunny-world begin-world { depth-attachment 1.0 } } clear-framebuffer ] [ - render-set new - triangles-mode >>primitive-mode - { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments - swap { - [ >>uniforms ] - [ bunny>> vertex-array>> >>vertex-array ] - [ bunny>> index-elements>> >>indexes ] - [ sobel>> framebuffer>> >>framebuffer ] - } cleave - render + { + { "primitive-mode" [ drop triangles-mode ] } + { "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] } + { "uniforms" [ ] } + { "vertex-array" [ bunny>> vertex-array>> ] } + { "indexes" [ bunny>> index-elements>> ] } + { "framebuffer" [ sobel>> framebuffer>> ] } + } render ] bi ; : ( sobel -- uniforms ) @@ -250,13 +249,12 @@ BEFORE: bunny-world begin-world : draw-sobel ( world -- ) T{ depth-state { comparison f } } set-gpu-state* - render-set new - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap sobel>> - [ >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + sobel>> { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ ] } + { "vertex-array" [ vertex-array>> ] } + } render ; : draw-sobeled-bunny ( world -- ) [ draw-bunny ] [ draw-sobel ] bi ; @@ -264,13 +262,12 @@ BEFORE: bunny-world begin-world : draw-loading ( world -- ) T{ depth-state { comparison f } } set-gpu-state* - render-set new - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap loading>> - [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + loading>> { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] } + { "vertex-array" [ vertex-array>> ] } + } render ; M: bunny-world draw-world* dup bunny>> diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index df323d3c82..9ac943150d 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays game-loop game-worlds generalizations -gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel -literals math math.matrices math.order math.vectors +USING: accessors arrays combinators.tuple game-loop game-worlds +generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd +kernel literals math math.matrices math.order math.vectors method-chains sequences ui ui.gadgets ui.gadgets.worlds ui.pixel-formats ; IN: gpu.demos.raytrace @@ -97,13 +97,12 @@ AFTER: raytrace-world tick* spheres>> [ tick-sphere ] each ; M: raytrace-world draw-world* - render-set new - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap - [ >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ ] } + { "vertex-array" [ vertex-array>> ] } + } render ; M: raytrace-world pref-dim* drop { 1024 768 } ; M: raytrace-world tick-length drop 1000 30 /i ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 65a99f94d7..feb2f3f768 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: accessors alien alien.c-types alien.structs arrays assocs classes.mixin classes.parser classes.singleton -classes.tuple classes.tuple.private combinators destructors fry +classes.tuple classes.tuple.private combinators combinators.tuple destructors fry generic generic.parser gpu gpu.buffers gpu.framebuffers gpu.framebuffers.private gpu.shaders gpu.state gpu.textures gpu.textures.private half-floats images kernel lexer locals @@ -474,13 +474,22 @@ M: vertex-array dispose PRIVATE> TUPLE: render-set - { primitive-mode primitive-mode } - { vertex-array vertex-array } - { uniforms uniform-tuple } - { indexes vertex-indexes initial: T{ index-range } } - { instances ?integer initial: f } - { framebuffer any-framebuffer initial: system-framebuffer } - { output-attachments sequence initial: { default-attachment } } ; + { primitive-mode primitive-mode read-only } + { vertex-array vertex-array read-only } + { uniforms uniform-tuple read-only } + { indexes vertex-indexes initial: T{ index-range } read-only } + { instances ?integer initial: f read-only } + { framebuffer any-framebuffer initial: system-framebuffer read-only } + { output-attachments sequence initial: { default-attachment } read-only } ; + +: ( x quot-assoc -- render-set ) + render-set swap make-tuple ; inline + +: 2 ( x y quot-assoc -- render-set ) + render-set swap 2make-tuple ; inline + +: 3 ( x y z quot-assoc -- render-set ) + render-set swap 3make-tuple ; inline : render ( render-set -- ) {