Update bunny, spheres, demo-support to use delegation

db4
U-VICTORIA\Administrator 2008-07-11 18:51:25 -07:00
parent f3d63e34ac
commit 8d311fbf76
3 changed files with 16 additions and 23 deletions

View File

@ -7,28 +7,23 @@ opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; bunny.cel-shaded bunny.outlined bunny.model accessors destructors ;
IN: bunny IN: bunny
TUPLE: bunny-gadget model geom draw-seq draw-n ; TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
: <bunny-gadget> ( -- bunny-gadget ) : <bunny-gadget> ( -- bunny-gadget )
0.0 0.0 0.375 <demo-gadget> 0.0 0.0 0.375 bunny-gadget new-demo-gadget
maybe-download read-model { maybe-download read-model >>model-triangles ;
set-delegate
(>>model)
} bunny-gadget construct ;
: bunny-gadget-draw ( gadget -- draw ) : bunny-gadget-draw ( gadget -- draw )
{ draw-n>> draw-seq>> } [ draw-n>> ] [ draw-seq>> ] bi nth ;
get-slots nth ;
: bunny-gadget-next-draw ( gadget -- ) : bunny-gadget-next-draw ( gadget -- )
dup { draw-seq>> draw-n>> } dup [ draw-seq>> ] [ draw-n>> ] bi
get-slots
1+ swap length mod 1+ swap length mod
>>draw-n relayout-1 ; >>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- ) M: bunny-gadget graft* ( gadget -- )
GL_DEPTH_TEST glEnable GL_DEPTH_TEST glEnable
dup model>> <bunny-geom> >>geom dup model-triangles>> <bunny-geom> >>geom
dup dup
[ <bunny-fixed-pipeline> ] [ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ] [ <bunny-cel-shaded> ]
@ -48,8 +43,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
dup demo-gadget-set-matrices dup demo-gadget-set-matrices
GL_MODELVIEW glMatrixMode GL_MODELVIEW glMatrixMode
0.02 -0.105 0.0 glTranslatef 0.02 -0.105 0.0 glTranslatef
{ geom>> bunny-gadget-draw } get-slots [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
draw-bunny
] if ; ] if ;
M: bunny-gadget pref-dim* ( gadget -- dim ) M: bunny-gadget pref-dim* ( gadget -- dim )

View File

@ -9,10 +9,10 @@ IN: opengl.demo-support
SYMBOL: last-drag-loc SYMBOL: last-drag-loc
TUPLE: demo-gadget yaw pitch distance ; TUPLE: demo-gadget < gadget yaw pitch distance ;
: <demo-gadget> ( yaw pitch distance -- gadget ) : new-demo-gadget ( yaw pitch distance class -- gadget )
demo-gadget construct-gadget new-gadget
swap >>distance swap >>distance
swap >>pitch swap >>pitch
swap >>yaw ; swap >>yaw ;
@ -31,19 +31,19 @@ M: demo-gadget distance-step ( gadget -- dz )
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
: yaw-demo-gadget ( yaw gadget -- ) : yaw-demo-gadget ( yaw gadget -- )
[ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; [ + ] with change-yaw relayout-1 ;
: pitch-demo-gadget ( pitch gadget -- ) : pitch-demo-gadget ( pitch gadget -- )
[ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ; [ + ] with change-pitch relayout-1 ;
: zoom-demo-gadget ( distance gadget -- ) : zoom-demo-gadget ( distance gadget -- )
[ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ; [ + ] with change-distance relayout-1 ;
M: demo-gadget pref-dim* ( gadget -- dim ) M: demo-gadget pref-dim* ( gadget -- dim )
drop { 640 480 } ; drop { 640 480 } ;
: -+ ( x -- -x x ) : -+ ( x -- -x x )
dup neg swap ; [ neg ] keep ;
: demo-gadget-frustum ( gadget -- -x x -y y near far ) : demo-gadget-frustum ( gadget -- -x x -y y near far )
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [ [ near-plane ] [ far-plane ] [ fov-ratio ] tri [

View File

@ -99,14 +99,13 @@ main()
} }
; ;
TUPLE: spheres-gadget TUPLE: spheres-gadget < demo-gadget
plane-program solid-sphere-program texture-sphere-program plane-program solid-sphere-program texture-sphere-program
reflection-framebuffer reflection-depthbuffer reflection-framebuffer reflection-depthbuffer
reflection-texture ; reflection-texture ;
: <spheres-gadget> ( -- gadget ) : <spheres-gadget> ( -- gadget )
20.0 10.0 20.0 <demo-gadget> 20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
{ set-delegate } spheres-gadget construct ;
M: spheres-gadget near-plane ( gadget -- z ) M: spheres-gadget near-plane ( gadget -- z )
drop 1.0 ; drop 1.0 ;