Subclassing fixes, removed Factoroids
slava
parent
ada7262fd8
commit
274dd3896a
|
|
@ -39,6 +39,7 @@
|
|||
|
||||
- inform-compile dies with funny error
|
||||
- amd64 %unbox-struct
|
||||
- amd64 %write-barrier
|
||||
- float intrinsics
|
||||
- complex float type
|
||||
- complex float intrinsics
|
||||
|
|
|
|||
|
|
@ -1,88 +0,0 @@
|
|||
USING: arrays gadgets generic hashtables io kernel math
|
||||
namespaces opengl prettyprint sdl sequences threads ;
|
||||
IN: factoroids
|
||||
|
||||
SYMBOL: player
|
||||
SYMBOL: actors
|
||||
|
||||
: add-actor dup actors get push ;
|
||||
|
||||
: remove-actor actors get delete ;
|
||||
|
||||
: 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
|
||||
default-priority over set-actor-priority ;
|
||||
|
||||
GENERIC: can-collide* ( actor actor -- ? )
|
||||
|
||||
M: actor can-collide* ( actor actor -- ) 2drop t ;
|
||||
|
||||
GENERIC: collision
|
||||
|
||||
M: actor collision ( actor actor -- ) drop remove-actor ;
|
||||
|
||||
: 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 1 <=
|
||||
[ 2dup collision 2dup swap collision ] when 2drop ;
|
||||
|
||||
: ?collisions ( actor -- )
|
||||
dup collidable [ ?collision ] each-with ;
|
||||
|
||||
: ?expire-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
|
||||
dup dup actor-ai ai-tick
|
||||
body-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 ;
|
||||
|
||||
: spawn-big-block ( position -- )
|
||||
>r cube { { 1/2 1/2 1 1 } } r> 360 random-int { 3 3 3 } <actor> 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 ;
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
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 ;
|
||||
|
|
@ -1,70 +0,0 @@
|
|||
USING: arrays gadgets generic hashtables io kernel math
|
||||
namespaces opengl sdl sequences threads ;
|
||||
IN: factoroids
|
||||
|
||||
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 ;
|
||||
|
||||
: 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 2 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 ;
|
||||
|
||||
: 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 ;
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
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
|
||||
{ 0.0 0.0 0.0 1.0 } 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 [
|
||||
5 [ { 1 0 0 } n*v gl-vertex ] each
|
||||
5 [ { 0 0 1 } n*v gl-vertex ] each
|
||||
] do-state ;
|
||||
|
||||
: grid-square ( w h -- )
|
||||
GL_MODELVIEW [
|
||||
[ 5 * ] 2apply 0 swap glTranslated
|
||||
(grid-square)
|
||||
] do-matrix ;
|
||||
|
||||
: draw-grid ( w h -- )
|
||||
{ 1.0 1.0 1.0 1.0 } 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
|
||||
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 [
|
||||
init-dlists millis last-frame set run-game
|
||||
] with-gl-screen ;
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
IN: factoroids
|
||||
USING: alien generic hashtables io kernel math namespaces sdl
|
||||
sequences ;
|
||||
|
||||
: fire ( -- )
|
||||
player get [
|
||||
dup body-position over body-direction 3 v*n v+
|
||||
swap body-angle
|
||||
] keep 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" <c-object> dup SDL_PollEvent
|
||||
[ handle-event ] [ drop f ] if ;
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
USING: kernel io parser sequences ;
|
||||
|
||||
{
|
||||
"utils"
|
||||
"models"
|
||||
"bodies"
|
||||
"actors"
|
||||
"projectiles"
|
||||
"ai"
|
||||
"input"
|
||||
"factoroids"
|
||||
} [ "/examples/factoroids/" swap ".factor" append3 run-resource ] each
|
||||
|
||||
"To play Factoroids, enter the following in the listener:" print
|
||||
terpri
|
||||
" USE: factoroids" print
|
||||
" factoroids" print
|
||||
|
|
@ -1,142 +0,0 @@
|
|||
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 ;
|
||||
|
||||
: cube
|
||||
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 }
|
||||
}
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
||||
: factoroid
|
||||
T{ model f
|
||||
{
|
||||
T{ face f
|
||||
1
|
||||
f
|
||||
{
|
||||
{ -1/3 1/2 -1/2 }
|
||||
{ 1/3 1/2 -1/2 }
|
||||
{ 1/2 -1/2 -1/2 }
|
||||
{ -1/2 -1/2 -1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
f
|
||||
{
|
||||
{ -1/3 1/2 -1/2 }
|
||||
{ -1/2 -1/2 -1/2 }
|
||||
{ 0 -1/2 1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
f
|
||||
{
|
||||
{ 1/3 1/2 -1/2 }
|
||||
{ 1/2 -1/2 -1/2 }
|
||||
{ 0 -1/2 1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
f
|
||||
{
|
||||
{ -1/3 1/2 -1/2 }
|
||||
{ 1/3 1/2 -1/2 }
|
||||
{ 0 -1/2 1/2 }
|
||||
}
|
||||
}
|
||||
|
||||
T{ face f
|
||||
0
|
||||
f
|
||||
{
|
||||
{ -1/2 -1/2 -1/2 }
|
||||
{ -1/2 -1/2 -1/2 }
|
||||
{ 0 -1/2 1/2 }
|
||||
}
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
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 ;
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
IN: factoroids
|
||||
USING: alien 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
|
||||
GL_LIGHTING glDisable
|
||||
;
|
||||
|
||||
: >float-array ( seq -- float-array )
|
||||
dup length dup "float" <c-array> -rot
|
||||
[ pick set-float-nth ] 2each ;
|
||||
|
||||
: light-source
|
||||
GL_LIGHTING glEnable
|
||||
GL_LIGHT0 glEnable
|
||||
GL_LIGHT0 GL_POSITION { 1 1 1 0 } >float-array glLightfv
|
||||
GL_LIGHT0 GL_DIFFUSE { 1 0 0 1 } >float-array glLightfv
|
||||
GL_LIGHT0 GL_SPECULAR { 1 1 1 1 } >float-array glLightfv
|
||||
GL_LIGHT0 GL_AMBIENT { 0.1 0.1 0.1 1 } >float-array glLightfv ;
|
||||
|
||||
: world-projection
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
50 width get height get / 1 30 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 ;
|
||||
|
|
@ -6,25 +6,26 @@ libc math namespaces sequences strings ;
|
|||
|
||||
: encode-types ( return types -- encoding )
|
||||
>r 1array r> append
|
||||
[ alien>objc-types get hash ] map >string ;
|
||||
[ [ alien>objc-types get hash , CHAR: 0 , ] each ] "" make ;
|
||||
|
||||
: prepare-method ( { name return types quot } -- sel type imp )
|
||||
[ first3 encode-types >r sel_registerName r> ] keep
|
||||
[ % \ alien-callback , ] [ ] make compile-1 ;
|
||||
[ 1 swap tail % \ alien-callback , ] [ ] make ;
|
||||
|
||||
: init-method ( method alien -- )
|
||||
>r prepare-method r>
|
||||
[ set-objc-method-imp ] keep
|
||||
[ set-objc-method-types ] keep
|
||||
[ >r compile-1 r> set-objc-method-imp ] keep
|
||||
[ >r <malloc-string> r> set-objc-method-types ] keep
|
||||
set-objc-method-name ;
|
||||
|
||||
: <empty-method-list> ( n -- alien )
|
||||
"objc-method-list" c-size
|
||||
"objc-method" c-size rot * + 1 calloc ;
|
||||
"objc-method" c-size pick * + 1 calloc
|
||||
[ set-objc-method-list-count ] keep ;
|
||||
|
||||
: <method-list> ( methods -- alien )
|
||||
dup length dup <empty-method-list> -rot
|
||||
[ pick objc-method-nth init-method ] 2each ;
|
||||
[ pick method-list@ objc-method-nth init-method ] 2each ;
|
||||
|
||||
: <method-lists> ( methods -- lists )
|
||||
<method-list> alien-address
|
||||
|
|
|
|||
Loading…
Reference in New Issue