factoroids
Slava Pestov
parent
f710a2df78
commit
b02c812b28
|
|
@ -0,0 +1,109 @@
|
|||
USING: arrays gadgets generic hashtables io kernel math
|
||||
namespaces opengl sdl sequences threads ;
|
||||
IN: factoroids
|
||||
|
||||
SYMBOL: player
|
||||
|
||||
SYMBOL: actors
|
||||
|
||||
: add-actor dup actors get push ;
|
||||
|
||||
: remove-actor actors get delete ;
|
||||
|
||||
TUPLE: body position velocity acceleration size up angle 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
|
||||
[ set-body-position ] keep
|
||||
{ 0 1 0 } over set-body-up
|
||||
0 over set-body-velocity
|
||||
0 over set-body-acceleration
|
||||
0 over set-body-angle-delta
|
||||
dup update-direction ;
|
||||
|
||||
: scaled-angle-delta ( time body -- x ) body-angle-delta * ;
|
||||
|
||||
: scaled-acceleration ( time body -- x ) body-acceleration * ;
|
||||
|
||||
: scaled-velocity ( time body -- x )
|
||||
[ body-velocity * ] keep body-direction n*v ;
|
||||
|
||||
: friction 0.95 ;
|
||||
|
||||
: update-angle ( time body -- )
|
||||
[ [ scaled-angle-delta ] keep body-angle + ] keep
|
||||
set-body-angle ;
|
||||
|
||||
: update-velocity ( time body -- )
|
||||
[
|
||||
[ scaled-acceleration ] keep body-velocity + friction *
|
||||
] keep set-body-velocity ;
|
||||
|
||||
: update-position ( time body -- )
|
||||
[ [ scaled-velocity ] keep body-position v+ ] keep
|
||||
set-body-position ;
|
||||
|
||||
M: body tick ( time body -- )
|
||||
[ update-angle ] 2keep
|
||||
[ update-velocity ] 2keep
|
||||
[ update-position ] keep
|
||||
update-direction ;
|
||||
|
||||
: camera-position ( player -- vec )
|
||||
dup body-position swap body-direction 3 v*n v- { 0 1 0 } v+ ;
|
||||
|
||||
: camera-look-at ( player -- vec )
|
||||
dup body-position swap body-direction 3 v*n v+ ;
|
||||
|
||||
: camera-modelview ( player -- )
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
dup camera-position
|
||||
over camera-look-at
|
||||
rot body-up
|
||||
>r >r first3 r> first3 r> first3
|
||||
gluLookAt ;
|
||||
|
||||
TUPLE: actor model colors up expiry ;
|
||||
|
||||
C: actor ( model colors position angle size -- actor )
|
||||
[ >r <body> r> set-delegate ] keep
|
||||
[ set-actor-colors ] keep
|
||||
[ set-actor-model ] keep ;
|
||||
|
||||
M: actor tick ( time actor -- )
|
||||
dup actor-expiry [ millis <= [ dup remove-actor ] when ] when*
|
||||
delegate tick ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: init-actors
|
||||
V{ } clone actors set
|
||||
factoroid { { 1 0 0 1 } } { 25 1/2 25 } 0 { 3/4 1/2 1/2 } <actor> player set
|
||||
player get add-actor ;
|
||||
|
||||
: draw-actors
|
||||
actors get [ draw-actor ] each ;
|
||||
|
||||
: tick-actors ( time -- )
|
||||
actors get clone [ dupd tick ] each drop ;
|
||||
|
||||
: add-expiring-actor ( actor time-to-live -- )
|
||||
millis + over set-actor-expiry add-actor ;
|
||||
|
||||
: spawn-rocket ( position angle -- rocket )
|
||||
>r >r rocket { { 1 1 0 1 } { 1 1 1 1 } } r> r> { 1/2 1/2 5 }
|
||||
<actor> 1/2000 over set-body-acceleration 1000 add-expiring-actor ;
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
USING: arrays gadgets generic hashtables io kernel math
|
||||
namespaces opengl sdl sequences styles threads ;
|
||||
IN: factoroids
|
||||
|
||||
: draw-sky
|
||||
flat-projection
|
||||
{ 0 1 0 } { { 0 0 1/3 1 } { 2/3 2/3 1 1 } } { 1 1/2 0 } gl-gradient ;
|
||||
|
||||
: make-sky-list ( -- id )
|
||||
GL_COMPILE [ draw-sky ] make-dlist ;
|
||||
|
||||
: draw-ground
|
||||
GL_DEPTH_TEST glDisable
|
||||
black gl-color
|
||||
GL_QUADS [
|
||||
{ -1000 0 -1000 } gl-vertex
|
||||
{ -1000 0 1000 } gl-vertex
|
||||
{ 1000 0 1000 } gl-vertex
|
||||
{ 1000 0 -1000 } gl-vertex
|
||||
] do-state
|
||||
GL_DEPTH_TEST glEnable ;
|
||||
|
||||
: (grid-square) ( -- )
|
||||
GL_POINTS [
|
||||
3 [ { 1 0 0 } n*v gl-vertex ] each
|
||||
3 [ { 0 0 1 } n*v gl-vertex ] each
|
||||
] do-state ;
|
||||
|
||||
: grid-square ( w h -- )
|
||||
GL_MODELVIEW [
|
||||
0 swap glTranslated
|
||||
1/3 1/3 1/3 glScaled
|
||||
(grid-square)
|
||||
] do-matrix ;
|
||||
|
||||
: draw-grid ( w h -- )
|
||||
white gl-color [ swap [ grid-square ] each-with ] each-with ;
|
||||
|
||||
: make-ground-list ( -- id )
|
||||
GL_COMPILE [ draw-ground 50 50 draw-grid ] make-dlist ;
|
||||
|
||||
SYMBOL: sky-list
|
||||
SYMBOL: ground-list
|
||||
|
||||
: init-dlists
|
||||
make-sky-list sky-list set
|
||||
make-ground-list ground-list set ;
|
||||
|
||||
: draw-factoroids
|
||||
[
|
||||
factoroids-gl
|
||||
sky-list get glCallList
|
||||
world-projection
|
||||
player get camera-modelview
|
||||
ground-list get glCallList
|
||||
draw-actors
|
||||
] with-gl-surface ;
|
||||
|
||||
SYMBOL: last-frame
|
||||
|
||||
: advance-clock ( -- time )
|
||||
millis last-frame get over last-frame set - 30 min ;
|
||||
|
||||
: run-game ( -- )
|
||||
advance-clock tick-actors
|
||||
draw-factoroids
|
||||
check-event [ run-game ] unless ;
|
||||
|
||||
: factoroids
|
||||
init-actors
|
||||
800 600 [
|
||||
init-dlists millis last-frame set run-game
|
||||
] with-gl-screen ;
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
IN: factoroids
|
||||
USING: generic hashtables io kernel math namespaces sdl
|
||||
sequences ;
|
||||
|
||||
: fire ( -- )
|
||||
player get dup body-position over body-direction 3 v*n v+
|
||||
swap body-angle spawn-rocket ;
|
||||
|
||||
: turn-left ( ? actor -- )
|
||||
swap [ 1 ] [ dup body-angle-delta 0 < -1 0 ? ] if 30 /f
|
||||
swap set-body-angle-delta ;
|
||||
|
||||
: turn-right ( ? actor -- )
|
||||
swap [ -1 ] [ dup body-angle-delta 0 > 1 0 ? ] if 30 /f
|
||||
swap set-body-angle-delta ;
|
||||
|
||||
: forward ( ? actor -- )
|
||||
swap [ 1 ] [ dup body-acceleration 0 < -1 0 ? ] if 6000 /f
|
||||
swap set-body-acceleration ;
|
||||
|
||||
: backward ( ? actor -- )
|
||||
swap [ -1 ] [ dup body-acceleration 0 > 1 0 ? ] if 60000 /f
|
||||
swap set-body-acceleration ;
|
||||
|
||||
: binding ( binding -- { down up } )
|
||||
keyboard-event>binding H{
|
||||
[[ [ "SPACE" ] { [ fire ] [ ] } ]]
|
||||
[[ [ "LEFT" ] { [ t player get turn-left ] [ f player get turn-left ] } ]]
|
||||
[[ [ "RIGHT" ] { [ t player get turn-right ] [ f player get turn-right ] } ]]
|
||||
[[ [ "UP" ] { [ t player get forward ] [ f player get forward ] } ]]
|
||||
[[ [ "DOWN" ] { [ t player get backward ] [ f player get backward ] } ]]
|
||||
} hash ;
|
||||
|
||||
GENERIC: handle-event ( event -- quit? )
|
||||
|
||||
M: object handle-event ( event -- quit? )
|
||||
drop f ;
|
||||
|
||||
M: quit-event handle-event ( event -- quit? )
|
||||
drop t ;
|
||||
|
||||
M: key-down-event handle-event ( event -- quit? )
|
||||
binding first call f ;
|
||||
|
||||
M: key-up-event handle-event ( event -- quit? )
|
||||
binding second call f ;
|
||||
|
||||
: check-event ( -- ? )
|
||||
<event> dup SDL_PollEvent [ handle-event ] [ drop f ] if ;
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
USING: io parser ;
|
||||
|
||||
"examples/factoroids/utils.factor" run-file
|
||||
"examples/factoroids/models.factor" run-file
|
||||
"examples/factoroids/actors.factor" run-file
|
||||
"examples/factoroids/input.factor" run-file
|
||||
"examples/factoroids/factoroids.factor" run-file
|
||||
|
||||
"To play Factoroids, enter the following in the listener:" print
|
||||
terpri
|
||||
" USE: factoroids" print
|
||||
" factoroids" print
|
||||
|
|
@ -0,0 +1,142 @@
|
|||
USING: arrays gadgets generic hashtables io kernel math
|
||||
namespaces opengl sdl sequences threads ;
|
||||
IN: factoroids
|
||||
|
||||
TUPLE: face color normal polygon ;
|
||||
|
||||
: draw-face ( colors face -- )
|
||||
[ face-color swap nth gl-color ] keep
|
||||
( dup face-normal gl-normal )
|
||||
face-polygon gl-fill-poly ;
|
||||
|
||||
TUPLE: model faces ;
|
||||
|
||||
: draw-model ( colors model -- )
|
||||
model-faces [ draw-face ] each-with ;
|
||||
|
||||
: factoroid
|
||||
T{ model f
|
||||
{
|
||||
T{ face f
|
||||
0
|
||||
{ 0 0 -1 }
|
||||
{
|
||||
{ -1/2 -1/2 -1/2 }
|
||||
{ 1/2 -1/2 -1/2 }
|
||||
{ 1/2 1/2 -1/2 }
|
||||
{ -1/2 1/2 -1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
{ 0 0 1 }
|
||||
{
|
||||
{ -1/2 -1/2 1/2 }
|
||||
{ 1/2 -1/2 1/2 }
|
||||
{ 1/2 1/2 1/2 }
|
||||
{ -1/2 1/2 1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
{ -1 0 0 }
|
||||
{
|
||||
{ -1/2 -1/2 -1/2 }
|
||||
{ -1/2 -1/2 1/2 }
|
||||
{ -1/2 1/2 1/2 }
|
||||
{ -1/2 1/2 -1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
{ 1 0 0 }
|
||||
{
|
||||
{ 1/2 -1/2 -1/2 }
|
||||
{ 1/2 -1/2 1/2 }
|
||||
{ 1/2 1/2 1/2 }
|
||||
{ 1/2 1/2 -1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
{ 0 -1 0 }
|
||||
{
|
||||
{ -1/2 -1/2 -1/2 }
|
||||
{ -1/2 -1/2 1/2 }
|
||||
{ 1/2 -1/2 1/2 }
|
||||
{ 1/2 -1/2 -1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
{ 0 1 0 }
|
||||
{
|
||||
{ -1/2 1/2 -1/2 }
|
||||
{ -1/2 1/2 1/2 }
|
||||
{ 1/2 1/2 1/2 }
|
||||
{ 1/2 1/2 -1/2 }
|
||||
}
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
||||
: 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 }
|
||||
}
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
IN: factoroids
|
||||
USING: kernel math namespaces opengl sdl sequences ;
|
||||
|
||||
: deg>rad pi * 180 / ; inline
|
||||
|
||||
: rad>deg 180 * pi / ; inline
|
||||
|
||||
: flat-projection
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
0 1 1 0 gluOrtho2D
|
||||
GL_DEPTH_TEST glDisable
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity ;
|
||||
|
||||
: world-projection
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
50 width get height get / 0.5 20 gluPerspective
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity ;
|
||||
|
||||
: factoroids-gl ( -- )
|
||||
0.0 0.0 0.0 0.0 glClearColor
|
||||
{ 1.0 0.0 0.0 0.0 } gl-color
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
0 0 width get height get glViewport
|
||||
GL_SMOOTH glShadeModel
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity ;
|
||||
|
||||
: gl-normal ( normal -- ) first3 glNormal3d ;
|
||||
|
||||
: gl-rotate first3 glRotated ;
|
||||
|
||||
: gl-scale first3 glScaled ;
|
||||
Loading…
Reference in New Issue