steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

minor fixes and factoroids updates

cvs
Slava Pestov 2005-11-19 09:09:30 +00:00
parent 3a15b4db35
commit d0eff0b9f0
18 changed files with 205 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
examples/factoroids/actors.factor
View File

@ -9,42 +9,46 @@ SYMBOL: actors
: remove-actor actors get delete ;
TUPLE: actor model colors up expiry ;
: default-priority 0 ;
: projectile-priority 1 ;
: powerup-priority 1 ;
! model: see models.factor
! colors: a sequence to color parts of the model
! up: an orientation vector for rotation
! expiry: f or a time when the actor will cease to exist
! shield: f if invincible, otherwise an integer
! max-shield: shield is set to max-shield when we recharge
! priority: when two actors collide, the one with highest
! priority has its collision generic word called
! ai: object responding to ai-tick generic
TUPLE: actor model colors up expiry shield max-shield priority ai ;
C: actor ( model colors position angle size -- actor )
[ >r <body> r> set-delegate ] keep
[ set-actor-colors ] keep
[ set-actor-model ] keep ;
TUPLE: projectile owner ;
C: projectile ( actor owner -- projectile )
[ set-projectile-owner ] keep
[ set-delegate ] keep ;
[ set-actor-model ] keep
default-priority over set-actor-priority ;
GENERIC: can-collide* ( actor actor -- ? )
M: projectile can-collide* ( actor actor -- ? )
over projectile? >r projectile-owner eq? r> or not ;
M: actor can-collide* ( actor actor -- ) 2drop t ;
GENERIC: collision
M: actor collision ( actor actor -- ) drop remove-actor ;
: can-collide? ( actor actor -- ? )
2dup eq? [
2drop f
] [
2dup can-collide* >r swap can-collide* r> and
] if ;
: can-collide? ( a1 a2 -- ? )
#! If true, a collision test is performed, and a2's
#! collision generic is called.
2dup eq? >r over actor-priority over actor-priority > r> or
[ 2drop f ] [ can-collide* ] if ;
: collidable ( actor -- seq )
actors get [ can-collide? ] subset-with ;
: ?collision ( actor actor -- )
2dup [ body-position ] 2apply v- norm 2 <=
2dup [ body-position ] 2apply v- norm 1 <=
[ 2dup collision 2dup swap collision ] when 2drop ;
: ?collisions ( actor -- )
@ -54,8 +58,14 @@ M: actor collision ( actor actor -- ) drop remove-actor ;
dup actor-expiry
[ millis <= [ dup remove-actor ] when ] when* drop ;
GENERIC: ai-tick
M: f ai-tick ( actor ai -- ) 2drop ;
: actor-tick ( time actor -- )
dup ?expire-actor dup ?collisions body-tick ;
dup ?expire-actor dup ?collisions
dup dup actor-ai ai-tick
body-tick ;
: draw-actor ( actor -- )
GL_MODELVIEW [
@ -68,27 +78,11 @@ M: actor collision ( actor actor -- ) drop remove-actor ;
: spawn-big-block ( position -- )
>r cube { { 1/2 1/2 1 1 } } r> 360 random-int { 3 3 3 } <actor> add-actor ;
: init-actors
V{ } clone actors set
{ 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
player get add-actor ;
: <player> ( position -- )
>r factoroid { { 1 0 0 1 } { 2/3 0 0 1 } } r> 0 { 3/4 1/4 2 } <actor> ;
: draw-actors
actors get [ draw-actor ] each ;
: tick-actors ( time -- )
actors get clone [ actor-tick ] each-with ;
: add-expiring-actor ( actor time-to-live -- )
millis + over set-actor-expiry add-actor ;
: <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 ;

52
examples/factoroids/ai.factor Normal file
View File

@ -0,0 +1,52 @@
USING: arrays gadgets generic hashtables io kernel math
namespaces opengl prettyprint sdl sequences threads ;
IN: factoroids
! The approach AI moves the player towards a certain point
TUPLE: approach point ;
: turn-toward ( point actor -- )
[ body-perp v. sgn 30 /f ] keep set-body-angle-delta ;
: approached? ( actor ai -- ? )
approach-point >r body-position r> v- norm-sq 4 <= ;
M: approach ai-tick ( actor ai -- )
2dup approached? [
drop
0 over set-body-acceleration
0 swap set-body-angle-delta
] [
approach-point over turn-toward
drop
! 1 60000 /f swap set-body-acceleration
] if ;
! The dumbass just wanders around, approaching random points
TUPLE: dumbass ;
C: dumbass ( -- dumbass ) f <approach> over set-delegate ;
: init-dumbass ( actor ai -- )
swap body-position
10 random-int 5 - 10 random-int 5 - 0 3array v+
swap set-approach-point ;
M: dumbass ai-tick ( actor ai -- )
dup approach-point [
2dup approached?
[ init-dumbass ] [ delegate ai-tick ] if
] [
init-dumbass
] if ;
! The follower follows an actor
TUPLE: follower actor ;
C: follower ( actor -- follower )
[ set-follower-actor ] keep
f <approach> over set-delegate ;
M: follower ai-tick ( actor ai -- )
dup follower-actor body-position over set-approach-point
delegate ai-tick ;

13
examples/factoroids/bodies.factor
View File

@ -7,10 +7,6 @@ angle-delta direction ;
GENERIC: tick ( time obj -- )
: update-direction ( body -- )
dup body-angle deg>rad dup sin swap cos 0 swap 3array
swap set-body-direction ;
C: body ( position angle size -- )
[ set-body-size ] keep
[ set-body-angle ] keep
@ -43,6 +39,10 @@ C: body ( position angle size -- )
[ [ scaled-velocity ] keep body-position v+ ] keep
set-body-position ;
: update-direction ( body -- )
dup body-angle deg>rad dup sin swap cos 0 swap 3array
swap set-body-direction ;
: body-tick ( time body -- )
[ update-angle ] 2keep
[ update-velocity ] 2keep
@ -63,3 +63,8 @@ C: body ( position angle size -- )
rot body-up
>r >r first3 r> first3 r> first3
gluLookAt ;
: body-perp ( v -- v )
#! Return a vector perpendicular to the direction vector
#! and also perpendicular to the y axis.
body-direction first3 swap >r neg swap r> swap 3array ;

9
examples/factoroids/factoroids.factor
View File

@ -66,6 +66,15 @@ SYMBOL: last-frame
2 sleep
check-event [ run-game ] unless ;
: init-actors
V{ } clone actors set
{ 25 1/2 25 } <player> player set
{ 30 1/2 30 } <player> player get <follower> over set-actor-ai add-actor
{ 15 1/2 30 } <player> player get <follower> over set-actor-ai add-actor
{ 10 1/2 30 } <player> <dumbass> over set-actor-ai add-actor
{ 5 1/2 30 } <player> <dumbass> over set-actor-ai add-actor
player get add-actor ;
: factoroids
init-actors
800 600 [

2
examples/factoroids/load.factor
View File

@ -4,6 +4,8 @@ USING: io parser ;
"examples/factoroids/models.factor" run-file
"examples/factoroids/bodies.factor" run-file
"examples/factoroids/actors.factor" run-file
"examples/factoroids/projectiles.factor" run-file
"examples/factoroids/ai.factor" run-file
"examples/factoroids/input.factor" run-file
"examples/factoroids/factoroids.factor" run-file

56
examples/factoroids/models.factor
View File

@ -140,59 +140,3 @@ TUPLE: model faces ;
}
}
} ;
: rocket
T{ model f
{
T{ face f
0
{ 0 -1 0 }
{
{ -1/2 0 -1/2 }
{ 0 1/2 -1/2 }
{ 1/2 0 -1/2 }
{ 0 -1/2 -1/2 }
}
}
T{ face f
1
f
{
{ -1/2 0 -1/2 }
{ 0 1/2 -1/2 }
{ 0 0 1/2 }
}
}
T{ face f
1
f
{
{ 0 1/2 -1/2 }
{ 1/2 0 -1/2 }
{ 0 0 1/2 }
}
}
T{ face f
1
f
{
{ 1/2 0 -1/2 }
{ 0 -1/2 -1/2 }
{ 0 0 1/2 }
}
}
T{ face f
1
f
{
{ 0 -1/2 -1/2 }
{ -1/2 0 -1/2 }
{ 0 0 1/2 }
}
}
}
} ;

