Bertie's face
Descripción del contenido de la página
Juego escrito en Ace Forth para Jupiter Ace.
Proyecto durmiente. Iniciado en 2010-01-12. 90% completado.
Etiquetas:
Este proyecto es una versión de Bertie para Jupiter ACE y, al igual que J. Caparace, está muy avanzado, pero lleva tiempo aparcado en espera de la evolución del emulador xAce.
Código fuente
: task ;
: \ 0 word drop ; immediate
\ Bertie's face
\ A game for the Jupiter ACE
\ UNFINISHED PROJECT. UNDER DEVELOPMENT.
\ This is a port of "Bertie",
\ the demo game bundled with Abersoft Forth
\ for the Sinclair ZX Spectrum.
\ Copyright (C) 2010,2013 Marcos Cruz (programandala.net)
\ License: http://programandala.net/license
\ History:
\ 2010-01-12 First changes in the original code. Pseudo sprites words.
\ 2010-03-03 Many changes, much factoring and fewer control structures to make the code tidier and simpler.
\ 2010-03-04 Many changes. GRAPH: and >AT ( renamed to >SPRITE_AT ) fixed because the sprites where shown upside down.
\ 2010-03-06 Fixes. First try to port the sound.
\ 2010-03-08 First try to use EVALUATE to init the shape actions table.
\ 2010-03-09 ON (renamed SELECT ) used instead of EVALUATE for managing the shape actions. It's much simpler.
\ 2010-03-11 High level version of SELECT used instead the assembler one.
\ Changes on the original version:
\ * No color ;)
\ * One bug fixed: one shape movement was affected in the 4th maze.
\ * No extra points depending on the time passed in every maze.
\ * Fixed two missing pixels of the shape 2 (X).
\ To do:
\ finish the word SHAPE_OK?
\ fix original bug: Shape 1 doesn't move in maze 4.
\ Trick to print at the bottom of the screen (tried in my game J. Caparace).
\ Test the sound.
\ Record?
\ Move sprites by 1 char position?
\ uniform lowercase or uppercase in comments
\ fix original bug: the shapes can destroy the key
\ ------------------------------
\ System variables and addresses
08192 constant 'screen
11264 constant 'charset
\ 15388 constant SCRAPS
15396 constant L_HALF
15403 constant FRAMES
15407 constant XCOORD
15408 constant YCOORD
\ 15422 constant FLAGS
\ ------------------------------
\ Arena
31 constant max_x
22 constant max_y
63 constant max_gx
45 constant max_gy
max_x 1+ constant columns
\ ------------------------------
\ Common words
: ( ascii ) word drop ; immediate
0 constant false
false 0= constant true
: off ( a -- ) false swap ! ;
: on ( a -- ) true swap ! ;
32 constant bl \ space char
: bounds ( a1 u -- a2 a3 ) over + swap ;
: cmove ( a0 a1 u -- ) bounds do dup c@ i c! 1+ loop drop ;
: +! ( n a -- ) swap over @ + swap ! ;
\ : s>d ( n -- d ) dup 0< negate ;
\ : u>ud ( u -- ud ) 0 ;
: d= ( d1 d2 -- f ) rot = >r = r> and ;
: 2drop ( x1 x2 -- ) drop drop ;
: 2dup ( x1 x2 -- x1 x2 x1 x2 ) over over ;
: r@ ( --- x ) r> r> dup >r swap >r ;
\ : <> ( x1 x2 -- f ) = 0= ;
: key ( -- c ) begin inkey ?dup until ;
: binary ( -- ) 2 base c! ;
\ : count ( a1 -- a2 u ) dup 1+ swap c@ ;
\ : compile ( -- ) begin find dup dup 0= if drop retype then until , ;
\ : [compile] ( <word > -- ) compile ; immediate
\: place ( a1 u1 a2 -- ) 2dup c! 1+ swap cmove ;
\ -----------------------------
\ General ad hoc words
\ : tab ( u -- ) SCRAPS @ - 31 and spaces ;
: frames+ ( n1 -- n2 ) FRAMES @ + ;
: frames< ( n -- f ) FRAMES @ < ;
: delay ( n -- ) \ waits for n 50ths of second
frames+
begin dup frames<
until drop
;
: (pause) ( n -- ) \ wait for n 50ths of second or until a key is pressed
frames+
begin dup frames< inkey or
until drop
;
: pause ( n -- ) \ wait for n 50ths of second (or forever if n=0) or until a key is pressed
?dup if (pause) else key drop then
;
: inverse ( c1 -- c2 ) 128 xor ;
: 'char ( c -- a ) 8 * 'charset + ;
: graph>addr ( a1 a2 -- ) 8 cmove ;
: graph>char ( a c -- ) 'char graph>addr ;
: 'at ( y x -- a ) swap columns * + 'screen + ;
: at_c@ ( y x -- c ) 'at c@ ;
\ : halfway ( n1 n2 -- n3 ) - 2 / ;
: lowercase ( c1 -- c2 ) [ binary 100000 decimal ] literal or ;
: y/n= ( c1 -- c2 f ) lowercase dup ascii y = over ascii n = or ;
: y/n ( -- c ) 0 begin drop inkey y/n= until ;
: yes? ( -- f ) y/n ascii y = ;
\ : no? ( -- f ) y/n ascii n = ;
: outside? ( n1 n2 n3 -- f ) \ Is n2 less than n1 or greater than n3?
over swap > >r > r> or
;
: between? ( n1 n2 n3 -- f ) \ Is n3 >= n2 >= n1?
outside? 0=
;
: even ( n1 -- n1 | n2 )
[ binary 1111111111111110 decimal ] literal and
;
\ By dulac and Acey:
\ http://jupiterace.proboards.com/index.cgi?action=gotopost&board=programmingaceforth&thread=220&post=925
: select dup + r> + @ execute ;
\ ------------------------------
\ Pseudo random number generator
\ (after the Jupiter Ace manual)
0 variable seed
: seedon ( -- n )
seed @ 75 u* 75 0 d+ over over u< - - 1- dup seed !
;
: rnd ( n1 -- n2 ) seedon u* swap drop ;
: randomize ( n -- ) ?dup 0= if FRAMES @ then seed ! ;
\ ------------------------------
\ Draw
\ (after the Jupiter Ace manual)
: step_sign ( n1 -- n2 )
\ n2 = -1 if n1<=0
\ n2 = 1 if n1>0
0> dup + 1 -
;
: step ( u1 u2 u3 u4 u5 u6 u7 x y -- u1 u2 u3 u4 u5 u6 u7 )
\ Take the two parts of a step, as left by diagonal_step or square_step
\ and uses them to plot the next point on the line.
YCOORD c@ + swap
XCOORD c@ + swap
9 pick plot
;
: diagonal_step ( u n1 n2 f n3 n4 n5 -- u n1 n2 f n3 n4 n5 x y )
\ Copy the two parts of a diagonal step to the top of the stack.
\ Both parts are 1 or -1.
\ n = plotting mode
\ n1 = the x part of a diagonal step (1 or -1)
\ n2 = the y part of a diagonal step (1 or -1)
\ f = 0 if x>y (a square step moves horizontally)
\ f = 1 if y>x (a square step moves vertically)
\ n3 = the larger of x and y
\ n4 = the smaller of x and y
\ n5 = ??
6 pick 6 pick
;
: square_step ( u n1 n2 f n3 n4 n5 -- u n1 n2 f n3 n4 n5 x y )
\ Copy the two parts of a diagonal step to the top of the stack.
\ One part is 0, the other is 1 or -1.
\ n = plotting mode
\ n1 = the x part of a diagonal step (1 or -1)
\ n2 = the y part of a diagonal step (1 or -1)
\ f = 0 if x>y (a square step moves horizontally)
\ f = 1 if y>x (a square step moves vertically)
\ n3 = the larger of x and y
\ n4 = the smaller of x and y
\ n5 = ??
4 pick
if 0 6 pick
else 6 pick 0
then
;
: (draw) ( ix iy n -- n n1 n2 f n3 n4 )
\ n = plotting mode
\ n1 = the x part of a diagonal step (1 or -1)
\ n2 = the y part of a diagonal step (1 or -1)
\ f = 0 if x>y (a square step moves horizontally)
\ f = 1 if y>x (a square step moves vertically)
\ n3 = the larger of x and y
\ n4 = the smaller of x and y
rot rot over step_sign over step_sign
4 roll abs 4 roll abs
over over <
rot rot 3 pick
if swap then
;
: draw ( ix iy n -- )
(draw) 2 pick dup 2 /
swap ?dup
if
0 do
over + dup 4 pick >
if 3 pick - diagonal_step
else square_step
then step
loop
then
drop drop drop drop drop drop drop
;
\ ------------------------------
\ Game config
ascii 5 constant left_key
ascii 6 constant down_key
ascii 7 constant up_key
ascii 8 constant right_key
ascii q constant quit_key
false variable sound?
\ ------------------------------
\ Graphics management
: 'char ( c -- a ) 8 * 'charset + ;
definer graph: ( u0 u1 u2 u3 u4 u5 u6 u7 -- )
0 8 do i roll c, -1 +loop
does> ( c -- ) ( run: c pfa -- )
swap graph>char
;
\ ------------------------------
\ Pseudo sprites management
2 constant rows/sprite
2 constant columns/sprite
rows/sprite columns/sprite * constant graphs/sprite
definer sprite: ( c4 c3 c2 c1 -- )
\ c1 = upper left char
\ c2 = upper rigth char
\ c3 = lower left char
\ c4 = lower rigth char
c, c, c, c,
\ More general alternative:
\ graphs/sprite 0
\ do c, loop
does> ( -- ) ( run: pfa -- )
;
: sprite@ ( a -- c1 c2 c3 c4 )
dup graphs/sprite + swap
do i c@ loop
;
\ : >sprite_at ( y x -- y1 x y x ) over 1+ swap rot over ;
\ : .sprite ( y x a -- ) >r >sprite_at at r@ .sprite_row at r> columns/sprite + .sprite_row ;
: >sprite_at ( y x -- y x y1 x ) over 1+ over ;
: .sprite_row ( a -- ) columns/sprite type ;
: .sprite ( y x a -- )
>r >sprite_at
at r@ columns/sprite + .sprite_row \ second row
at r> .sprite_row \ first row
;
: -sprite_row ( y x -- ) at columns/sprite spaces ;
: -sprite ( y x -- ) >sprite_at -sprite_row -sprite_row ;
\ ------------------------------
\ Graphics and pseudo sprites
\ The following graphic data has one space at the beginning of every line
\ because sometimes the first character of the line is not
\ interpreted. I don't know the cause.
\ Maybe it's a xace's issue when interpreting a defining word.
000 003 012 016 046 042 078 064 graph: <bertie_00_graph
000 192 048 008 116 084 114 002 graph: <bertie_01_graph
065 065 044 039 017 012 003 000 graph: <bertie_10_graph
130 130 052 228 136 048 192 000 graph: <bertie_11_graph
000 000 000 000 000 000 000 001 graph: <key_00_graph
000 028 054 034 054 124 224 192 graph: <key_01_graph
003 007 014 028 056 052 008 000 graph: <key_10_graph
128 000 000 000 000 000 000 000 graph: <key_11_graph
255 255 252 248 240 240 248 252 graph: <lock_00_graph
255 255 063 031 015 015 031 063 graph: <lock_01_graph
254 254 252 252 248 240 255 255 graph: <lock_10_graph
127 127 063 063 031 015 255 255 graph: <lock_11_graph
000 007 007 007 007 127 127 127 graph: <shape1_00_graph
000 224 224 224 224 254 254 254 graph: <shape1_01_graph
127 127 127 007 007 007 007 000 graph: <shape1_10_graph
254 254 254 224 224 224 224 000 graph: <shape1_11_graph
000 008 028 062 127 063 031 015 graph: <shape2_00_graph
000 016 056 124 254 252 248 240 graph: <shape2_01_graph
015 031 063 127 062 028 008 000 graph: <shape2_10_graph
240 248 252 254 124 056 016 000 graph: <shape2_11_graph
170 085 170 085 170 085 170 085 graph: <block_graph
30 constant block_char
001 002 003 004 sprite: bertie_sprite
005 006 007 008 sprite: key_sprite
009 010 011 012 sprite: lock_sprite
014 015 024 025 sprite: shape1_sprite
026 027 028 029 sprite: shape2_sprite
block_char dup dup dup sprite: block_sprite
: init_bertie_sprite ( -- )
bertie_sprite sprite@
<bertie_11_graph <bertie_10_graph <bertie_01_graph <bertie_00_graph
;
: init_key_sprite ( -- )
key_sprite sprite@
<key_11_graph <key_10_graph <key_01_graph <key_00_graph
;
: init_lock_sprite ( -- )
lock_sprite sprite@
<lock_11_graph <lock_10_graph <lock_01_graph <lock_00_graph
;
: init_shape1_sprite ( -- )
shape1_sprite sprite@
<shape1_11_graph <shape1_10_graph <shape1_01_graph <shape1_00_graph
;
: init_shape2_sprite ( -- )
shape2_sprite sprite@
<shape2_11_graph <shape2_10_graph <shape2_01_graph <shape2_00_graph
;
: init_block_sprite ( -- )
block_sprite c@ <block_graph
;
: init_sprites ( -- )
init_bertie_sprite
init_key_sprite init_lock_sprite
init_shape1_sprite init_shape2_sprite
init_block_sprite
;
\ ------------------------------
\ Sound
\ The Abersofth Forth's manual says its word BLEEP works in a different
\ way from the Sinclair Basic's BEEP, but doesn't explain what's the difference!
\ I found the information I needed in the book "Advanced Spectrum FORTH", by Don Thomasson:
\ http://programandala.net/es.art%C3%ADculo.2009.04.27.libros_forth#advancedspectrumforth
\ http://www.worldofspectrum.org/infoseekid.cgi?id=2000024
\ On page 26, I read the following about the BLEEP's parameters:
\ To generate a frequency of F Hertz, TOS must be set to:
\ TOS = (437500/F) -30
\ Looking in the opposite direction:
\ F = 437500/(TOS + 30)
\ The duration of the note is determined as a number of cycles, so 2OS must be
\ set to F x T, where T is the duration is seconds.
: pitch>hertzs ( n1 -- n2 )
30 + 437500 swap u/mod swap drop
;
: duration>ms ( n1 n2 -- n3 )
\ n1 = hertzs
\ n2 = duration (hertzs*seconds)
\ n3 = milliseconds
swap / 1000 *
;
: bleep>beep ( n1 n2 -- n3 n4 ) \ translate the Abersoft Forth BLEEP's parameters to the Ace Forth BEEP's parameters
\ n1 = duration: hertzs*seconds
\ n2 = pitch: (437500/hertzs) - 30
\ n3 = hertzs
\ n4 = milliseconds
pitch>hertzs dup rot duration>ms
;
: bleep ( n1 n2 -- )
sound? @ if bleep>beep beep else 2drop then
;
: tune1 ( -- )
1000 500 do 10 i bleep 50 +loop
;
: tune2 ( -- )
500 1000 do 10 i bleep i -5 / +loop
;
: tune3 ( -- )
1500 500 do 50 i bleep 100 +loop
400 600 do 30 i bleep -25 +loop
10 0 do tune2 loop
;
: tune4 ( -- )
5 0 do tune1 tune2 loop
;
: tune5 ( -- )
10 0 do tune1 loop
;
\ ------------------------------
\ Game variables and constants
0 variable have_key?
1 variable maze
0 variable score
3 constant max_lives
max_lives variable lives
10 constant key_points
100 constant unlock_points
\ ------------------------------
\ Status
max_y constant status_y
: status_at ( x -- ) status_y swap at ;
: .maze# ( -- ) 5 status_at maze @ . ;
: ."maze" ( -- ) 0 status_at ." maze:" .maze# ;
: .lives ( -- ) 14 status_at lives @ . ;
: ."lives" ( -- ) 8 status_at ." lives:" .lives ;
: .score ( -- ) 23 status_at score @ . ;
: ."score" ( -- ) 17 status_at ." score:" .score ;
: .status ( -- ) ."maze" ."lives" ."score" ;
: score+ ( n -- ) score +! .score ;
\ ------------------------------
\ Bertie coords and printing
0 variable bertie_x
0 variable bertie_y
: bertie>home ( -- ) 0 bertie_x ! 0 bertie_y ! ;
: bertie_coords ( -- y x ) bertie_y @ bertie_x @ ;
: .bertie ( -- ) bertie_coords bertie_sprite .sprite ;
: -bertie ( -- ) bertie_coords -sprite ;
\ ------------------------------
\ Maze
6 constant max_maze
bl bl 256 * + constant 2bl
: 2bl? ( y x -- f ) \ are there two spaces at the given coords?
'at @ 2bl =
;
: empty? ( y x -- f ) \ is the area from (y,x) to (y+1,x+1) empty?
>sprite_at 2bl?
if 2bl?
else 2drop false
then
;
: >block_coord ( b1 -- b2 )
\ u1 = max coord
\ u2 = proper even coord
rnd even
;
: .block ( -- )
0 dup
begin
2drop
[ max_y 1- ] literal >block_coord
[ max_x 1- ] literal >block_coord
2dup empty?
until
block_sprite .sprite
;
: .blocks ( -- )
maze @ 5 * 5 + 0 do .block loop
;
0 variable key_x
16 constant key_y
: key_coords ( -- y x ) key_y key_x @ ;
: -key ( -- ) key_coords -sprite ;
: +key_coords ( -- y x ) key_y 8 rnd 2 * 4 + dup key_x ! ;
: .key ( -- )
begin
+key_coords empty?
until
key_coords key_sprite .sprite
;
0 variable lock_y
max_x 1- constant lock_x
: lock_coords ( -- y x ) lock_y @ lock_x ;
: +lock_coords ( -- y x ) lock_x 10 rnd 2 * dup lock_y ! swap ;
: .lock ( -- )
begin
+lock_coords empty?
until
lock_coords lock_sprite .sprite
;
: .maze ( -- )
cls .blocks .lock .key
;
: +maze ( -- )
tune4 40 delay 1 maze +!
bertie>home have_key? off
;
: init_maze ( -- )
.maze .status .bertie
;
\ ------------------------------
\ Shapes
0 variable shape1_x
0 variable shape1_y
0 variable shape2_x
0 variable shape2_y
: shape1_coords ( -- y x) shape1_y @ shape1_x @ ;
: shape2_coords ( -- y x) shape2_y @ shape2_x @ ;
: shape1_coords! ( y x -- ) shape1_x ! shape1_y ! ;
: shape2_coords! ( y x -- ) shape2_x ! shape2_y ! ;
\ : shapes_coords ( -- y1 x1 y2 x2 ) shape1_coords shape2_coords ;
\ : -shape1 ( -- ) shape1_coords -sprite ;
\ : -shape2 ( -- ) shape2_coords -sprite ;
\ : -shapes ( -- ) -shape1 -shape2 ;
: .shape1 ( -- ) shape1_coords shape1_sprite .sprite ;
: .shape2 ( -- ) shape2_coords shape2_sprite .sprite ;
\ : .shapes ( -- ) .shape1 .shape2 ;
: range! ( n1 n2 a -- ) \ limit the content of a variable to the specified range
\ n1 = min value
\ n2 = max value
dup @ 3 roll min 3 roll max swap !
;
max_x 1- constant shape_max_x
max_y 2- constant shape_max_y
: shapes_limits ( -- )
0 shape_max_x shape1_x range!
0 shape_max_y shape1_y range!
0 shape_max_x shape2_x range!
0 shape_max_y shape2_y range!
;
: +shape_y! ( a -- )
3 rnd 1 - 2 * swap +!
;
: shape_step! ( u a -- ) \ add 2 or -2 to the content of a variable (a shape's coordinate), depending on u (a bertie's coordinate)
dup >r @ > 4 * 2 - r> +!
;
: maze_1_shapes ( -- ) \ used for mazes 1 to 3
02 shape1_x ! shape1_y +shape_y!
28 shape2_x ! shape2_y +shape_y!
;
: maze>3_shapes ( -- ) \ common for all mazes>3
bertie_y @ shape2_y @ =
if 20 shape2_y ! then
FRAMES @ 3 mod 0=
if bertie_y @ shape2_y shape_step! then
bertie_x @ shape2_x shape_step!
;
: maze_4_shapes ( -- )
maze>3_shapes
16 shape1_x !
;
: maze>4_shapes ( -- ) \ common for all mazes>4
maze>3_shapes
bertie_y @ shape1_y shape_step!
;
: maze>5_shapes ( -- ) \ common for all mazes>5
maze>4_shapes
26 shape1_x !
bertie_x @ shape1_x shape_step!
;
: maze_5_shapes ( -- )
maze>4_shapes
;
: maze_6_shapes ( -- )
maze>5_shapes
;
\ !!! Obsolete version, with a vector table, S" and EVALUATE
\ A simpler version with SELECT was used.
\ create shapes_actions max_maze 2 * allot
\ : shape_action! ( cfa u -- )
\ 2 * shapes_actions + !
\ ;
\ : init_shapes_actions ( -- )
\ s" find maze_1_shapes" evaluate
\ dup 0 shape_action! dup 1 shape_action! 2 shape_action!
\ s" find maze_4_shapes" evaluate 3 shape_action!
\ s" find maze_5_shapes" evaluate 4 shape_action!
\ s" find maze_6_shapes" evaluate 5 shape_action!
\ ;
\ : (shapes) ( -- ) \ manage the shapes depending on the current maze
\ maze @ max_maze min 1- 2 * shapes_actions + @ execute
\ ;
: shape_ok? ( y x -- f )
\ todo !!! UNFINISHED
2dup at_c@
dup bl = dup 0=
if
drop block_char =
if 3 rnd 0=
else
then
then
swap drop
;
: (shapes) ( -- ) \ manage the shapes depending on the current maze
maze @ max_maze min 1-
select maze_1_shapes maze_1_shapes maze_1_shapes maze_4_shapes maze_5_shapes maze_6_shapes
;
: shapes ( -- )
shape1_coords shape2_coords \ save for later
(shapes) shapes_limits
shape2_coords shape_ok? if -sprite .shape2 else shape2_coords! then
shape1_coords shape_ok? if -sprite .shape1 else shape1_coords! then
;
\ ------------------------------
\ End
: center ( -- )
[ max_gx 1+ 2 / ] literal
[ max_gy 1+ 2 / ] literal
1 plot
;
: radius ( -- )
[ max_gx 1+ ] literal rnd [ max_gx 1+ 2 / ] literal -
[ max_gy 1+ ] literal rnd [ max_gy 1+ 2 / ] literal -
1 draw
;
: crash_effect ( -- )
16 dup rnd + 0 do center radius loop
;
: game_over
crash_effect 50 delay cls tune5
1 12 at ." GAME OVER"
5 9 at ." You scored " score @ .
7 7 at ." You reached maze " maze @ .
9 7 at ." To replay type RUN"
tune3 quit
;
: -lives ( -- )
-1 lives +! .lives
lives @ 0= if game_over then
;
: crash ( -- )
-lives
\ bertie>home \ todo !!! needed?
\ 18 shape2_y ! 28 shape2_x ! \ todo !!! needed?
50 delay .maze .bertie tune3
;
\ ------------------------------
\ Checks
\ : near? ( u1 u2 -- f ) - abs 2 < ;
\ : collision? ( y1 x1 y2 x2 -- f )
\ rot near? >r near? r> and
\ ;
: key_reached ( -- )
have_key? on tune1 key_points score+
-key .bertie
;
: (check_key) ( -- )
bertie_coords key_coords d=
if key_reached then
;
: check_key ( -- )
have_key? @ 0=
if (check_key) then
;
: unlock ( -- )
have_key? off unlock_points score+
+maze init_maze
;
: lock_reached ( -- )
have_key? @ if unlock else crash then
;
: check_lock ( -- )
bertie_coords lock_coords d=
if lock_reached then
;
: check_border ( -- )
0 bertie_y @ [ max_y 2- ] literal outside? if crash then
0 bertie_x @ [ max_x 1- ] literal outside? if crash then
;
: check_blocks ( -- )
bertie_coords at_c@ block_char = if crash then
;
: check_bertie ( -- ) \ todo !!!
check_border check_blocks
check_lock check_key
;
\ ------------------------------
\ Bertie movement
: down ( -- ) -bertie 2 bertie_y +! check_bertie .bertie ;
: left ( -- ) -bertie -2 bertie_x +! check_bertie .bertie ;
: right ( -- ) -bertie 2 bertie_x +! check_bertie .bertie ;
: up ( -- ) -bertie -2 bertie_y +! check_bertie .bertie ;
: quit_game ( -- ) quit vis ; \ todo !!!
0 variable pressed_key
: pressed? ( c -- f ) pressed_key @ = ;
: left_key? ( -- f ) left_key pressed? ;
: right_key? ( -- f ) right_key pressed? ;
: up_key? ( -- f ) up_key pressed? ;
: down_key? ( -- f ) down_key pressed? ;
: quit_key? ( -- f ) quit_key pressed? ;
: action ( c -- )
pressed_key !
left_key? if left else
right_key? if right else
up_key? if up else
down_key? if down else
quit_key? if quit_game
then then then then then
;
: bertie ( -- )
inkey action tune2
;
\ ------------------------------
\ Info
: .title ( -- )
." Bertie's face"
;
: any_key ( -- )
cr cr ." Press any key to continue." 50 delay 0 pause
;
: .about ( -- )
cr ." Copyright (C) 2010,2013 Marcos Cruz"
cr ." http://programandala.net"
cr ." License:"
cr ." http://programandala.net/license"
." Version: 2010-03-06"
;
: .object ( -- )
cr ." The object of the game is to"
cr ." gain as many points as"
cr ." possible by picking up the"
cr ." key and using it to unlock"
cr ." the door. But you must"
cr ." avoid the shapes which"
cr ." are trying to catch you."
cr ." At each new maze the shapes"
cr ." become more difficult to avoid."
;
: .control_key ( c -- )
cr 2 spaces inverse emit space
;
: .control_keys ( -- )
left_key .control_key ." left"
right_key .control_key ." right"
down_key .control_key ." down"
up_key .control_key ." up"
;
: .controls ( -- )
." Controls:" cr cr .control_keys
;
: .points ( u -- )
cr 2 spaces . ." points" cr
;
: .scores ( -- )
cr ." Scores:" cr
cr ." Picking up the key scores"
key_points .points
cr ." Unlocking the door scores"
unlock_points .points
cr ." If you complete a maze quickly"
." you will get bonus points"
cr ." depending on your time."
;
: .instructions ( -- )
cls .title cr .object any_key
cls .controls cr .scores any_key
;
: instructions
cls .title cr .about
9 2 at ." Do you want instructions?"
yes? if .instructions then
;
\ ------------------------------
\ Main
: init_coords ( -- )
bertie>home
\ 10 shape1_y ! 2 shape1_x ! \ todo !!! necessary?
\ 10 shape2_y ! 28 shape2_x ! \ todo !!! necessary?
;
: init ( -- )
0 randomize
1 maze ! max_lives lives ! score off have_key? off
init_coords init_sprites init_maze
;
: game ( -- )
begin
bertie shapes
false until
;
: run ( -- )
invis instructions init game
;
run