2005-11-15 03:19:57 -05:00
|
|
|
USING: arrays gadgets generic hashtables io kernel math
|
2005-11-15 23:25:22 -05:00
|
|
|
namespaces opengl prettyprint sdl sequences threads ;
|
2005-11-15 03:19:57 -05:00
|
|
|
IN: factoroids
|
|
|
|
|
|
|
|
|
|
SYMBOL: player
|
|
|
|
|
SYMBOL: actors
|
|
|
|
|
|
|
|
|
|
: add-actor dup actors get push ;
|
|
|
|
|
|
|
|
|
|
: remove-actor actors get delete ;
|
|
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
TUPLE: actor model colors up expiry ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
C: actor ( model colors position angle size -- actor )
|
|
|
|
|
[ >r <body> r> set-delegate ] keep
|
|
|
|
|
[ set-actor-colors ] keep
|
|
|
|
|
[ set-actor-model ] keep ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
TUPLE: projectile owner ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
C: projectile ( actor owner -- projectile )
|
|
|
|
|
[ set-projectile-owner ] keep
|
|
|
|
|
[ set-delegate ] keep ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
GENERIC: can-collide* ( actor actor -- ? )
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
M: projectile can-collide* ( actor actor -- ? )
|
|
|
|
|
over projectile? >r projectile-owner eq? r> or not ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
M: actor can-collide* ( actor actor -- ) 2drop t ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
GENERIC: collision
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
M: actor collision ( actor actor -- ) drop remove-actor ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: can-collide? ( actor actor -- ? )
|
|
|
|
|
2dup eq? [
|
|
|
|
|
2drop f
|
|
|
|
|
] [
|
|
|
|
|
2dup can-collide* >r swap can-collide* r> and
|
|
|
|
|
] if ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: collidable ( actor -- seq )
|
|
|
|
|
actors get [ can-collide? ] subset-with ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: ?collision ( actor actor -- )
|
|
|
|
|
2dup [ body-position ] 2apply v- norm 2 <=
|
|
|
|
|
[ 2dup collision 2dup swap collision ] when 2drop ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: ?collisions ( actor -- )
|
|
|
|
|
dup collidable [ ?collision ] each-with ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: ?expire-actor
|
|
|
|
|
dup actor-expiry
|
|
|
|
|
[ millis <= [ dup remove-actor ] when ] when* drop ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: actor-tick ( time actor -- )
|
|
|
|
|
dup ?expire-actor dup ?collisions body-tick ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
|
|
|
|
: draw-actor ( actor -- )
|
|
|
|
|
GL_MODELVIEW [
|
|
|
|
|
dup body-position gl-translate
|
|
|
|
|
dup body-angle over body-up gl-rotate
|
|
|
|
|
dup body-size gl-scale
|
|
|
|
|
dup actor-colors swap actor-model draw-model
|
|
|
|
|
] do-matrix ;
|
|
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: spawn-big-block ( position -- )
|
|
|
|
|
>r cube { { 1/2 1/2 1 1 } } r> 360 random-int { 3 3 3 } <actor> add-actor ;
|
|
|
|
|
|
2005-11-15 03:19:57 -05:00
|
|
|
: init-actors
|
|
|
|
|
V{ } clone actors set
|
2005-11-15 23:25:22 -05:00
|
|
|
{ 15 3 25 } spawn-big-block
|
|
|
|
|
{ 20 2 25 } spawn-big-block
|
|
|
|
|
{ 30 1 20 } spawn-big-block
|
|
|
|
|
{ 30 1/2 15 } spawn-big-block
|
|
|
|
|
factoroid { { 1 0 0 1 } { 2/3 0 0 1 } } { 25 1/2 25 } 0 { 3/4 1/4 2 } <actor> player set
|
2005-11-15 03:19:57 -05:00
|
|
|
player get add-actor ;
|
|
|
|
|
|
|
|
|
|
: draw-actors
|
|
|
|
|
actors get [ draw-actor ] each ;
|
|
|
|
|
|
|
|
|
|
: tick-actors ( time -- )
|
2005-11-15 23:25:22 -05:00
|
|
|
actors get clone [ actor-tick ] each-with ;
|
2005-11-15 03:19:57 -05:00
|
|
|
|
|
|
|
|
: add-expiring-actor ( actor time-to-live -- )
|
|
|
|
|
millis + over set-actor-expiry add-actor ;
|
|
|
|
|
|
2005-11-15 23:25:22 -05:00
|
|
|
: <rocket> ( position angle owner -- rocket )
|
|
|
|
|
>r >r >r rocket { { 1 1 0 1 } { 1 1 1 1 } } r> r> { 1/2 1/2 5 }
|
|
|
|
|
<actor> r> <projectile> 1/2000 over set-body-acceleration ;
|
|
|
|
|
|
|
|
|
|
: spawn-rocket ( position angle owner -- )
|
|
|
|
|
<rocket> 1000 add-expiring-actor ;
|