79
examples/factoroids/projectiles.factor Normal file
View File

@ -0,0 +1,79 @@
USING: arrays gadgets generic hashtables io kernel math
namespaces opengl prettyprint sdl sequences threads ;
IN: factoroids
: add-expiring-actor ( actor time-to-live -- )
millis + over set-actor-expiry add-actor ;
TUPLE: projectile owner ;
C: projectile ( actor owner -- projectile )
[ set-projectile-owner ] keep
[ set-delegate ] keep
projectile-priority over set-actor-priority ;
M: projectile can-collide* ( actor actor -- ? )
over projectile? >r projectile-owner eq? r> or not ;
: rocket
T{ model f
{
T{ face f
0
{ 0 -1 0 }
{
{ -1/2 0 -1/2 }
{ 0 1/2 -1/2 }
{ 1/2 0 -1/2 }
{ 0 -1/2 -1/2 }
}
}
T{ face f
1
f
{
{ -1/2 0 -1/2 }
{ 0 1/2 -1/2 }
{ 0 0 1/2 }
}
}
T{ face f
1
f
{
{ 0 1/2 -1/2 }
{ 1/2 0 -1/2 }
{ 0 0 1/2 }
}
}
T{ face f
1
f
{
{ 1/2 0 -1/2 }
{ 0 -1/2 -1/2 }
{ 0 0 1/2 }
}
}
T{ face f
1
f
{
{ 0 -1/2 -1/2 }
{ -1/2 0 -1/2 }
{ 0 0 1/2 }
}
}
}
} ;
: <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 ;

