home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hall of Fame
/
HallofFameCDROM.cdr
/
game3
/
willy.lzh
/
WILLY.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1980-01-01
|
16KB
|
609 lines
program willy;
type namest = string[20];
scorec = record
sc:integer;
na:namest;
end;
var n,m,score,scrnum,balls,pcdlay,
oldx,oldy,worms,wx,wy,wc,
scount,bcount,bonus,vx,vy,updown,
wxdir,wydir,jcount,lfrt,
color1,color2,color3,color4,
color5,color6,maxballs : integer;
ballx,bally,ballc,balld : array[1..9] of integer;
hiscoreP,hiscoreT : array[1..10] of integer;
hinameP,hinameT : array[1..10] of namest;
startxy : array[1..64,1..2] of byte;
name : namest;
chrset : array[1..1024] of byte;
screendata : array[1..9,1..40,1..24] of byte;
startx,starty : array[1..8] of byte;
screen : array[1..40,1..24] of byte;
jflag,stop,win,lose,
soundflag : boolean;
key : string[1];
tableofs,tableseg : integer;
dfile : file;
scorefile : file of scorec;
element : scorec;
procedure setup;
var x,y,z:integer;
q:char;
begin
clrscr;
textcolor(white);
writeln(' Willy the Worm --- Ver. 2.0');
writeln(' by Alan Farmer, June 1985');
writeln;
writeln;
writeln(' This is a user-supported program. Feel free to make copies');
writeln(' and pass them out, but please do not sell them. Donations');
writeln(' of about $10 would be greatly appreciated. Please send your');
writeln(' questions, comments, high scores, improved game screens, and');
writeln(' DONATIONS to:');
writeln;
writeln(' Alan Farmer');
writeln(' 2743 McElroy Drive');
writeln(' Charlottesville, Va 22903');
tableofs:=memw[$0000:$007c];
tableseg:=memw[$0000:$007e];
memw[$0000:$007c]:=ofs(chrset[1]);
memw[$0000:$007e]:=seg(chrset[1]);
assign(dfile,'WILLY.CHR');
reset(dfile);
blockread(dfile,chrset,8);
close(dfile);
assign(dfile,'WILLY.DAT');
reset(dfile);
blockread(dfile,screendata,60);
blockread(dfile,startxy,1);
close(dfile);
assign(scorefile,'WILLY.SCR');
reset(scorefile);
for x:=1 to 10 do
begin
read(scorefile,element);
hiscoreP[x]:=element.sc;
hinameP[x]:=element.na;
end;
close(scorefile);
if mem[$f000:$fffe]=$fd then pcdlay:=0 else pcdlay:=25;
writeln;
writeln;
writeln;
write(' Are you using a color monitor? ');
repeat until keypressed;
read(kbd,q);
if upcase(q)='Y' then writeln('Yes') else writeln('No');
if upcase(q)='Y' then
begin
color1:=blue;
color2:=red;
color3:=yellow;
color4:=yellow;
color5:=lightcyan;
end
else
begin;
color1:=black;
color2:=lightgray;
color3:=lightgray;
color4:=white;
color5:=white;
end;
write(' Do you want sound effects? ');
repeat until keypressed;
read(kbd,q);
if upcase(q)='Y' then writeln('Yes') else writeln('No');
if upcase(q)='Y' then soundflag:=true else soundflag:=false;
for m:=1 to 10 do
begin
hiscoreT[m]:=0;
hinameT[m]:='';
end;
graphcolormode; palette(1); textcolor(3); graphbackground(color1);
gotoxy(13,4); writeln('Willy the Worm'); writeln; writeln;
writeln('Meet Willy the Worm ',chr(128),'. Willy is a fun-');
writeln('loving invertebrate who likes to climb');
writeln('ladders ',chr(131),', bounce on springs ',chr(133),' ',chr(134));
writeln('and find his presents ',chr(130),'. But more');
writeln('than anything, Willy loves to ring');
writeln('bells ',chr(136),'!');
writeln;
writeln('You can press the arrow keys ',chr(24),' ',chr(25),' ',chr(26),' ',
chr(27));
writeln('to make Willy run and climb, or the');
writeln('space bar to make him jump. Anything');
writeln('else will make Willy stop and wait.');
writeln;
writeln('Good luck, and don''t let Willy step on');
writeln('a tack ',chr(132),'!');
writeln;
write('Press Enter ',chr(17),chr(217),' to start the game...');
readln;
end;
procedure exit;
begin
memw[$0000:$007c]:=tableofs;
memw[$0000:$007e]:=tableseg;
assign(scorefile,'WILLY.SCR');
rewrite(scorefile);
for m:=1 to 10 do
begin
element.sc:=hiscoreP[m];
element.na:=hinameP[m];
write(scorefile,element);
end;
close(scorefile);
textmode;
clrscr;
halt;
end;
procedure winsound;
begin
gotoxy(13,10);
write('** Bonus ',bonus,' **');
if soundflag then for m:=1 to 5 do
begin
sound(2000);
delay(45);
nosound;
delay(30)
end;
delay(500)
end;
procedure losesound;
begin
if soundflag then
begin
for m:=1 to 5 do
begin
sound(220);
nosound;
delay(m)
end;
for m:=12 downto 1 do
begin
sound(2000);
nosound;
delay(m div 2)
end;
end;
for m:=1 to 20 do
begin
graphbackground(color2);
delay(pcdlay);
graphbackground(color3);
delay(pcdlay);
end;
graphbackground(color1);
end;
procedure getscreen;
var box : boolean;
begin
graphcolormode; palette(1); textcolor(3); graphbackground(color1);
box:=false;
for n:=1 to 24 do
for m:=1 to 40 do
begin
screen[m,n]:=screendata[scrnum,m,n];
gotoxy(m,n);
write(char(screen[m,n]));
if (screen[m,n]=254) and (not box) then
begin
box:=true;
vx:=m;
vy:=n;
end;
end;
wx:=startxy[scrnum,1];
wy:=startxy[scrnum,2];
wc:=32;
gotoxy(3,25);
write('Score ',score:6,' Bonus 1000 Worms ');
for n:=1 to worms-1 do write(chr(129))
end;
procedure addpoints(a : integer; b : boolean);
var c : integer;
begin
score:=score+a;
gotoxy(9,25);
write(score:6);
if b and soundflag then
begin
sound(1200);
delay(10);
sound(1660);
delay(10);
nosound
end;
scount:=scount+a;
if scount>3000 then
begin
scount:=scount-3000;
if soundflag then for c:=500 to 1500 do sound(c);
nosound;
worms:=worms+1;
gotoxy(35,25);
if worms>6 then
begin
for c:=1 to 5 do write(chr(129));
write('+');
end
else for c:=1 to worms-1 do write(chr(129))
end
end;
procedure movewilly;
var z : integer;
begin
delay(pcdlay);
z:=memw[$40:28];
z:=z-2;
if z<30 then z:=60;
key:=chr(mem[$40:z+1]);
case key of
#1 : exit;
'H' : updown:=-1;
'P' : updown:=1;
'9' : if (jcount=0) and (screen[wx,wy+1]>=179) and
(screen[wx,wy+1]<=218) and (screen[wx,wy]<>131) then
begin
updown:=0;
jcount:=1;
jflag:=true;
end;
'K' : begin
updown:=0;
lfrt:=-1;
end;
'M' : begin
updown:=0;
lfrt:=1;
end;
#$ff: begin end;
else
begin
updown:=0;
lfrt:=0;
end
end;
memw[$40:z]:=255 shl 8;
oldx:=wx; oldy:=wy;
wxdir:=lfrt;
wydir:=0;
if jcount>0 then
begin
case jcount of
1 : wydir:=-1;
2 : wydir:=-1;
3 : wydir:=-1;
4 : wydir:=0;
5 : wydir:=1;
6 : wydir:=1;
7 : wydir:=1;
end;
end;
if (jcount=0) and (screen[wx,wy]<>131) and ((screen[wx,wy+1]<179)
or (screen[wx,wy+1]>218)) then
begin
wxdir:=0;
wydir:=1
end;
if (updown<>0) and (jcount=0) and (screen[wx,wy]=131) then
begin
lfrt:=0;
if updown<>0 then wxdir:=0;
wydir:=0;
if (updown=-1) and (wy>1) then
if screen[wx,wy-1]=131 then wydir:=-1;
if (updown=1) and (wy<24) then
if (screen[wx,wy+1]<179) or (screen[wx,wy+1]>218) then wydir:=1;
end;
if (jcount>0) and (screen[wx,wy]=131) then
begin
jcount:=0;
lfrt:=0;
wxdir:=0;
wydir:=0
end;
if (jcount=0) and (lfrt=-1) then
if wx-1<1 then lfrt:=0
else if (screen[wx-1,wy]>=179) and (screen[wx-1,wy]<=218) then lfrt:=0;
if (jcount=0) and (lfrt=1) then
if wx+1>40 then lfrt:=0
else if (screen[wx+1,wy]>=179) and (screen[wx+1,wy]<=218) then lfrt:=0;
if (wx+wxdir<1) or (wx+wxdir>40) then wxdir:=0;
if (wy+wydir<1) or (wy+wydir>24) then wydir:=0;
if jcount>0 then jcount:=(jcount+1) mod 8;
if (wxdir<>0) and (screen[wx,wy+1]=196) then
begin
screen[wx,wy+1]:=32;
gotoxy(wx,wy+1);
write(' ')
end;
if (screen[wx+wxdir,wy+wydir]<179) or (screen[wx+wxdir,wy+wydir]>218) then
begin
wx:=wx+wxdir;
wy:=wy+wydir
end
else wydir:=0;
if (wydir<>0) and soundflag then sound((25-wy)*100);
gotoxy(oldx,oldy); write(chr(wc));
wc:=screen[wx,wy]; gotoxy(wx,wy);
if lfrt=1 then write(chr(128)) else write(chr(129));
nosound;
if jcount=0 then jflag:=false;
if wc=132 then lose:=true;
if wc=133 then
begin
jcount:=1;
jflag:=true;
end;
if wc=134 then lfrt:=-lfrt;
if wc=136 then win:=true;
if wc=130 then
begin
wc:=32;
screen[wx,wy]:=wc;
addpoints(100,true);
end;
end;
procedure moveballs;
var u,v : integer;
begin
if (random<0.1) and (balls<maxballs) then
begin
balls:=balls+1;
ballx[balls]:=vx;
bally[balls]:=vy;
balld[balls]:=0;
ballc[balls]:=254
end;
m:=(6-balls)*12;
if m>0 then delay(m);
for u:=1 to balls do
begin
gotoxy(ballx[u],bally[u]);
write(char(ballc[u]));
if balld[u]=0 then
begin
v:=screen[ballx[u],bally[u]+1];
if ((v<179) or (v>218)) and (bally[u]<24) then bally[u]:=bally[u]+1
else if random<0.5 then balld[u]:=-1 else balld[u]:=1
end;
if (balld[u]=-1) and (ballx[u]=1) then balld[u]:=1;
if (balld[u]=1) and (ballx[u]=40) then balld[u]:=-1;
if balld[u]=-1 then
begin
v:=screen[ballx[u]-1,bally[u]];
if (v>=179) and (v<=218) then balld[u]:=1
else ballx[u]:=ballx[u]-1
end;
if balld[u]=1 then
begin
v:=screen[ballx[u]+1,bally[u]];
if (v>=179) and (v<=218) then balld[u]:=-1
else ballx[u]:=ballx[u]+1
end;
v:=screen[ballx[u],bally[u]+1];
if (v<179) or (v>218) then balld[u]:=0;
ballc[u]:=screen[ballx[u],bally[u]];
if ballc[u]=254 then
begin
ballx[u]:=vx;
bally[u]:=vy;
balld[u]:=0
end;
gotoxy(ballx[u],bally[u]);
write(char(135));
if (balld[u]=-1) and (ballx[u]=1) then balld[u]:=1;
if (balld[u]=1) and (ballx[u]=40) then balld[u]:=-1;
end
end;
procedure collision;
procedure jumped_one;
begin
addpoints(20,true);
jflag:=false
end;
begin
for m:=1 to balls do
begin
if jflag then case jcount of
2,7 : if (ballx[m]=wx) and (bally[m]=wy+1) then jumped_one;
3,6 : if (ballx[m]=wx) and (bally[m]=wy+2) then jumped_one;
4,5 : if (ballx[m]=wx) and (bally[m]=wy+3) then jumped_one;
end;
if (ballx[m]=wx) and (bally[m]=wy) then lose:=true;
end;
end;
procedure playgame;
begin
scrnum:=1;
score:=0;
scount:=0;
worms:=5;
maxballs:=5;
repeat
balls:=0; bonus:=1000; bcount:=0;
lfrt:=0; updown:=0; jcount:=0;
lose:=false; win:=false;
getscreen;
repeat
bcount:=bcount+1;
if (bcount mod 15=0) then
begin
bonus:=bonus-10;
gotoxy(23,25);
write(bonus:4)
end;
if bonus=0 then lose:=true;
movewilly;
collision;
if not lose then moveballs;
if not lose then collision;
until win or lose;
if win then
begin
addpoints(bonus,false);
scrnum:=scrnum+1;
if scrnum=9 then
begin
scrnum:=1;
maxballs:=maxballs+2;
if maxballs>9 then maxballs:=9;
end;
winsound
end;
if lose then
begin
worms:=worms-1;
losesound;
end;
until worms=0
end;
procedure showscores;
var q:char;
a,b:integer;
begin
a:=-1; b:=-1;
textmode(c40);
textbackground(color1);
textcolor(white);
clrscr;
if score>hiscoreP[10] then writeln('You''re an Official Nightcrawler!')
else if score>hiscoreT[10] then writeln('You''re a Daily Pinworm!');
writeln;
writeln('Your score for this game is ',score,'...');
if score<1000 then writeln('Didn''t you even read the instructions?')
else if score<2000 then writeln('If you can''t say anything nice... ')
else if score<3000 then writeln('Okay. Maybe you''re not so bad after all.')
else if score<4000 then writeln('Wow! Absolutely mediocre!')
else if score<5000 then writeln('Pretty darn good, for a vertebrate!')
else if score<6000 then writeln('Well done! Do you often eat garbage?')
else writeln('Absolutely fantastic! You should consider a career as an earthworm!');
if score>hiscoreT[10] then
begin
writeln;
write('Enter your name >> ');
readln(name);
m:=1;
while (m<10) and (score<hiscoreT[m]) do m:=m+1;
a:=m+13;
for n:=10 downto m+1 do
begin
hiscoreT[n]:=hiscoreT[n-1];
hinameT[n]:=hinameT[n-1];
end;
hiscoreT[m]:=score;
hinameT[m]:=name;
if score>hiscoreP[10] then
begin
m:=1;
while score<hiscoreP[m] do m:=m+1;
b:=m+1;
for n:=10 downto m+1 do
begin
hiscoreP[n]:=hiscoreP[n-1];
hinameP[n]:=hinameP[n-1];
end;
hiscoreP[m]:=score;
hinameP[m]:=name;
end;
end
else
begin
writeln;
write('Press any key... ');
repeat until keypressed
end;
clrscr;
window(6,2,35,11);
textbackground(black);
clrscr;
window(6,14,35,23);
clrscr;
window(1,1,40,25);
textcolor(color4);
textbackground(color1);
gotoxy(10,1);
write('All-Time Nightcrawlers');
textcolor(color5);
gotoxy(10,13);
write('Today''s Best Pinworms');
textcolor(color4);
textbackground(black);
for m:=1 to 10 do
begin
gotoxy(6,m+1);
write(m:2,' ',hiscoreP[m]:6,' ',hinameP[m]);
end;
textcolor(color5);
for m:=1 to 10 do
begin
gotoxy(6,m+13);
write(m:2,' ',hiscoreT[m]:6,' ',hinameT[m]);
end;
textcolor(white+blink);
textbackground(color1);
if a>0 then
begin
gotoxy(5,a);
write(chr(26));
end;
if b>0 then
begin
gotoxy(5,b);
write(chr(26));
end;
textcolor(white);
gotoxy(2,25);
write('Hit a key to play again or ESC to exit');
repeat until keypressed;
read(kbd,q);
if keypressed then read(kbd,q);
if q=#27 then stop:=true else stop:=false;
end;
begin
randomize;
setup;
repeat
playgame;
showscores;
until stop;
exit
end.