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