New FPCGAME demo, Quad

install/demo/quad.pas

@@ -0,0 +1,680 @@
+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.