Shareware Overload/ShartewareOverload.cdr/games/qikserve.zip/QIKSERVE.PAS

Pascal/Delphi Source File | 1987-11-30 | 19KB | 720 lines

Program QikServe;

{$C- }

{$i Graph.p }

const
   ycounter : array[1..4] of integer =
              (67,105,146,185);
   ymachine : array[1..4] of integer =
              (51,89,130,169);
   centeradj = -1;
   rightadj  = -2;

type
   stype = string[15];
   words = string[80];
   data0 = record
              pict : array[0..2700] of real;
           end;
   data1 = record
              shp : array[0..200] of integer;
           end;
   data2 = record
              xp,yp,person,want,yell  : integer;
              eatmove,eating,onscreen : boolean;
           end;
   data3 = record
              fx,fy,kind : integer;
              moving     : boolean;
           end;

var
   ch           : char;
   screen       : data0;
   pic          : array[1..21] of data1;
   xpic         : array[0..2] of data1;
   people       : array[1..10] of data2;
   food         : array[1..10] of data3;
   score,c,
   guys,cy,
   foodturn,
   peopleturn,
   total,smoke,
   smoketime    : integer;
   smoking,left : boolean;


function st(h :integer) : stype;
var
   chaa : stype;
begin
   str(h,chaa);
   st := chaa;
end;


function vl(h :stype) : integer;
var
   d,e : integer;
begin
   val(h,d,e);
   vl := d;
end;


function findopen : integer;
var
   d,e : integer;
begin
   e := 0;
   for d := 10 downto 1 do
      if not food[d].moving
         then e := d;
   findopen := e;
end;


function level : integer;
var
   d : integer;
begin
   d := 0;
   case cy of
     67 : d := 1;
    102 : d := 2;
    142 : d := 3;
    182 : d := 4;
   end;
   level := d;
end;


function speed : integer;
var
   d : integer;
begin
   d := (score div 100) + 2;
   if d>10
      then d := 10;
   speed := d;
end;


