J. Caparace

Descripción del contenido de la página

Juego escrito en Ace Forth para Jupiter Ace.

Proyecto durmiente. Iniciado en 2009-05-25. 70% completado.

Etiquetas:

Este proyecto de juego para Jupiter ACE, al igual que Bertie's face, está muy avanzado, pero lleva tiempo aparcado en espera de la evolución del emulador xAce.

Código fuente




: task ;

: \  0 word drop  ;  immediate
: (  begin  ascii ) word c@ 31 =  while  retype  repeat  ;  immediate

\ "J. Caparace"
\ A game for the Jupiter Ace

\ Copyright (C) 2009,2010 Marcos Cruz (programandala.net)
\ License: http://programandala.net/license

\ UNFINISHED. UNDER DEVELOPMENT.

\ History:

\ 2009-05-25 First draft version.
\ 2010-01-09 Some bugs fixed. Many improvements.
\ 2010-01-10 Many improvements and changes.
\ 2010-01-11 Many improvements and changes. First version of the scenery graphics.
\ 2010-01-12 Many improvements.
\ 2010-01-22 Record. Whole on the ceiling for the egss. Changes in the code.
\ 2010-01-25 Some fixes and changes.

\ Todo:

\ Caparace graph.
\ 6 egg graphs, in array, indexed by xi and yi.
\ chain graph for the floor.
\ Better first screen.
\ Options configurable by the user: sound on/off, keys.

\ Bugs:

\ When the egg falls down parallel to the left wall and it bounces to the left wall, it breaks the wall!

forth definitions  decimal

\ System addresses

11264 constant 'charset
15398 constant KEYCOD
15403 constant FRAMES
15422 constant FLAGS