6
library/alien/compiler.factor
View File

@ -132,12 +132,8 @@ M: alien-node linearize* ( node -- )
[ dup parameters stack-space %cleanup , ] unless
dup linearize-return linearize-next ;
: unpair ( seq -- odds evens )
2 swap group flip dup empty?
[ drop { } { } ] [ first2 ] if ;
: parse-arglist ( lst -- types stack effect )
unpair [
2 swap group unpair [
" " % [ "," ?tail drop % " " % ] each "-- " %
] "" make ;

1
library/alien/syntax.factor
View File

@ -13,7 +13,6 @@ sequences words ;
!
! : glTranslatef ( x y z -- )
! "void" "gl" "glTranslatef" [ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ;
! \ glTranslatef compile
!
! other forms:
!

2
library/collections/sequences-epilogue.factor
View File

@ -121,7 +121,7 @@ M: object peek ( sequence -- element )
: pop* ( sequence -- )
#! Shorten the sequence by one element.
[ length 1- ] keep
[ f -rot set-nth ] 2keep
[ 0 -rot set-nth ] 2keep
set-length ;
: pop ( sequence -- element )

5
library/collections/slicing.factor
View File

@ -52,7 +52,7 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
: (group) ( n seq -- )
2dup length >= [
dup like , drop
dup empty? [ 2drop ] [ dup like , drop ] if
] [
2dup head , dupd tail-slice (group)
] if ;
@ -106,6 +106,9 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
2dup mismatch dup -1 = [ drop 2dup min-length ] when
tuck swap tail-slice >r swap tail-slice r> ;
: unpair ( seq -- firsts seconds )
flip dup empty? [ drop { } { } ] [ first2 ] if ;
IN: strings
: completion? ( partial completion quot -- ? )

6
library/inference/inline-methods.factor
View File

@ -19,7 +19,11 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
[ swap ?hash [ object ] unless* ] map-with ;
: dispatching-classes ( node -- seq )
dup dup node-param dispatching-values node-classes* ;
dup node-in-d empty? [
drop { }
] [
dup dup node-param dispatching-values node-classes*
] if ;
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?

3
library/opengl/opengl-utils.factor
View File

@ -64,9 +64,6 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
: four-sides ( dim -- )
dup top-left dup top-right dup bottom-right bottom-left ;
: gl-line ( from to color -- )
gl-color [ gl-vertex ] 2apply ;
: gl-fill-rect ( dim -- )
#! Draws a two-dimensional box.
GL_QUADS [ four-sides ] do-state ;

2
library/syntax/prettyprint.factor
View File

@ -211,7 +211,7 @@ M: real pprint* ( obj -- ) number>string f text ;
: ch>unicode-escape ( ch -- esc )
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
: unparse-ch ( ch -- ch/str )
: unparse-ch ( ch -- )
dup quotable? [
,
] [

2
library/test/collections/sequences.factor
View File

@ -205,3 +205,5 @@ unit-test
] unit-test
[ 1 ] [ 1/2 { 1 2 3 } nth ] unit-test
[ { } ] [ 0 { } group ] unit-test

8
library/test/compiler/optimizer.factor
View File

@ -1,7 +1,7 @@
IN: temporary
USING: arrays assembler compiler compiler-backend generic
hashtables inference kernel kernel-internals lists math
optimizer prettyprint sequences strings test vectors words ;
IN: temporary
: kill-1
[ 1 2 3 ] [ + ] over drop drop ; compiled
@ -205,3 +205,9 @@ TUPLE: pred-test ;
: blah over cons? [ bleh >r 2cdr r> ] [ 2drop f f f ] if ; compiled
[ f ] [ [ 1 2 3 ] [ 1 3 2 ] blah drop 2car = ] unit-test
! regression
: (the-test) dup 0 > [ 1- (the-test) ] when ; inline
: the-test 2 dup (the-test) ; compiled
[ 2 0 ] [ the-test ] unit-test

2
library/ui/gadgets.factor
View File

@ -23,7 +23,7 @@ M: array rect-dim drop { 0 0 0 } ;
: |v-| ( vec vec -- vec ) v- [ 0 max ] map ;
: <extent-rect> ( loc ext ) dupd swap |v-| <rect> ;
: <extent-rect> ( loc ext -- rect ) dupd swap |v-| <rect> ;
: >absolute ( rect -- rect )
rect-bounds >r origin get v+ r> <rect> ;