paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-22 15:38:25 +02:00
Code Issues Packages Projects Releases Wiki Activity
30f1eb4705
fpc/demo/graph/quad.pp
peter 01dfac4a4e * old logs removed and tabs fixed
2002-09-07 15:06:34 +00:00

829 lines
18 KiB
ObjectPascal
Raw Blame History

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).}
{$Define UseGraphics}
{$ifdef UseGraphics}
{$ifdef Win32}
{$define Win32Graph} // Needed for GameUnit.
{$APPTYPE GUI}
{$endif}
{$endif}
Uses
{$ifdef Win32}
WinCrt,Windows,
{$else}
Crt,
{$endif}
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';
{$IFDEF UseGraphics}
DisplGrX=110;
DisplGrY=90;
DisplGrScale=16;
HelpY=130;
{$ENDIF}
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
{$ifdef Win32}
{$ifndef Debug}
ShowWindow(GetActiveWindow,0);
{$endif}
grmode:=vgaHI;
grd:=vga;
Direc:='';
{$else}
closegraph;
grd := 9;{ detect;}
grmode := 2;{ m800x600x16;}
{$endif}
initgraph(grd,grmode,direc);
{$ifndef Win32}
setgraphmode(2);
{$endif}
End;
procedure WaitForMouse;
var ms_mx,ms_my,ms_but : LONGINT;
begin
Repeat
GetMouseState(ms_mx,ms_my,ms_but);
Until ms_but=0;
Repeat
GetMouseState(ms_mx,ms_my,ms_but);
Until ms_but<>0;
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);
{$ifndef Win32}
gotoxy(1,1);
{$endif}
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;
{$ifdef Win32Graph}
Procedure ClearTextCoord(x1,y1,x2,y2:Longint);
Begin
SetFillStyle(SolidFill,0); {Clear part of playfield}
Bar ((x1+1) * DisplGrScale, (Y1+1)*DisplGrScale,(x2+1) * DisplGrScale, (Y2+1)*DisplGrScale);
End;
{$endif}
Procedure win;
Var m,s: string;
I,J : LONGINT;
Const GameOver='Game Over, turns needed = ';
Begin
hidemouse;
// fire_works;
cleardevice;
{$ifndef Win32}
closegraph;
textmode(co80+font8x8);
clrscr;
{$endif}
I:=SlipInScore(Turns);
{$ifndef Win32}
GotoXY(1,23);
Writeln(GameOver,Turns);
FOR J:=9 TO 22 DO
BEGIN
GotoXY(20,J);
Write(' ':38);
END;
{$else}
SetColor(White);
ClearTextCoord(20,9,58,22);
Str(Turns,S);
S:=GameOver+S;
OutTextXY(5,40+9*LineDistY,S);
OutTextXY(5,40+23*LineDistY,'Press mouse to continue');
WaitForMouse;
{$endif}
IF I<>0 THEN
BEGIN
ShowHighScore;
{$IFDEF USEGRAPHICS}
SetColor(Black);
Bar(5,40+23*LineDisty,5+8*26,40+23*LineDisty+8);
SetColor(White);
OutTextXY(5,40+23*LineDistY,'Please enter your name');
GrInputStr(S,300,HelpY+20+(17-I+1)*LineDistY,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;
{$ifdef Win32}
Bar(5,40+23*LineDisty,5+8*26,40+23*LineDisty+8);
OutTextXY(5,40+23*LineDistY,'Press mouse to continue');
WaitForMouse;
{$else}
ginit640x480x16(bgidirec);
{$endif}
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;
{$ifndef Win32}
gotoxy(1,1);
{$endif}
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
{$ifdef Win32}
MessageBox(GetActiveWindow,'Error','Fatal error, couldn''t find graphics data file quaddata.dat',WM_QUIT);
{$else}
TextMode(CO80);
Writeln('Fatal error, couldn''t find graphics data file quaddata.dat');
{$endif}
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}
{$ifdef Win32}
HighX :=300; {Coordinates of highscores}
HighY :=130+20+8*LineDistY; {y coordinate relative to other options}
{$else}
HighX:=20; HighY:=9; {coordinates for highscores}
{$endif}
GetMem(PicData,PicBufferSize); {Allocate room for pictures}
load_pics(PicData); {Load picture data from file}
FOR I:=0 TO 9 DO {Create default scores}
begin
HighScore[I].Score:=-100*I; {Negative, because then the
"highest" score is best}
If HighScore[I].Score>0 Then
Writeln('ohoh');
End;
LoadHighScore(ScoreFileName); {Try to load highscore file}
// closegraph;
{$ifNdef FPC}
bgidirec := 'd:\prog\bp\bgi';
{$ENDIF}
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
Initmouse;
Negative:=True;
clean;
Repeat
interpret;
Until (exit1=true) {$ifdef Debug} or (turns=1) {$endif};
{$ifndef Win32}
closegraph;
{$endif}
Freemem(PicData,PicBufferSize);
SaveHighScore;
{$ifndef Win32}
Textmode(co80);
clrscr;
HideMouse;
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;
ShowMouse;
{$else}
SetbkColor(black);
SetColor(White);
SetViewPort(0,0,getmaxx,getmaxy,clipoff);
ClearViewPort;
SetTextStyle(0,Horizdir,2);
SetTextStyle(0,Horizdir,1);
OutTextXY(220,10,'QUAD');
OutTextXY(5,40+1*LineDistY,'Thanks for playing Quadruple Memory');
OutTextXY(5,40+2*LineDistY,'Feel free to distribute this software.');
OutTextXY(5,40+4*LineDistY,'Programmed by: Justin Pierce');
OutTextXY(5,40+5*LineDistY,'Graphics by: Whitney Pierce');
OutTextXY(5,40+6*LineDistY,'Inspired by: Jos Dickman''s triple memory!');
OutTextXY(5,40+7*LineDistY,'FPC conversion and cleanup by Marco van de Voort');
OutTextXY(5,40+9*LineDistY,'Press mouse to continue');
WaitForMouse;
{$endif}
{$ifdef Win32}
CloseGraph;
{$endif}
DoneMouse;
End.
{
$Log$
Revision 1.5 2002-09-07 15:06:35 peter
* old logs removed and tabs fixed
Revision 1.4 2002/06/02 09:49:17 marco
* Renamefest
Revision 1.3 2002/02/27 16:29:54 carl
* We should initialize the mouse!
Revision 1.2 2002/02/25 12:23:05 marco
* Fixes for Quad Win32 GUI mode
}
Reference in New Issue View Git Blame Copy Permalink