--- /dev/null
+! (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"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs classes.tuple generalizations kernel
+locals quotations sequences ;
+IN: combinators.tuple
+
+<PRIVATE
+
+:: (tuple-slot-quot) ( slot assoc n -- quot )
+ slot name>> 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 <wrapper> :> \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
+
+! (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
{ 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 {
- [ <bunny-uniforms> >>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" [ <bunny-uniforms> ] }
+ { "vertex-array" [ bunny>> vertex-array>> ] }
+ { "indexes" [ bunny>> index-elements>> ] }
+ { "framebuffer" [ sobel>> framebuffer>> ] }
+ } <render-set> render
] bi ;
: <sobel-uniforms> ( sobel -- uniforms )
: 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>>
- [ <sobel-uniforms> >>uniforms ]
- [ vertex-array>> >>vertex-array ] bi
- render ;
+ sobel>> {
+ { "primitive-mode" [ drop triangle-strip-mode ] }
+ { "indexes" [ drop T{ index-range f 0 4 } ] }
+ { "uniforms" [ <sobel-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render ;
: draw-sobeled-bunny ( world -- )
[ draw-bunny ] [ draw-sobel ] bi ;
: 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-set> render ;
M: bunny-world draw-world*
dup bunny>>
! (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
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
- [ <sphere-uniforms> >>uniforms ]
- [ vertex-array>> >>vertex-array ] bi
- render ;
+ {
+ { "primitive-mode" [ drop triangle-strip-mode ] }
+ { "indexes" [ drop T{ index-range f 0 4 } ] }
+ { "uniforms" [ <sphere-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render ;
M: raytrace-world pref-dim* drop { 1024 768 } ;
M: raytrace-world tick-length drop 1000 30 /i ;
! (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
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 } ;
+
+: <render-set> ( x quot-assoc -- render-set )
+ render-set swap make-tuple ; inline
+
+: 2<render-set> ( x y quot-assoc -- render-set )
+ render-set swap 2make-tuple ; inline
+
+: 3<render-set> ( x y z quot-assoc -- render-set )
+ render-set swap 3make-tuple ; inline
: render ( render-set -- )
{
projects / factor.git / commitdiff