mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-28 10:08:31 +02:00
691 lines
15 KiB
ObjectPascal
691 lines
15 KiB
ObjectPascal
PROGRAM Quad;
|
|
{A demo which loads some graphics etc. Nice. Don't forget to distribute
|
|
quaddata.inc!
|
|
|
|
The sources for this game was found on a site that claims to only have
|
|
PD stuff with the below header(which was only reindented), and the webmaster
|
|
said that everything he published was sent to him with that purpose. We tried
|
|
to contact the authors mentioned below via mail over internet, but that
|
|
failed. If there is somebody that claims authorship of these programs,
|
|
please mail marco@freepascal.org, and the sources will be removed from our
|
|
websites.
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
ORIGINAL Header:
|
|
|
|
Programmed by: Justin Pierce
|
|
Graphics by: Whitney Pierce
|
|
Inspired by: Jos Dickman''s triple memory!
|
|
-----
|
|
|
|
Old version requires egavga.bgi. FPC doesn't require BGI's (VGA and VESA
|
|
support are built in the Graph, others are ignored).}
|
|
|
|
Uses Crt,Dos,Graph,
|
|
GameUnit; {Supplied with FPC demoes package. Wrapper for
|
|
mousesupport (via msmouse or api), and contains
|
|
highscore routines}
|
|
|
|
Const nox = 10;
|
|
noy = 8;
|
|
card_border = red;
|
|
PicBufferSize = 64000; {Buffersize for deRLE'ed picture data}
|
|
ComprBufferSize = 20000; {Buffer for diskread- RLE'ed data}
|
|
PicsFilename = 'quaddata.dat'; {Name of picturesfile}
|
|
ScoreFileName = 'quad.scr';
|
|
|
|
Type
|
|
pByte = ^Byte; {BufferTypes}
|
|
Card = Record
|
|
exposed: boolean;
|
|
pic: byte;
|
|
End;
|
|
|
|
{Assigns an enumeration to each picture}
|
|
PictureEnum= (zero,one,two,three,four,five,six,seven,eight,nine,colon,
|
|
back,score,exit_b,score_b,chunk,p1,p2,p3,p4,p5,p6,p7,p8,
|
|
p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20);
|
|
|
|
{A pictures definition;
|
|
x and y dimensions and offset in PicData buffer}
|
|
|
|
Picture = packed Record
|
|
start: longint;
|
|
x,y: byte;
|
|
End;
|
|
|
|
{All pictures. This array, and the data in PicData is all pic info.}
|
|
PictureArray= ARRAY[zero..p20] OF Picture;
|
|
|
|
selected = Record
|
|
x,y: byte;
|
|
pic: byte;
|
|
End;
|
|
time_record = Record
|
|
o_hr,o_min,o_sec,o_sec100: word;
|
|
hr,min,sec,sec100: word;
|
|
a_sec,a_min: word;
|
|
End;
|
|
|
|
Var b : array[1..nox,1..noy] Of card;
|
|
Pics : PictureArray;
|
|
PicData : PByte;
|
|
s : array[1..4] Of selected;
|
|
os : byte;
|
|
turns : integer;
|
|
off,ok,exit1: boolean;
|
|
opened : byte;
|
|
bgidirec : string;
|
|
time : time_record;
|
|
|
|
{
|
|
Procedure fatal(fcall:String);
|
|
Begin
|
|
textmode(CO80);
|
|
clrscr;
|
|
Writeln('A fatal error has occured');
|
|
Writeln('Error: ',fcall);
|
|
Writeln;
|
|
Write('Hit enter to halt program--');
|
|
readln;
|
|
halt;
|
|
End;
|
|
}
|
|
|
|
Procedure ginit640x480x16(direc:String);
|
|
|
|
Var grd,grmode: integer;
|
|
Begin
|
|
closegraph;
|
|
grd := 9;{ detect;}
|
|
grmode := 2;{ m800x600x16;}
|
|
initgraph(grd,grmode,direc);
|
|
setgraphmode(2);
|
|
End;
|
|
|
|
Procedure clean_board;
|
|
|
|
Var x,y: byte;
|
|
Begin
|
|
y := 1;
|
|
Repeat
|
|
x := 1;
|
|
Repeat
|
|
b[x,y].pic := 0;
|
|
b[x,y].exposed := false;
|
|
inc(x);
|
|
Until x>nox;
|
|
inc(y);
|
|
Until y>noy
|
|
End;
|
|
|
|
Procedure showpic(xp,yp:integer; tp:pictureenum);
|
|
|
|
Var x,y,x1,y1: byte;
|
|
tx: integer;
|
|
Begin
|
|
x := pics[tp].x; {mb[tp.start];}
|
|
y := pics[tp].y; {mb[tp.start+1];}
|
|
y1 := 1;
|
|
tx := 0;
|
|
Repeat
|
|
x1 := 1;
|
|
Repeat
|
|
putpixel(xp+(x1-1),yp+(y1-1),picdata[pics[tp].start-1+tx]);
|
|
inc(x1);
|
|
inc(tx);
|
|
Until x1>x;
|
|
inc(y1);
|
|
Until y1>y;
|
|
End;
|
|
|
|
Procedure NumberOutput(X,Y,Number:LONGINT;RightY:BOOLEAN);
|
|
|
|
Var num: string;
|
|
plc: byte;
|
|
|
|
Begin
|
|
str(number,num);
|
|
If length(num)=1 Then
|
|
insert('0',num,0);
|
|
IF RightY THEN
|
|
dec (x,length(num)*11);
|
|
plc := 1;
|
|
Repeat
|
|
IF (Num[plc]>CHR(47)) AND (Num[plc]<CHR(58)) THEN
|
|
showpic(((plc-1)*11)+X,Y,pictureenum(ORD(Zero)+ORD(Num[plc])-48));
|
|
inc(plc);
|
|
Until plc>length(num);
|
|
End;
|
|
|
|
Procedure update_secs;
|
|
|
|
Begin
|
|
showpic(605,453,colon);
|
|
NumberOutput(615,453,time.a_sec,FALSE);
|
|
End;
|
|
|
|
Procedure showturn(x,y:integer);
|
|
|
|
Begin
|
|
hidemouse;
|
|
If (x=0) And (y=0) Then
|
|
NumberOutput(4,453,Turns,FALSE)
|
|
ELSE
|
|
NumberOutput(x,y,Turns,FALSE);
|
|
showmouse;
|
|
End;
|
|
|
|
Procedure get_original_time;
|
|
Begin
|
|
With time Do
|
|
Begin
|
|
a_sec := 0;
|
|
a_min := 0;
|
|
gettime(o_hr,o_min,o_sec,o_sec100);
|
|
gettime(hr,min,sec,sec100);
|
|
End;
|
|
End;
|
|
|
|
Procedure update_time(ForcedUpdate:BOOLEAN);
|
|
Begin
|
|
With time Do
|
|
Begin
|
|
gettime(hr,min,sec,sec100);
|
|
|
|
If sec<>o_sec Then
|
|
Begin
|
|
inc(a_sec);
|
|
If a_sec<=60 Then update_secs;
|
|
End;
|
|
If a_sec>60 Then
|
|
Begin
|
|
a_sec := 0;
|
|
inc(a_min);
|
|
ForcedUpdate:=TRUE;
|
|
End;
|
|
IF ForcedUpdate THEN
|
|
BEGIN
|
|
Update_secs;
|
|
showpic(606,453,colon);
|
|
NumberOutput(606,453,time.a_min,TRUE);
|
|
END;
|
|
o_hr := hr;
|
|
o_min := min;
|
|
o_sec := sec;
|
|
o_sec100 := sec;
|
|
End;
|
|
End;
|
|
|
|
|
|
Procedure makecard(x,y:byte);
|
|
|
|
Var xp,yp: integer;
|
|
Begin
|
|
hidemouse;
|
|
xp := ((x-1)*63);
|
|
yp := ((y-1)*56);
|
|
setcolor(card_border);
|
|
setfillstyle(1,0);
|
|
bar(xp+1,yp+1,xp+62,yp+55);
|
|
rectangle(xp,yp,xp+63,yp+56);
|
|
If b[x,y].exposed=false Then
|
|
Begin
|
|
showpic(xp+1,yp+1,back);
|
|
End;
|
|
showmouse;
|
|
If b[x,y].exposed=true Then
|
|
Begin
|
|
hidemouse;
|
|
showpic(xp+7,yp+4,pictureenum(ORD(b[x,y].pic)+ORD(p1)-1));
|
|
showmouse;
|
|
End;
|
|
End;
|
|
|
|
Function used(pic:byte): byte;
|
|
|
|
Var cx,cy,u: byte;
|
|
Begin
|
|
used := 0;
|
|
u := 0;
|
|
cy := 1;
|
|
Repeat
|
|
cx := 1;
|
|
Repeat
|
|
If b[cx,cy].pic=pic Then inc(u);
|
|
inc(cx);
|
|
Until cx>nox;
|
|
inc(cy);
|
|
Until cy>noy;
|
|
used := u;
|
|
End;
|
|
|
|
Procedure set_board;
|
|
|
|
CONST Outstr=#219+#219+#219+#219+#219+#219+#219+#219+#219+#219+#219+#219+#219+
|
|
#219+#219+#219+#219+#219+#219+#219+#219+#219+#219+#219+#219+
|
|
#219+#219+#219+#219;
|
|
|
|
Var cx,cy,pic: byte;
|
|
Begin
|
|
setcolor(0);
|
|
outtextxy(0,470,OutStr);
|
|
setcolor(green);
|
|
outtextxy(0,470,'Dealing board, please wait...');
|
|
Delay(1000);
|
|
cy := 1;
|
|
Repeat
|
|
cx := 1;
|
|
Repeat
|
|
Repeat
|
|
pic := random(20)+1;
|
|
Until used(pic)<4;
|
|
b[cx,cy].pic := pic;
|
|
makecard(cx,cy);
|
|
inc(cx);
|
|
Until cx>nox;
|
|
inc(cy);
|
|
Until cy>noy;
|
|
setcolor(0);
|
|
outtextxy(0,470,OutStr);
|
|
End;
|
|
|
|
Procedure fire_works;
|
|
|
|
Const
|
|
nof = 30;
|
|
|
|
Type
|
|
fires = Record
|
|
x,y: Longint;
|
|
direct: longint;
|
|
speed: Longint;
|
|
explode: boolean;
|
|
color: byte;
|
|
oex: longint;
|
|
End;
|
|
|
|
Var fire: array[1..nof] Of fires;
|
|
|
|
Procedure clean_fires;
|
|
|
|
Var c: longint;
|
|
Begin
|
|
c := 1;
|
|
Repeat
|
|
fire[c].direct := random(2)+1;
|
|
fire[c].color := random(15)+1;
|
|
fire[c].x := random(639);
|
|
fire[c].y := 479;
|
|
fire[c].explode := false;
|
|
fire[c].speed := random(20)+15;
|
|
fire[c].oex := 1;
|
|
inc(c);
|
|
Until c>nof;
|
|
End;
|
|
|
|
Procedure inact;
|
|
|
|
Var c: longint;
|
|
Begin
|
|
c := 1;
|
|
Repeat
|
|
If fire[c].explode=false Then
|
|
Begin
|
|
setcolor(fire[c].color);
|
|
circle(fire[c].x,fire[c].y,1);
|
|
End;
|
|
|
|
If (fire[c].explode=true) And (fire[c].oex<10) Then
|
|
Begin
|
|
setcolor(fire[c].color);
|
|
circle(fire[c].x,fire[c].y,fire[c].oex);
|
|
setcolor(random(15)+1);
|
|
circle(fire[c].x,fire[c].y,fire[c].oex-1);
|
|
End;
|
|
|
|
inc(c);
|
|
Until c>nof;
|
|
|
|
delay(75);
|
|
gotoxy(1,1);
|
|
|
|
c := 1;
|
|
Repeat
|
|
setcolor(0);
|
|
circle(fire[c].x,fire[c].y,1);
|
|
|
|
If (fire[c].explode=true) And (fire[c].oex<10) Then
|
|
Begin
|
|
circle(fire[c].x,fire[c].y,fire[c].oex);
|
|
circle(fire[c].x,fire[c].y,fire[c].oex-1);
|
|
inc(fire[c].oex);
|
|
End;
|
|
|
|
If fire[c].explode=false Then
|
|
Begin
|
|
dec(fire[c].speed,1);
|
|
dec(fire[c].y,fire[c].speed);
|
|
If fire[c].direct=1 Then inc(fire[c].x,2);
|
|
If fire[c].direct=2 Then dec(fire[c].x,2);
|
|
If fire[c].speed<=(-1*LONGINT(random(11))) Then
|
|
fire[c].explode := true;
|
|
End;
|
|
|
|
inc(c);
|
|
Until c>nof;
|
|
c := 1;
|
|
End;
|
|
|
|
Function exploded: boolean;
|
|
|
|
Var c: longint;
|
|
m: boolean;
|
|
Begin
|
|
c := 1;
|
|
m := true;
|
|
Repeat
|
|
If fire[c].oex<6 Then m := false;
|
|
inc(c);
|
|
Until (c>nof);
|
|
exploded := m;
|
|
End;
|
|
|
|
Begin
|
|
cleardevice;
|
|
Repeat
|
|
clean_fires;
|
|
Repeat
|
|
inact;
|
|
Until (exploded=true) Or (keypressed);
|
|
Until keypressed;
|
|
End;
|
|
|
|
Procedure win;
|
|
|
|
Var m,s: string;
|
|
I,J : LONGINT;
|
|
|
|
Begin
|
|
hidemouse;
|
|
fire_works;
|
|
cleardevice;
|
|
closegraph;
|
|
textmode(co80+font8x8);
|
|
clrscr;
|
|
I:=SlipInScore(Turns);
|
|
GotoXY(1,23);
|
|
Writeln('Game Over, turns needed = ',Turns);
|
|
FOR J:=9 TO 22 DO
|
|
BEGIN
|
|
GotoXY(20,J);
|
|
Write(' ':38);
|
|
END;
|
|
IF I<>0 THEN
|
|
BEGIN
|
|
ShowHighScore;
|
|
{$IFDEF USEGRAPHICS}
|
|
GrInputStr(S,20,21-I,16,12,10,FALSE,AlfaBeta);
|
|
{$ELSE}
|
|
InputStr(S,20,21-I,10,FALSE,AlfaBeta);
|
|
{$ENDIF}
|
|
IF Length(S)<12 THEN
|
|
BEGIN
|
|
str(time.a_min,m);
|
|
S:=S+'['+m+':';
|
|
str(time.a_sec,m);
|
|
S:=S+'m'+']';
|
|
END;
|
|
HighScore[I-1].Name:=S;
|
|
END;
|
|
ShowHighScore;
|
|
ginit640x480x16(bgidirec);
|
|
off := false;
|
|
clean_board;
|
|
set_board;
|
|
turns := 0;
|
|
showpic(0,450,score);
|
|
showpic(80,450,score_b);
|
|
showpic(150,450,exit_b);
|
|
showpic(569,450,score);
|
|
showturn(0,0);
|
|
exit1 := false;
|
|
get_original_time;
|
|
update_time(True);
|
|
SetMousePosition(0,0);
|
|
showmouse;
|
|
End;
|
|
|
|
Procedure show_scores;
|
|
|
|
Var x,y,c: byte;
|
|
Begin
|
|
hidemouse;
|
|
|
|
y := 1;
|
|
Repeat
|
|
x := 1;
|
|
showpic(x+135,(y-1)*21,score);
|
|
showpic(x,(y-1)*21,score);
|
|
showpic(x+204,(y-1)*21,score);
|
|
Repeat
|
|
showpic(((x-1)*10)+3,(y-1)*21,chunk);
|
|
inc(x);
|
|
Until x>20;
|
|
inc(y);
|
|
Until y>10;
|
|
|
|
c := 0;
|
|
Repeat
|
|
If HighScore[c].name<>'' Then
|
|
Begin
|
|
setcolor(white);
|
|
outtextxy(4,7+(c*21),HighScore[c].name);
|
|
turns := HighScore[c].Score;
|
|
showturn(211,3+(c*21));
|
|
End;
|
|
inc(c);
|
|
Until c>9;
|
|
turns := 0;
|
|
gotoxy(1,1);
|
|
readln;
|
|
|
|
off := false;
|
|
clean_board;
|
|
set_board;
|
|
turns := 0;
|
|
showpic(0,450,score);
|
|
showpic(80,450,score_b);
|
|
showpic(150,450,exit_b);
|
|
showpic(569,450,score);
|
|
showturn(0,0);
|
|
exit1 := false;
|
|
get_original_time;
|
|
update_time(True);
|
|
SetMousePosition(0,0);
|
|
showmouse;
|
|
End;
|
|
|
|
Procedure interpret;
|
|
|
|
Var mpx,mpy: byte;
|
|
ms_mx,ms_my,ms_but : LONGINT;
|
|
Begin
|
|
GetMouseState(ms_mx,ms_my,ms_but);
|
|
ms_mx:=ms_mx shr 1;;
|
|
|
|
If ms_but=0 Then off := false;
|
|
|
|
If ((ms_but AND 1)=1) And (off=false) Then
|
|
Begin
|
|
off := true;
|
|
mpx := ms_mx*2 Div 63;
|
|
mpy := (ms_my) Div 56;
|
|
|
|
If (ms_mx*2>=80) And (ms_mx*2<=129) And (ms_my>=450) And (ms_my<=466)
|
|
And (ok=true) Then show_scores;
|
|
If (ms_mx*2>=150) And (ms_mx*2<=199) And (ms_my>=450) And (ms_my<=466)
|
|
Then
|
|
Begin
|
|
exit1 := true;
|
|
End;
|
|
|
|
inc(mpx);
|
|
inc(mpy);
|
|
If (b[mpx,mpy].exposed=false) And (mpx>=1) And (mpy>=1) And (mpx<=10) And (mpy<=8)
|
|
Then
|
|
Begin
|
|
setfillstyle(1,0);
|
|
bar(80,450,130,466);
|
|
ok := false;
|
|
b[mpx,mpy].exposed := true;
|
|
makecard(mpx,mpy);
|
|
inc(os);
|
|
s[os].x := mpx;
|
|
s[os].y := mpy;
|
|
s[os].pic := b[mpx,mpy].pic;
|
|
End;
|
|
End;
|
|
|
|
If os=4 Then
|
|
Begin
|
|
inc(turns);
|
|
showturn(0,0);
|
|
os := 0;
|
|
delay(700);
|
|
inc(opened);
|
|
If Not((s[1].pic=s[2].pic) And (s[1].pic=s[3].pic) And (s[1].pic=s[4].pic)) Then
|
|
Begin
|
|
dec(opened);
|
|
b[s[1].x,s[1].y].exposed := false;
|
|
b[s[2].x,s[2].y].exposed := false;
|
|
b[s[3].x,s[3].y].exposed := false;
|
|
b[s[4].x,s[4].y].exposed := false;
|
|
makecard(s[1].x,s[1].y);
|
|
makecard(s[2].x,s[2].y);
|
|
makecard(s[3].x,s[3].y);
|
|
makecard(s[4].x,s[4].y);
|
|
End;
|
|
If opened=20 Then win;
|
|
End;
|
|
|
|
If NOT ok Then
|
|
update_time(FALSE);
|
|
End;
|
|
|
|
Procedure load_pics(PicBuf:PByte);
|
|
{loads picture structures from disc}
|
|
|
|
VAR F : File;
|
|
Buf1Ind,
|
|
I,J,K : LONGINT;
|
|
TData : PByte;
|
|
|
|
Begin
|
|
GetMem(TData,ComprBufferSize); { allocate buffer}
|
|
Assign(F,Picsfilename); { Open file}
|
|
{$I-}
|
|
Reset(F,1);
|
|
{$I+}
|
|
If ioresult<>0 Then
|
|
BEGIN
|
|
TextMode(CO80);
|
|
Writeln('Fatal error, couldn''t find graphics data file quaddata.dat');
|
|
HALT;
|
|
END;
|
|
|
|
{Read the array with picture information; (X,Y dimensions and offset in
|
|
binary data)}
|
|
BlockRead(F,pics,SIZEOF(Picture)*(ORD(p20)-ORD(zero)+1),I);
|
|
|
|
{Read some slackspace which shouldn't be in the file ;-)}
|
|
blockread(F,TData[0],6,Buf1ind);
|
|
|
|
{Read the real, RLE'ed graphics data}
|
|
BlockRead(F,TData[0],ComprBufferSize,Buf1Ind);
|
|
Close(F);
|
|
|
|
{Expand the RLE data. Of each byte, the high nibble is the count-1, low
|
|
nibble is the value}
|
|
|
|
I:=0; J:=0;
|
|
REPEAT
|
|
K:=(TData[I] SHR 4) +1;
|
|
FillChar(PicBuf[J],K,TData [I] AND 15);
|
|
INC(J,K);
|
|
INC(I);
|
|
UNTIL I>=Buf1Ind;
|
|
|
|
{Release the temporary buffer (the compressed data isn't necesary anymore)}
|
|
Freemem(TData,ComprBufferSize);
|
|
End;
|
|
|
|
Procedure clean;
|
|
|
|
VAR I : LONGINT;
|
|
|
|
Begin
|
|
Randomize; {Initialize random generator}
|
|
Negative:=TRUE; {Higher highscore is worse}
|
|
HighX:=20; HighY:=9; {coordinates for highscores}
|
|
|
|
GetMem(PicData,PicBufferSize); {Allocate room for pictures}
|
|
load_pics(PicData); {Load picture data from file}
|
|
FOR I:=0 TO 9 DO {Create default scores}
|
|
HighScore[I].Score:=-100*I; {Negative, because then the
|
|
"highest" score is best}
|
|
LoadHighScore(ScoreFileName); {Try to load highscore file}
|
|
closegraph;
|
|
bgidirec := 'd:\prog\bp\bgi';
|
|
ginit640x480x16(bgidirec);
|
|
setcolor(card_border);
|
|
ok := true;
|
|
opened := 0;
|
|
os := 0;
|
|
s[1].x := 0;
|
|
s[2].x := 0;
|
|
s[3].x := 0;
|
|
off := false;
|
|
clean_board;
|
|
set_board;
|
|
turns := 0;
|
|
showpic(0,450,score); showpic(80,450,score_b);
|
|
showpic(150,450,exit_b); showpic(569,450,score);
|
|
showturn(0,0);
|
|
exit1 := false;
|
|
SetMousePosition(0,0);
|
|
get_original_time;
|
|
update_time(True);
|
|
showmouse;
|
|
End;
|
|
|
|
Begin
|
|
|
|
clean;
|
|
Repeat
|
|
interpret;
|
|
Until exit1=true;
|
|
closegraph;
|
|
textmode(co80);
|
|
Freemem(PicData,PicBufferSize);
|
|
clrscr;
|
|
SaveHighScore;
|
|
Writeln('Thanks for playing Quadruple Memory');
|
|
Writeln('Feel free to distribute this software.');
|
|
Writeln;
|
|
Writeln('Programmed by: Justin Pierce');
|
|
Writeln('Graphics by: Whitney Pierce');
|
|
Writeln('Inspired by: Jos Dickman''s triple memory!');
|
|
Writeln('FPC conversion and cleanup by Marco van de Voort');
|
|
Writeln;
|
|
End.
|
|
$Log$
|
|
Revision 1.1 2001-05-03 21:39:33 peter
|
|
* moved to own module
|
|
|
|
Revision 1.2 2000/07/13 11:33:08 michael
|
|
+ removed logs
|
|
|
|
}
|