freepascal.compiler/install/demo/quad.pas

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 [email protected], 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,errcode: integer;
Begin
  closegraph;
  grd := 9;{ detect;}
  grmode := 2;{ m800x600x16;}
  initgraph(grd,grmode,direc);
{  ErrCode := GraphResult;
  If ErrCode <> grOk Then fatal(
                       'PROC[GINIT640X480X16]- CANNOT INITIALIZE 640x480x16 GRAPHICS MODE'
    );}
  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;
   InputStr(S,20,21-I,10,FALSE,AlfaBeta);
   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.