Tron 5mx
Priskribo de la ĉi-paĝa enhavo
Ludo verkita en Forth por la komputilo Psion 5mx.
Etikedoj:
En 2005, por provadi mian Forth 5mx, tiam programata, mi ekideis adapte reverki la ludon Tron kiun mi estis verkinta 20 jarojn antaŭe en fig-Forth por ZX Spectrum. Kompreneble la novan version mi nomis Tron 5mx. Kaj, same kompreneble, la stilon de mia kodo jam estis iom pli bona ol en 1985...
Forth 5mx ne plene laŭas la normon ANS Forth, sed probable apenaj ŝanĝoj necesus por funkciigi ĝin en ANS-Forthaj sistemoj. Vortoj specifaj de Psion 5mx estas dokumentitaj kaj estus facile reverkeblaj.
Fontkodo
\ tron5mx
\ Copyright (C) 2005, 2008, 2009 Marcos Cruz (http://programandala.net)
\ License: http://programandala.net/license
\ History:
\ 2005-05-28 First draft. Port of the Sinclair Spectrum Forth version.
\ 2008-04-10 First working version.
\ 2008-05-07 Improved to be used with any number of players. Other improvements.
\ 2009-05-24 Layout changes in the source code.
\ Bugs:
\ - When both players cause the collision, the score calculation is wrong and the explosion is repeated.
marker tron5mx
\ ..................................................................
\ Arena
screeninfo \ system dependent; it leaves 10 cells on the stack that describe the current screen
2drop
constant screen-heigth
constant screen-width
2drop 2drop 2drop
screen-heigth 1- constant x-max
screen-width 1- constant y-max
screen-heigth screen-width * constant #arena \ number of arena tiles
create arena #arena chars allot \ arena data space
: clear-arena ( -- ) arena #arena erase ;
: >arena ( x y -- c-addr ) screen-heigth * + arena + ;
: arena@ ( x y -- b ) >arena C@ ;
: arena! ( b x y -- ) >arena C! ;
: plot ( c x y -- )
\ Put a character on the arena.
2>r dup 2R@ arena! \ update the arena map
2r> at-xy emit \ print the char
;
\ ..................................................................
\ Players
2 constant #players \ max number of players
10 constant /player \ data bytes per player
create players #players /player * chars allot \ players data space
: player ( u -- c-addr )
\ u = player number
\ c-addr = player data address
/player * players +
;
variable offset
: [+offset] ( -- )
\ Compile the offset calculation.
offset @ case
0 of endof
1 of postpone 1+ endof
2 of postpone 2+ endof
offset @ postpone literal postpone +
endcase
1 offset +!
; immediate
0 offset !
: x ( u -- c-addr ) player [+offset] ;
: y ( u -- c-addr ) player [+offset] ;
: xi ( u -- c-addr ) player [+offset] ;
: yi ( u -- c-addr ) player [+offset] ;
: img ( u -- c-addr ) player [+offset] ;
: score ( u -- c-addr ) player [+offset] ;
: left-key ( u -- c-addr ) player [+offset] ;
: down-key ( u -- c-addr ) player [+offset] ;
: up-key ( u -- c-addr ) player [+offset] ;
: right-key ( u -- c-addr ) player [+offset] ;
: pitch ( u -- c-addr ) player [+offset] ;
: x@ ( u -- b ) x C@ ;
: x! ( b u -- ) x C! ;
: y@ ( u -- b ) y C@ ;
: y! ( b u -- ) y C@ ;
: xi@ ( u -- b ) xi C@ ;
: xi! ( b u -- ) xi C@ ;
: yi@ ( u -- b ) yi C@ ;
: yi! ( b u -- ) yi C! ;
: img@ ( u -- b ) img C@ ;
: img! ( b u -- ) img C! ;
: score@ ( u -- b ) score C@ ;
: score! ( b u -- ) score C! ;
: left-key@ ( u -- b ) left-key C@ ;
: left-key! ( b u -- ) left-key C! ;
: right-key@ ( u -- b ) right-key C@ ;
: right-key! ( b u -- ) right-key C! ;
: up-key@ ( u -- b ) up-key C@ ;
: up-key! ( b u -- ) up-key C! ;
: down-key@ ( u -- b ) down-key C@ ;
: down-key! ( b u -- ) down-key C! ;
: pitch@ ( u -- b ) pitch C@ ;
: pitch! ( b u -- ) pitch C! ;
: future-position ( u -- x y )
\ Return the future position of a player.
\ u = number of player
>r r@ xi@ r@ x@ +
r@ yi@ r> y@ +
;
\ ..................................................................
\ Keys
char e value abort-key
\ System dependent cursor codes:
258 constant cursor-right
256 constant cursor-up
257 constant cursor-down
259 constant cursor-left
: cursor ( -- u1 u2 u3 u4 )
\ u1 = right key code
\ u2 = up key code
\ u3 = down key code
\ u4 = left key code
cursor-right cursor-up cursor-down cursor-left
;
: qwerty-left ( -- u1 u2 u3 u4 )
\ Keys to play on the left of a QWERTY keyboard.
\ u1 = right key code
\ u2 = up key code
\ u3 = down key code
\ u4 = left key code
[char] x [char] q [char] a [char] c
;
: es-qwerty-right ( -- u1 u2 u3 u4 )
\ Keys to play on the right of a Spanish QWERTY keyboard.
\ u1 = right key code
\ u2 = up key code
\ u3 = down key code
\ u4 = left key code
[char] , [char] p [char] <f1> [char] .
;
: es-dvorak-left ( -- u1 u2 u3 u4 )
\ Keys to play on the left of a Spanish Dvorak keyboard.
\ u1 = right key code
\ u2 = up key code
\ u3 = down key code
\ u4 = left key code
[char] q [char] a [char] . [char] j
;
: keys! ( u1 u2 u3 u4 u5 -- )
\ u1 = right key code
\ u2 = up key code
\ u3 = down key code
\ u4 = left key code
\ u5 = player
dup >r left-key!
r@ down-key!
r@ up-key!
r> right-key!
;
\ ..................................................................
\ Player data
cursor 0 keys! \ player 0 keys
char <95> 0 img!
100 0 pitch!
es-dvorak-left 1 keys! \ player 1 keys
char * 1 img!
100 0 pitch!
\ ..................................................................
\ Game data
3 constant init-score
\ ..................................................................
\ Screen
: .scores ( -- )
0 dup at-xy
#players 0 do
." Player " I . ." (" I img@ emit ." ): " I score@ . SPACE
loop
;
: crash ( x y -- )
\ Make an awesome 2D visual crash effect at x y...
8 0 do
2dup at-xy [char] \ emit 1 100 beep
2dup at-xy [char] | emit 1 200 beep
2dup at-xy [char] / emit 1 300 beep
2dup at-xy [char] - emit 1 400 beep
loop
2drop
;
: player-sound ( u -- )
\ Make the sound of a player.
\ u = player number
pitch@ 1 SWAP beep \ system dependent
;
: .player ( u -- )
\ Print one player.
\ u = number of player
dup >r img@ r@ x@ r@ y@ plot
r> player-sound
;
: .players ( -- )
\ Print all players.
#players 0 do
I .player
loop
;
\ ..................................................................
\ Collisions
: collision ( u x y -- )
\ Make a collision effect and decrement the score of the player.
\ x y = collision coordinates
\ u = player number
crash score -1 C+!
;
: collision? ( u -- flag )
\ Is the future screen position of a player already occupied?
\ If so, show it and decrement its score.
\ u = player number
dup future-position 2dup arena@
if collision true
else 2drop drop false
then
;
: collisions? ( -- flag )
\ Check possible collisions.
false
#players 0 do
I collision? OR
loop
;
\ ..................................................................
\ Arena limits
: out-of-arena? ( x y -- flag )
\ Is a screen position outside the arena?
2dup
0< swap 0< or >r
y-max > swap x-max > or
r> or
;
: outside? ( u -- flag )
\ Is the future position of a player outside the arena?
\ If so, show it and decrement its score.
\ u = number of player
dup future-position 2dup out-of-arena?
if collision true
else 2drop false
then
;
: outsides? ( -- flag )
\ Check possible outsides.
false
#players 0 do
I outside? or
loop
;
\ ..................................................................
\ Movement
: init-positions ( -- )
y-max 2 / dup
#players 0 do
I y!
loop
x-max 20 / dup 0 x!
x-max swap - 1 x!
1 0 xi ! 0 0 yi ! \ init direction
-1 1 xi ! 0 1 yi ! \ init direction
;
: steer-player ( b u -- )
\ b = key presed
\ u = player number to check
to player
case
player down-key@ of 0 player xi ! 1 player yi ! endof
player up-key@ of 0 player xi ! -1 player yi ! endof
player left-key@ of -1 player xi ! 0 player yi ! endof
player right-key@ of 1 player xi ! 0 player yi ! endof
endcase
;
: steer ( -- )
key?
if key else false then
dup abort-key = abort" Game aborted"
#players 0 do
dup i steer-player
loop
;
: update-positions ( -- )
#players 0 do
i xi@ i x C+!
i yi@ i y C+!
loop
;
\ ..................................................................
\ Round
: init-round ( -- )
page clear-arena init-positions .scores
;
: round ( -- )
init-round
begin
steer
collisions? 0= outsides? 0= and
while
update-positions .players
repeat
.scores
;
\ ..................................................................
\ Game
: game-over? ( -- f )
false
#players 0 do
i score@ 0= or
loop
;
: init-scores ( -- )
#players 0 do
init-score i score!
loop
;
: init-game ( -- )
init-scores
10 5 2dup at-xy ." Press SPACE to play"
key bl <> if quit then
at-xy 18 spaces
;
: game ( -- )
init-game
begin
round game-over?
until
cr ." GAME OVER"
;
\ ..................................................................
\ Instructions
: .key ( b -- )
\ b = key
space
case
cursor-left of ." Cursor " endof
cursor-down of ." Cursor " endof
cursor-up of ." Cursor " endof
cursor-right of ." Cursor " endof
dup emit
endcase
[char] , emit space
;
: .player-keys ( u -- )
\ Print keys of a player.
\ u = player number.
cr >r ." Player " r@ .
." (" r@ img@ emit ." ): "
r@ left-key@ .key ." Left"
r@ down-key@ .key ." Down"
r@ up-key@ .key ." Up"
r> right-key@ .key ." Right"
;
: .keys ( -- )
cr abort-key emit ." Abort"
#players 0 do
i .player-keys
loop
;
: instructions ( -- )
page
." Tron 5mx" cr
." ********"
.keys
;
\ ..................................................................
\ Start
: tron ( -- )
instructions game
;
cr .( Type TRON to start. )