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