procedure inkey;
begin
   if keypressed
      then read(kbd,ch)
      else ch := #0;
   if (ch=#27) and not keypressed
      then
         begin
            textmode(c80);
            textcolor(7);
            clrscr;
            halt;
         end;
   ch := upcase(ch);
end;


procedure click;
begin
   sound(1000);
   nosound;
end;


procedure beep;
begin
   sound(100);
   delay(300);
   nosound;
end;


procedure clearbuffer;
begin
   while keypressed do
      read(kbd,ch);
   ch := #0;
end;


procedure getshapes;
var
   fil1  : text;
   fil2  : file of data0;
   d,e,f : integer;
begin
   assign(fil1,'QikServe.shp');
   reset(fil1);
   for d := 1 to 21 do
      with pic[d] do
         begin
            read(fil1,shp[0]);
            read(fil1,shp[1]);
            read(fil1,shp[2]);
            e := (((shp[1]+3)div 4)*shp[2]*2+6)div 3;
            for f := 3 to e-1 do
               read(fil1,shp[f]);
         end;
   close(fil1);
   assign(fil2,'QikServe.pic');
   reset(fil2);
   read(fil2,screen);
   close(fil2);
end;


procedure putletter(px,py,color :integer; wword :words);
const
   wlet : array[1..66] of string[15] =
          ('000000000000000','010010010000010','101101000000000',
           '010111010111010','010111110011110','101001010100101',
           '101010110101011','010010000000000','001010010010001',
           '100010010010100','010111111111010','010010111010010',
           '000000000010100','000000111000000','000000000000010',
           '001001010100100','010101101101010','010110010010111',
           '111001111100111','110001010001110','101101111001001',
           '111100110001110','011100110101010','111001010010010',
           '111101111101111','111101111001111','000000010000010',
           '000010000010100','001010100010001','000111000111000',
           '100010001010100','111001011000010','010111011101010',
           '010101111101101','110101110101110','111100100100111',
           '110101101101110','111100110100111','111100110100100',
           '111100101101111','101101111101101','111010010010111',
           '001001001101010','100101110101101','100100100100111',
           '111111111101101','101111111101101','111101101101111',
           '111101111100100','111101111010011','110101110101101',
           '011100111001110','111010010010010','101101101101111',
           '101101101101010','101101111111111','101101010101101',
           '101101010010010','111001010100111','111100100100111',
           '100110010001001','111001001001111','010101000000000',
           '000000000000111','100010000000000','111111111111111');
type
   wletter = ' '..'a';
var
   aa,bb,cc,dd,ee : integer;
   chara          : wletter;
begin
   if px=-1
      then px := 160 - length(wword) * 7  div 2
      else if px=-2
              then px := 319 - length(wword)*7;
   for aa := 1 to length(wword) do
      begin
         if copy(wword,aa,1)='█'
            then chara := 'a'
            else chara := upcase(copy(wword,aa,1));
         bb := ord(chara);
         for cc := 0 to 4 do
            for dd := 0 to 2 do
               if copy(wlet[bb-31],cc*3+(dd+1),1)='1'
                  then case color of
                           0 : draw(dd*2+px,cc+py,dd*2+px+1,cc+py,0);
                           1 : draw(dd*2+px,cc+py,dd*2+px+1,cc+py,1);
                           2 : draw(dd*2+px,cc+py,dd*2+px+1,cc+py,2);
                           3 : draw(dd*2+px,cc+py,dd*2+px+1,cc+py,3);
                           4 : begin
                                  plot(dd*2+px,cc+py,0);
                                  plot(dd*2+px+1,cc+py,1);
                               end;
                           5 : begin
                                  plot(dd*2+px,cc+py,0);
                                  plot(dd*2+px+1,cc+py,2);
                               end;
                           6 : begin
                                  plot(dd*2+px,cc+py,0);
                                  plot(dd*2+px+1,cc+py,3);
                               end;
                           7 : begin
                                  plot(dd*2+px,cc+py,1);
                                  plot(dd*2+px+1,cc+py,2);
                               end;
                           8 : begin
                                  plot(dd*2+px,cc+py,1);
                                  plot(dd*2+px+1,cc+py,3);
                               end;
                           9 : begin
                                  plot(dd*2+px,cc+py,2);
                                  plot(dd*2+px+1,cc+py,3);
                               end;
                       end;
         px := px + 7;
      end;
   c := px;
end;


procedure titlescreen;
const
   name = 'QikServe';
var
   x,y,d,e : integer;
begin
   graphcolormode;
   palette(2);
   graphbackground(1);
   clearscreen;
   randomize;
   getpic(xpic[1].shp,0,0,9,9);
   getpic(xpic[2].shp,0,0,19,19);
   for d := 1 to length(name) do
      begin
         x := random(40)+1;
         y := random(24)+1;
         while not((x=d*2+11) and (y=12)) do
            begin
               gotoxy(x,y); write(' ');
               if x<d*2+11
                  then x := x + 1
                  else if x>d*2+11
                          then x := x - 1;
               if y<12
                  then y := y + 1
                  else if y>12
                          then y := y - 1;
               gotoxy(x,y); write(copy(name,d,1));
               for e := 1 to d-1 do
                  begin
                     gotoxy(e*2+11,12);
                     write(copy(name,e,1));
                  end;
               delay(20);
            end;
         sound(1000);
         delay(10);
         nosound;
      end;
   putletter(centeradj,100,3,'By Scott Ramsay');
   putletter(90,180,1,'Press ');
   putletter(c,180,2,'ESC ');
   putletter(c,180,1,'anytime quit');
   putletter(centeradj,187,1,'or press any other key to continue.');
   clearbuffer;
   repeat
      inkey;
   until ch<>#0;
end;


procedure gamescreen;
begin
   putpic(screen.pict,0,199);
end;


procedure printscore;
var
   d : integer;
begin
   putletter(46,24,0,'██████');
   for d := 0 to 5-length(st(score)) do
      putletter(d*7+46,24,6,'0');
   putletter(c,24,6,st(score));
end;


procedure printchances;
var
   d : integer;
begin
   putletter(207,24,0,'██');
   for d := 0 to 1-length(st(guys)) do
      putletter(d*7+207,24,6,'0');
   putletter(c,24,6,st(guys));
end;


procedure setup;
var
   d : integer;
begin
   total := 3;
   score := 0;
   guys := 6;
   cy := 67;
   smoke := 0;
   smoking := true;
   smoketime := 0;
   left := true;
   foodturn := 0;
   peopleturn := 0;
   for d := 1 to 10 do
      people[d].onscreen := false;
   for d := 1 to 10 do
      food[d].moving := false;
   putpic(pic[5].shp,25,cy);
   colortable(0,2,1,3);
   putpic(pic[20].shp,25,cy+20);
   colortable(0,1,2,3);
   printchances;
   printscore;
   clearbuffer;
   putletter(centeradj,50,3,'press any key to play');
   repeat
      inkey;
   until ch<>#0;
   putletter(centeradj,50,0,'press any key to play');
end;


procedure smokeoff(h : integer);
begin
   putpic(xpic[1].shp,3,ymachine[h]);
   putpic(xpic[1].shp,10,ymachine[h]-4);
   putpic(xpic[1].shp,0,ymachine[h]-6);
end;


procedure smokepuff(var h :integer);
begin
   if h<>0
      then
         begin
            if smoking
               then
                  begin
                     if random<0.3
                        then putpic(pic[19].shp,3,ymachine[h])
                        else if random<0.6
                                then putpic(pic[19].shp,10,ymachine[h]-4)
                                else putpic(pic[19].shp,0,ymachine[h]-6);
                  end
               else smokeoff(h);
            smoking := not smoking;
            smoketime := smoketime - 1;
            if smoketime=0
               then
                  begin
                     smokeoff(h);
                     h := 0;
                  end;
         end;
end;


procedure setfood;
var
   d : integer;
begin
   putpic(pic[6].shp,25,cy);
   d := findopen;
   with food[d] do
      begin
         kind := vl(ch);
         fx := 50;
         fy := ycounter[level];
         moving := true;
         putpic(pic[kind].shp,fx,fy);
      end;
   for d := 1 to 4 do
      smokeoff(d);
   smoke := level;
   smoketime := 10;
   putpic(pic[5].shp,25,cy);
   clearbuffer;
end;


procedure getkey;
begin
   if (ch in ['1','2','3']) and (findopen<>0) and (cy in [67,102,142,182])
      then setfood;
   if (ch=#27) and keypressed
      then
         begin
            read(kbd,ch);
            putpic(xpic[2].shp,25,cy);
            putpic(xpic[2].shp,25,cy+20);
            if ch='H'
               then cy := cy - 5
               else if ch='P'
                       then cy := cy + 5;
            if cy<67
               then cy := 182
               else if cy>182
                       then cy := 67;
            if ch in ['H','P']
               then
                  begin
                     left := not left;
                     click;
                  end;
            putpic(pic[5].shp,25,cy);
            if level<>0
               then colortable(0,2,1,3);
            if left
               then putpic(pic[20].shp,25,cy+20)
               else putpic(pic[21].shp,25,cy+20);
            if level<>0
               then colortable(0,1,2,3);
         end;
end;


procedure loseguy;
var
   d : integer;
begin
   delay(1500);
   for d := 1 to 10 do
      with food[d] do
        if moving
           then
              begin
                 putpic(xpic[1].shp,fx,fy);
                 moving := false;
              end;
   for d := 1 to total do
      with people[d] do
        if onscreen
           then
              begin
                 putpic(xpic[2].shp,xp,ycounter[yp]);
                 if yell<6
                    then putpic(xpic[2].shp,xp-20,ycounter[yp]-7);
                 onscreen := false;
              end;
   for d := 1 to 4 do
      smokeoff(d);
   guys := guys - 1;
   printchances;
   if guys<>0
      then
         begin
            for d := 1 to 5 do
               begin
                  putletter(-1,40,(d mod 2)+1,'Get Ready');
                  sound(1000);
                  delay(40);
                  nosound;
                  delay(200);
              end;
            putletter(-1,40,0,'Get Ready');
         end;
   clearbuffer;
end;


procedure checkforperson;
var
   d : integer;
begin
   for d := 1 to total do
      with people[d],food[foodturn] do
         if onscreen and not eating
            then if (fy=ycounter[yp]) and (abs(fx-xp)<15) and (want=kind)
                    then
                       begin
                          if yell<6
                             then putpic(xpic[2].shp,xp-20,ycounter[yp]-7);
                          moving := false;
                          eating := true;
                          eatmove := (random<0.2);
                          score := score + 10;
                          printscore;
                          sound(1000);
                          delay(40);
                          nosound;
                       end;
end;


procedure lostfood;
const
   fn : array[1..3] of stype =
        ('a hamburger','a shake','fries');
var
   d : integer;
begin
   putletter(-1,33,2,'Lost '+fn[food[foodturn].kind]+'!');
   for d := 2000 downto 100 do
      sound(d);
   nosound;
   with food[foodturn] do
       for d := fy div 5 to 199 div 5 do
          begin
             getpic(xpic[0].shp,fx,d*5,fx+9,d*5-9);
             putpic(pic[kind].shp,fx,d*5);
             delay(30);
             putpic(xpic[0].shp,fx,d*5);
          end;
   loseguy;
   putletter(-1,33,0,'Lost '+fn[food[foodturn].kind]+'!');
end;


procedure movefood;
begin
   foodturn := foodturn + 1;
   if foodturn=11
      then foodturn := 1;
   with food[foodturn] do
      if moving
         then
            begin
               putpic(xpic[1].shp,fx,fy);
               fx := fx + 10;
               checkforperson;
               if fx>309
                  then
                     begin
                        moving := false;
                        lostfood;
                     end
                  else if moving
                          then putpic(pic[kind].shp,fx,fy);
            end;
end;


procedure personmad;
begin
   putletter(-1,33,2,'person mad!');
   beep;
   loseguy;
   putletter(-1,33,0,'person mad!');
end;


function closeto(h :integer) : boolean;
var
   d : integer;
begin
   closeto := false;
   for d := 1 to 10 do
      with people[d] do
         if (d<>h) and (xp>265) and (yp=people[h].yp)
            then closeto := true;
end;


procedure movepeople;
var
   d,e : integer;
begin
   total := (score div 150) + 3;
   if total>10
      then total := 10;
   peopleturn := peopleturn + 1;
   if peopleturn=total+1
      then peopleturn := 1;
   for e := 1 to total do
      with people[e] do
         if not onscreen and (random(300)=0)
            then
               begin
                  onscreen := true;
                  eating := false;
                  xp := 296;
                  d := 0;
                  repeat
                     d := d + 1;
                     yp := random(4)+1;
                  until (d=10) or not closeto(e);
                  yell := 0;
                  want := random(3)+1;
                  person := random(6)+1;
                  putpic(pic[person*2+5].shp,xp,ycounter[yp]);
               end;
   with people[peopleturn] do
      if onscreen
         then
            begin
               if not eating
                  then
                     begin
                        if yell<6
                           then putpic(xpic[2].shp,xp-20,ycounter[yp]-7);
                        yell := random(50);
                        putpic(xpic[2].shp,xp,ycounter[yp]);
                        xp := xp - random(speed);
                        if xp<50
                           then
                              begin
                                 onscreen := false;
                                 personmad;
                              end
                           else
                              begin
                                 putpic(pic[person*2+5].shp,xp,ycounter[yp]);
                                 if yell<6
                                    then
                                       begin
                                          putpic(pic[4].shp,xp-20,ycounter[yp]-7);
                                          putpic(pic[want].shp,xp-15,ycounter[yp]-15);
                                          delay(80);
                                       end;
                              end;
                     end
                  else
                     begin
                         putpic(xpic[2].shp,xp,ycounter[yp]);
                         if eatmove
                            then xp := xp + 15;
                         if xp>296
                            then onscreen := false;
                         if (random(50)=0) and not eatmove
                            then
                               begin
                                  if (random<0.4) or (xp<140)
                                     then eatmove := true
                                     else
                                        begin
                                           eating := false;
                                           want := random(3)+1;
                                        end;
                               end
                            else if onscreen
                                    then
                                       begin
                                          if random(200)<100
                                             then putpic(pic[person*2+6].shp,xp,ycounter[yp])
                                             else putpic(pic[person*2+5].shp,xp,ycounter[yp]);
                                       end;
                     end;
            end;
end;


function gameover : boolean;
begin
   putletter(-1,50,3,'GAME OVER');
   putletter(-1,90,1,'press space to play again');
   putletter(-1,97,1,'or press any other key to quit');
   clearbuffer;
   repeat
      inkey;
   until ch<>#0;
   gameover := (ch<>' ');
end;


procedure gamedone;
begin
   textmode(c80);
   textcolor(7);
   textbackground(0);
   clrscr;
end;


begin
   getshapes;
   titlescreen;
   repeat
      gamescreen;
      setup;
      repeat
         inkey;
         getkey;
         movefood;
         movepeople;
         smokepuff(smoke);
      until guys=0;
   until gameover;
   gamedone;
end.