\ Pseudo random number generator
\ (as of 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 !
  ;

\ Common use words

: s>d  ( n -- d )  dup 0< negate  ;
: 2dup  ( n1 n2 -- n1 n2 n1 n2 )  over over  ;
: +!  ( n a -- )  swap over @ + swap !  ;
: bounds  ( ca1 u -- ca2 ca3 )  over + swap  ;
: cmove  ( ca0 ca1 u -- )  bounds  do  dup c@ i c! 1+  loop  drop  ;

\  Common ad-hoc words

\ : *!  ( a n -- )  
\  over @ * swap !  
\  ;
: negate!  ( a -- )
  dup @ negate swap !
  ;
: -?dup  ( f -- 1 | 0 0 )  \ Duplicate flag if it's zero.
  dup 0=  if  0  then
  ;
: 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=
  ;
\ : flip_input_buffer  
  \ Reference: Forth User #1, page 15.
\  FLAGS c@ 8 xor FLAGS c!  
\  ;

\ Keyboard

: pause  ( -- )
  begin  inkey  until
  ;
: key  ( -- c )
  begin  inkey ?dup  until
  ;
: pressed?  ( c -- f )
  inkey =
  ;
: last_key  ( -- c )
  KEYCOD c@
  ;
\ : >lower  ( c1 -- c2 )  
\  32 or  
\  ; 
: >upper  ( c1 -- c2 )
  [ 255 32 - ] literal and
  ;
\ : >case<  ( c1 -- c2 )  
\  32 xor  
\  ;
\ : letter?  ( c -- f )  \ todo !!!
\  >upper ascii A swap ascii Z between? 
\  ;
\ : letter_key=  ( c1 c2 -- f )  \ todo !!!
\  over = swap ascii y = or 0=  
\  ;
\ : key=  ( c1 c2 -- f )  \ todo !!! unfinished
\  over = swap ascii y = or 0=  
\  ;
: y/n  ( -- f )
  begin
    key >upper dup  ascii Y =
    if  drop 2
    else  ascii N =
    then  ?dup
  until  1-
  ;

\ Arena

1 constant left_limit
30 constant right_limit
2 constant top_limit
21 constant bottom_limit

\ Egg config

0 variable x
0 variable y
1 variable xi
1 variable yi
ascii O constant egg_char

\ JC config

1 variable jc_x
bottom_limit constant jc_y
8 128 + constant jc_char

\ Graphics

: 'char  ( c -- a )
  8 * 'charset +
  ;
\ : char!  ( b0...b7 c -- )  
\  'char dup 8 +  do  i c! -1  +loop  
\  ;
: graph>char  ( ca c -- )
  'char 8 cmove
  ;
\ : char>char  ( c0 c1 -- )  
\  swap 'char swap graph>char 
\  ;

base c@  2 base c!

create left_brick_graph
  00000001 c,
  00000001 c,
  00000001 c,
  11111110 c,
  00000010 c,
  00000010 c,
  00000010 c,
  11111110 c,
create right_brick_graph
  01000000 c,
  01000000 c,
  01000000 c,
  01111111 c,
  10000000 c,
  10000000 c,
  10000000 c,
  01111111 c,
create top_brick_graph
  11011111 c,
  00100000 c,
  00100000 c,
  11011101 c,
  00000010 c,
  00000010 c,
  00000010 c,
  11111101 c,
create floor_brick_graph
  10101010 c,
  00000000 c,
  00000000 c,
  00000000 c,
  00000000 c,
  00000000 c,
  00000000 c,
  00000000 c,

base c!

4 constant jc_lenght
create jc_shape  jc_lenght allot
20 128 + c,  19 c,  19 c, 23 c,

\ : jc_shape!  ( -- ) 
\  jc_shape  jc_lenght 0 do  jc_char over c! 1+  loop  drop  
\  ;
\ jc_shape!  forget jc_shape!

1 constant left_brick
2 constant right_brick
3 constant top_brick
4 constant floor_brick

: init_graphs  ( -- )
  left_brick_graph left_brick graph>char
  right_brick_graph right_brick graph>char
  top_brick_graph top_brick graph>char
  floor_brick_graph floor_brick graph>char
  ;

\ Game config

1024 variable delay#
1024 constant max_delay# \ todo !!! not used yet

ascii r constant left_key
ascii t constant right_key

0 constant sound?

\ Sound

: bounce_beep  ( -- )
  sound?  if  30 10 beep  then
  ;
: crash_beep  ( -- )
  sound?  if
    10 1 do  i 10 * i 15 * beep  loop
  then
  ;

\ Score

0 variable score
0 variable record

: .000  ( n -- )
  s>d <# # # # #> type
  ;
: .score  ( -- )
  0 dup at ." Score: " score @ .000
  ;
: +score  ( -- )
  1 score +!  .score
  ;
: .record  ( -- )
  0 21 at ." Score: " record @ .000
  ;
: +record  ( -- )
  score @ record @ >
  if  score @ record ! .record  then
  ;

\ JC

right_limit 1+ jc_lenght - constant jc_right_limit

: jc_right_x  ( -- u )
  jc_x @ jc_lenght + 1-
  ;
: at_jc  ( -- )
  jc_y jc_x @ at
  ;
: .jc  ( -- )
  at_jc  jc_shape jc_lenght type
  ;
: -jc  ( -- )
  at_jc jc_lenght spaces
  ;
: <jc>  ( n -- )  \ Move JC n columns.
  -jc jc_x +! .jc
  ;
: <jc  ( -- )  \ Move JC to the left if possible.
  jc_x @ left_limit >  if  -1 <jc>  then
  ;
: jc>  ( -- )  \ Move JC to the right if possible.
  jc_x @ jc_right_limit <  if  1 <jc>  then
  ;
: jc  ( -- )
  left_key pressed?
  if  <jc
  else  right_key pressed? if  jc>  then
  then
  ;

\ Egg

: >xi<  ( -- )  \ Change the egg's x increment in order to bounce.
  xi @ 3 rnd 1- +  1 min -1 max  xi !
  ;
: >yi<  ( -- )  \ Change the egg's y increment in order to bounce.
  yi negate!
  ;
: x_bounce  ( -- )  \ Bounce the egg if it touches a wall.
  x @ left_limit over = swap right_limit = or
  if  xi negate!  bounce_beep  then
  ;
: y_bounce_up  ( -- )  \ Bounce the egg if it touches the ceiling.
  top_limit y @ =
  if  >yi< >xi< bounce_beep  then
  ;
: on_jc?  ( -- f )  \ Is the egg on JC?
  jc_y 1- y @ = -?dup
  if  jc_x @ x @ jc_right_x between?
  then
  ;
: y_bounce_down  ( -- )  \ Bounce the egg if it touches JC.
  on_jc?  if  >yi< >xi< bounce_beep +score  then
  ;

\ create (y_bounce_vectors)
\ find y_bounce_up ,
\ find y_bounce_down ,
\ (y_bounce_vectors) 1+ constant y_bounce_vectors
\ : y_bounce  y_bounce_vectors yi @ + @ execute  ;

: y_bounce  ( -- )  \ Bounce the egg vertically.
  yi @ 1 =
  if  y_bounce_down
  else  y_bounce_up
  then
  ;
: at_egg  ( -- )
  y @ x @ at
  ;
: .egg  ( -- )
  at_egg egg_char emit
  ;
: <egg>  ( -- )  \ Update the egg's coordinates.
  x_bounce  xi @ x +!
  y_bounce  yi @ y +!
  ;
: -egg  ( -- )
  at_egg space
  ;
: egg  ( -- )
  -egg <egg> .egg
  ;

\ : touched?  ( -- f )
\  y @ jc_y 1- =
\  if
\    jc_x @  x @  over jc_lenght 1- +  between?
\  else
\    0
\  then
\  ;

\ End conditions

: crash?  ( -- f )
  y @ bottom_limit =
  ;
: end?  ( -- f )
  crash? dup  if  crash_beep  then
  ;

\ Scenery

: center  ( -- u )
  right_limit left_limit - 2 / 2+
  ;
: hole_yx  ( -- y x )
  top_limit 1- center
  ;
: at_hole  ( -- )
  hole_yx at
  ;
: .hole  ( -- )
  at_hole space
  ;
: .sides  ( c y x -- )
  2dup  right_limit 1+ swap -
  at 3 pick emit  at emit
  ;
: .ceiling  ( -- )
  top_limit 1-  \ line
  center 0
  do  top_brick over i .sides  loop  drop
  ;
: .floor  ( -- )
  bottom_limit 1+  \ line
  center 0
  do  floor_brick over i .sides  loop  drop
  ;
: .walls  ( -- )
  bottom_limit top_limit 1- - 0
  do
    bottom_limit i - dup
    left_limit 1- at left_brick emit
    right_limit 1+ at right_brick emit
  loop
  ;
: .scenery  ( -- )
  .floor .walls .ceiling .hole
  ;

\ Init

: init_egg  ( -- )
  hole_yx x ! y !  0 xi ! 1 yi !
  ;
: init_jc  ( -- )
  32 jc_lenght - 2 / jc_x !
  ;
: init_screen  ( -- )
  invis cls init_graphs
  ;
: init_round  ( -- )
  init_screen init_jc init_egg  0 score ! .scenery
  ;

\ Speed

: delay  ( -- )
  delay# @ 0  do loop
  ;
: faster  ( -- )   \ todo !!! experimental, not used yet
  delay# @ 1- 1 max delay# !
  ;
: slower  ( -- )  \ todo !!! experimental, not used yet
  delay# @ 1+ max_delay# min delay# !
  ;

\ Text screens

: ----  ( -- )
  ." --------------------------------"
  ;
: about  ( -- )
  ." J. Caparace" cr
  cr
  ." Copyright (C) 2009,2010:" cr
  ." Marcos Cruz" cr
  ." (http://programandala.net)" cr
  ." License:" cr
  ." http://programandala.net/license" cr
  ;
: .key  ( c -- )
  cr emit ." : "
  ;
: instructions  ( -- )
  ." Keys:"
  left_key .key ." left"
  right_key .key ." right"
  cr
  ;
: start_screen  ( -- )
  init_screen
  ---- about ---- instructions ----
  ;
: .start  ( -- )
  cr ." Type RUN to start."
  ;

\ Main

: end  ( -- )
  vis .start
  ;
: finish?  ( -- f )
  10 7 at ." Play again? (Y/N)" y/n 0=
  ;
\ : .debug  ( -- )
\  0 dup at
\  ." x=" x @ . ." (" xi @ .
\  ." ) y=" y @ . ." (" yi @ .
\  ." ) outside?=" left_limit x @ right_limit outside? .
\  ; \ !!! debug
: round  ( -- )
  init_round  .jc
  begin
    egg delay jc  end?
  until
  ;
: run  ( -- )
  begin
    start_screen pause  round  finish?
  until  end
  ;

save j_caparace
.start

Páginas relacionadas

Bertie's face
Juego escrito en Ace Forth para Jupiter Ace.