+++ /dev/null
-! A simple space shooter.
-!
-! To run this code, bootstrap Factor like so:
-!
-! ./f boot.image.le32
-! -libraries:sdl:name=libSDL.so
-! -libraries:sdl-gfx:name=libSDL_gfx.
-!
-! (But all on one line)
-!
-! Then, start Factor as usual (./f factor.image) and enter this
-! at the listener:
-!
-! "examples/factoroids.factor" run-file
-
-IN: factoroids
-
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: generic
-USE: random
-USE: sdl
-USE: sdl-event
-USE: sdl-gfx
-USE: sdl-keysym
-USE: sdl-video
-
-! Game objects
-GENERIC: draw ( actor -- )
-#! Draw the actor.
-
-GENERIC: tick ( actor -- ? )
-#! Return f if the actor should be removed.
-
-GENERIC: collide ( actor1 actor2 -- )
-#! Handle collision of two actors.
-
-! Actor attributes
-SYMBOL: position
-SYMBOL: radius
-SYMBOL: len
-SYMBOL: velocity
-SYMBOL: color
-SYMBOL: active
-
-! The list of actors is divided into layers. Note that an
-! actor's tick method can only add actors to layers other than
-! the actor's layer. The player layer only has one actor.
-SYMBOL: player
-SYMBOL: enemies
-SYMBOL: player-shots
-SYMBOL: enemy-shots
-
-: player-actor ( -- player )
- player get dup [ car ] when ;
-
-: x-in-screen? ( x -- ? ) 0 width get between? ;
-: y-in-screen? ( y -- ? ) 0 height get between? ;
-
-: in-screen? ( actor -- ? )
- #! Is the actor in the screen?
- [
- position get >rect y-in-screen? swap x-in-screen? and
- ] bind ;
-
-: move ( -- )
- #! Add velocity vector to current actor's position vector.
- velocity get position [ + ] change ;
-
-: active? ( actor -- ? )
- #! Push f if the actor should be removed.
- [ active get ] bind ;
-
-: deactivate ( actor -- )
- #! Cause the actor to be removed in the next tick cycle.
- [ active off ] bind ;
-
-: screen-xy ( -- x y )
- position get >rect swap >fixnum swap >fixnum ;
-
-: actor-xy ( actor -- )
- #! Copy actor's x/y co-ordinates to this namespace.
- [ position get ] bind position set ;
-
-! Collision detection
-: distance ( actor1 actor2 -- x )
- #! Distance between two actor's positions.
- >r [ position get ] bind r> [ position get ] bind - abs ;
-
-: min-distance ( actor1 actor2 -- )
- #! Minimum distance before there is a collision.
- >r [ radius get ] bind r> [ radius get ] bind + ;
-
-: collision? ( actor1 actor2 -- ? )
- 2dup distance >r min-distance r> > ;
-
-: check-collision ( actor1 actor2 -- )
- 2dup collision? [ collide ] [ 2drop ] ifte ;
-
-: layer-actor-collision ( actor layer -- )
- #! The layer is a list of actors.
- [ dupd check-collision ] each drop ;
-
-: layer-collision ( layer layer -- )
- swap [ over layer-actor-collision ] each drop ;
-
-: collisions ( -- )
- #! Only collisions we allow are player colliding with an
- #! enemy shot, and player shot colliding with enemy.
- player get enemy-shots get layer-collision
- enemies get player-shots get layer-collision ;
-
-! The player's ship
-
-TRAITS: ship
-M: ship draw ( actor -- )
- [
- surface get screen-xy radius get color get
- filledCircleColor
- ] bind ;
-
-M: ship tick ( actor -- ? ) dup [ move ] bind active? ;
-
-C: ship ( -- ship )
- [
- width get 2 /i height get 50 - rect> position set
- white rgb color set
- 10 radius set
- 0 velocity set
- active on
- ] extend ;
-
-! Projectiles
-TRAITS: plasma
-M: plasma draw ( actor -- )
- [
- surface get screen-xy dup len get + color get
- vlineColor
- ] bind ;
-
-M: plasma tick ( actor -- ? )
- dup [ move ] bind dup in-screen? swap active? and ;
-
-M: plasma collide ( actor1 actor2 -- )
- #! Remove the other actor.
- deactivate deactivate ;
-
-C: plasma ( actor dy -- plasma )
- [
- velocity set
- actor-xy
- blue rgb color set
- 10 len set
- 5 radius set
- active on
- ] extend ;
-
-: player-fire ( -- )
- #! Do nothing if player is dead.
- player-actor [
- #{ 0 -6 }# <plasma> player-shots cons@
- ] when* ;
-
-: enemy-fire ( actor -- )
- #{ 0 5 }# <plasma> enemy-shots cons@ ;
-
-! Background of stars
-TRAITS: particle
-
-M: particle draw ( actor -- )
- [ surface get screen-xy color get pixelColor ] bind ;
-
-: wrap ( -- )
- #! If current actor has gone beyond screen bounds, move it
- #! back.
- position get >rect
- swap >fixnum width get rem
- swap >fixnum height get rem
- rect> position set ;
-
-M: particle tick ( actor -- )
- [ move wrap t ] bind ;
-
-C: particle ;
-
-SYMBOL: stars
-: star-count 100 ;
-
-: random-x 0 width get random-int ;
-: random-y 0 height get random-int ;
-: random-position random-x random-y rect> ;
-: random-byte 0 255 random-int ;
-: random-color random-byte random-byte random-byte rgb ;
-: random-velocity 0 10 20 random-int 10 /f rect> ;
-
-: random-star ( -- star )
- <particle> [
- random-position position set
- random-color color set
- random-velocity velocity set
- active on
- ] extend ;
-
-: init-stars ( -- )
- #! Generate random background of scrolling stars.
- [ ] star-count [ random-star swons ] times stars set ;
-
-: draw-stars ( -- )
- stars get [ draw ] each ;
-
-: tick-stars ( -- )
- stars get [ tick drop ] each ;
-
-! Enemies
-: enemy-chance 50 ;
-
-TRAITS: enemy
-M: enemy draw ( actor -- )
- [
- surface get screen-xy radius get color get
- filledCircleColor
- ] bind ;
-
-: attack-chance 30 ;
-
-: chance ( n -- boolean )
- #! Returns true with a 1/n probability, false with a (n-1)/n
- #! probability.
- 1 swap random-int 1 = ;
-
-: attack ( actor -- )
- #! Fire a shot some of the time.
- attack-chance chance [ enemy-fire ] [ drop ] ifte ;
-
-SYMBOL: wiggle-x
-
-: wiggle ( -- )
- #! Wiggle from left to right.
- -3 3 random-int wiggle-x [ + ] change
- wiggle-x get sgn 1 rect> velocity set ;
-
-M: enemy tick ( actor -- )
- dup attack
- dup [ wiggle move position get imaginary ] bind
- y-in-screen? swap active? and ;
-
-C: enemy ;
-
-: spawn-enemy ( -- )
- <enemy> [
- random-x 10 rect> position set
- red rgb color set
- 0 wiggle-x set
- 0 velocity set
- 10 radius set
- active on
- ] extend ;
-
-: spawn-enemies ( -- )
- enemy-chance chance [ spawn-enemy enemies cons@ ] when ;
-
-! Event handling
-SYMBOL: event
-
-: mouse-motion-event ( event -- )
- motion-event-x player-actor dup [
- [ position get imaginary rect> position set ] bind
- ] [
- 2drop
- ] ifte ;
-
-: mouse-down-event ( event -- )
- drop player-fire ;
-
-: handle-event ( event -- ? )
- #! Return if we should continue or stop.
- [
- [ event-type SDL_MOUSEBUTTONDOWN = ] [ mouse-down-event t ]
- [ event-type SDL_MOUSEMOTION = ] [ mouse-motion-event t ]
- [ event-type SDL_QUIT = ] [ drop f ]
- [ drop t ] [ drop t ]
- ] cond ;
-
-: check-event ( -- ? )
- #! Check if there is a pending event.
- #! Return if we should continue or stop.
- event get dup SDL_PollEvent [
- handle-event [ check-event ] [ f ] ifte
- ] [
- drop t
- ] ifte ;
-
-! Game loop
-: init-game ( -- )
- #! Init game objects.
- init-stars
- <ship> unit player set
- <event> event set ;
-
-: each-layer ( quot -- )
- #! Apply quotation to each layer.
- [ enemies enemy-shots player player-shots ] swap each ;
-
-: draw-actors ( -- )
- [ get [ draw ] each ] each-layer ;
-
-: tick-actors ( -- )
- #! Advance game state by one frame. Actors whose tick word
- #! returns f are removed from the layer.
- [ dup get [ tick ] subset put ] each-layer ;
-
-: render ( -- )
- #! Draw the scene.
- [ black rgb clear-surface draw-stars draw-actors ] with-surface ;
-
-: advance ( -- )
- #! Advance game state by one frame.
- tick-actors tick-stars spawn-enemies ;
-
-: game-loop ( -- )
- #! Render, advance game state, repeat.
- render advance collisions check-event [ game-loop ] when ;
-
-: factoroids ( -- )
- #! Main word.
- 640 480 32 SDL_HWSURFACE [
- "Factoroids" "Factoroids" SDL_WM_SetCaption
- init-game game-loop
- ] with-screen ;
-
-factoroids
projects / factor.git / commitdiff