Bertie's face

Descripción del contenido de la página

[Proyecto durmiente:] 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


Páginas relacionadas

Bertie
Juego de demostración incluido en Abersoft Forth, formateado para facilitar su lectura y con unas pequeñas modificaciones.
J. Caparace
[Proyecto durmiente:] Juego escrito en Ace Forth para Jupiter Ace.