old/PAS/OLD/DEMOMODE.PAS

Uses CRT,Graph,DOS;
Type Hiscore = record
  Name  : array[1..10] of string[16];
  Score : array[1..10] of Word;
  Sp    : byte;
end;
Var
 test      : boolean;
 now, cl   : byte;
 rcrd      : boolean;
 s         : SearchRec;
 Tbl       : file of HiScore;
 MAX       : HiScore;
 col       : integer;
 C         : char;
 lt, rt    : Byte;
 W, e      : word;
 Dir, b    : byte;
 Num       : longint;
 en        : array [1..2] of byte;
 bg        : array [1..2] of byte;
 a         : array [20..80, 2..25] of integer;
 i,j,k,l,r : byte;
{-----------------======================-----------------}
Procedure FullClnBuf;forward;
Procedure ClnBuf;forward;
Procedure Setup; forward;
Procedure Stat1(bg1,bg2:byte); forward;
Procedure Apple ; forward;
Procedure Ext ; forward;
Procedure StartUp; forward;
Procedure DrawTable; forward;
Procedure Game; forward;
{---------------------------------------------------------}
Function Last(n:word):integer;
Var p,o : byte;
Begin
  for p := WhereY-3 to WhereY+3 do
    for o := Wherex - 3 to WhereX + 3 do
      if a[o,p] = n + 1 then
        Last := p * 100  + o;
end;{last}
{---------------------------------------------------------}
Function TestPos(s : byte):boolean;
Begin
  TestPos := true;
  if s <> 1 then begin
    case dir of

    1 : begin
          if (WhereX+1 > 79)  then TestPos := false;
          if a[WhereX,WhereY] > num then TestPos := false
          else if a[WhereX+1,WhereY] > num then TestPos := false;
          If (a[WhereX+1, WhereY - 1]>0) and (a[WhereX+1, WhereY+1]>0) then
             TestPos := false;
        end;
    2:  begin
          if (WhereY + 2) > 23 then TestPos := false;
          if a[WhereX-1,WhereY+2] > num then TestPos := false
          else if a[WhereX-1,WhereY+1] > num then TestPos := false;
          If (a[WhereX, WhereY + 2]>0) and (a[WhereX-2, WhereY+2]>0) then
             TestPos := false;
        end;
    3 : begin
          if (WhereX-3) < 21 then TestPos := false;
          if a[WhereX-3,WhereY] > num then TestPos := false
          else if a[WhereX-2,WhereY] > num then TestPos := false;
          If (a[WhereX-3, WhereY -1]>0) and (a[WhereX-3, WhereY+1]>0) then
             TestPos := false;
        end;
    4 : begin
          if (WhereY - 2) < 3 then TestPos := false;
          if a[WhereX-1,WhereY-2] > num then TestPos := False
          else if a[WhereX-1,WhereY-1] > num then TestPos := False;
          If (a[WhereX, WhereY - 2]>0) and (a[WhereX-2, WhereY-2]>0) then
             TestPos := false;
        end;
    end;
    end
  else
    begin
    case w of

                 77 : case dir of
                       1 : begin
                             if WhereX > 79 then testPos := false;
                             if a[whereX,WhereY+1] > 0 then testPos := false;
                             if a[whereX,WhereY] > 0 then testPos := false;
                           end;
                       2 : begin
                             if (WhereY + 1) > 23 then testPos := false;
                             if a[whereX-2,WhereY+1] > 0 then testPos := false;
                             if a[whereX-1,WhereY+1] > 0 then testPos := false;
                           end;
                       3 : begin
                             if (WhereX - 2) < 21 then testPos := false;;
                             if a[whereX-2,WhereY-1] > 0 then testPos := false;
                             if a[whereX-2,WhereY] > 0 then testPos := false;
                           end;
                       4 : begin
                             if (WhereY - 1) < 3 then testPos := false;;
                             if a[whereX,WhereY-1] > 0 then testPos := false;
                             if a[whereX-1,WhereY+1] > 0 then testPos := false;
                           end;
                       end;
                75 : case dir of
                       1 : begin
                             if WhereX > 79 then testPos := false;
                             if a[whereX,WhereY-1] > 0 then testPos := false;
                             if a[whereX,WhereY] > 0 then testPos := false;
                           end;
                       2 : begin
                             if WhereY + 1 > 23 then testPos := false;
                             if a[whereX,WhereY+1] > 0 then testPos := false;;
                             if a[whereX-1,WhereY+1] > 0 then testPos := false;
                           end;
                       3 : begin
                             if WhereX - 2 < 21 then testPos := false;
                             if a[whereX-2,WhereY+1] > 0 then testPos := false;;
                             if a[whereX-2,WhereY] > 0 then testPos := false;
                           end;
                       4 : begin
                             if WhereY - 1 < 3 then testPos := false;
                             if a[whereX-2,WhereY-1] > 0 then testPos := false;;
                             if a[whereX-1,WhereY-1] > 0 then testPos := false;
                            end;
                 end;
              end;
    end;
end;{TestPos}
{-------------------------------------------------------}
Procedure AI;
Var
 s,y : byte;
begin
  for y := 20 to 80 do
     begin
       a[y,2] := 32000;
       a[y,24] := 32000;
     end;
   for y := 2 to 24 do
     begin
       a[20,y] := 32000;
       a[80,y] := 32000;
     end;
  randomize;
  repeat
    repeat
      s := random(3);
    until s <> 0;
    if s = 1 then
      begin
        repeat
          w := random(78);
          c := #0;
        until (w = 77) or (w = 75);
      end
    else
      begin
        Fullclnbuf;
        c := #24;
        w := 12;
      end;
  until TestPos(s);
end;{AI}
{-----------------------------------------------------}
Procedure ClnBuf;
var
 z : char;
 v : byte;
 p : boolean;
begin
  p := false;
  c := #1;
  w := 0;
  Repeat
    if KeyPressed then
     z := ReadKey;
     if z = #0 then v := ord(readKey);
     if (v = 77) or (z = #27) or (z = 'p') or (z = 'P') or (v = 75) then
       begin
         p := true;
         c := z;
         w := v;
       end;
     if p then exit;
  until not keypressed;
end;{clnbuf}
{---------------------------------------------------------}
Procedure FullClnBuf;
begin
  Repeat
    if KeyPressed then
     ReadKey;
  until not keypressed;
end;{clnbuf}
{----------------------------------------------------------}
Procedure Recrd(i : byte);
Var t : byte;
Begin
  t := 0;
  if rcrd then begin
    ClrScr;
    GotoXY(30,10);
    if i = 10 then max.score[10] := col
    else
      for t := 9 downto i do begin
        max.score[t+1] := max.score[t];
        max.name[t+1] := max.name[t]
      end;
    max.score[i] := col;
    TextColor(cyan);
    Write('П О З Д Р А В Л Я Ю');
    GotoXY(30,12);
    TextColor(Blue);
    Write('Вы поставили рекорд');
    GotoXY(12,17);
    TextColor(Yellow);
    Write('Введите свое имя до 20 символов ');
    TextColor(lightgreen);
    Readln(max.name[i]);
    TextColor(7);
    Seek(tbl,0);
    Write(tbl,max);
    Close(tbl);
    Reset(tbl);
  end;
end;{Recrd}
{-----------------------------------------------------------}
Procedure SetCursorSize(size:word);
var
  reg : registers;
begin
  with reg do begin
    AH := $01;
    CH := hi(size);
    CL := lo(size);
    Intr($10,reg);
  end;
end;
{------------------------------------------------------------}
Procedure Setup;
begin
  CloseGraph;
  ClrScr;
  TextMode(CO80);
  SetCursorSize(16*256);
  GotoXY(10, 5);
  Write('1 :  Скорость');
  {GotoXY(10, 10);
  Write('2 :  Установить Клавиши');}
  GotoXY(10, 15);
  Write('3 :  Завершить настроики');
  GotoXY(1,1);
  Case readkey of
    '1' : begin
            GotoXY(12,20);
            Write('Введите скорость 1..10 (5) ');
            repeat
             Readln(max.sp);
            until (max.sp > 0) and (max.sp < 11);
           end;
    '2' : begin
        end;
    end;
end;{setup}
{--------------------------------------------------------}
Procedure Stat1;
begin
  TextColor(Yellow);
  GotoXY(15,3);
  Write('    ');
  GotoXY(15,3);
  Write(bg1-21);
  GotoXY(15,5);
  Write('    ');
  GotoXY(15,5);
  Write(bg2-2);
  GotoXY(15,7);
  Write(col);
  GotoXY(15,9);
  Write(num);
  GotoXY(bg1,bg2);
  TextColor(cl);
end; {stat}
{--------------------------------------------------------}
Procedure StatMain;
Var n,k : byte;
begin
  N := 0;
  DrawTable;
  TextColor(Yellow);
  GotoXY(1,3);
  Write('X           : ');
  GotoXY(1,5);
  Write('Y           : ');
  GotoXY(1,7);
  Write('Длина змея  : ');
  GotoXY(1,9);
  Write('Число ходов : ');
  GotoXY(7,12);
  TextColor(LightBlue);
  Write('Лучшие ');
  TextColor(LightGreen);
  for n := 1 to 10 do begin
    GotoXY(2,13 + n);
    Write(max.name[n], Max.score[n]:(17 - length(max.name[n])));
  end;
  for n := 3 to 24 do
    for k := 21 to 79 do
      a[k,n] := 0;
end; {StatMain}
{------------------------------------------------}
Procedure Apple;
Var i,j,c,b1,b2 : byte;
begin
  randomize;
  cl := now;
  repeat
    i := random(78);
    j := random(23);
    c := random(9);
    r := random(14);
  until (i > 20) and (i < 80) and (j > 2 ) and (j < 25)
  and (c <> 0) and (a[i,j] = 0) and (r <> 0) and (r <> 7) and (r <> cl);
  b1 := WhereX;
  b2 := WhereY;
  GotoXY(i,j);
  TextColor(r);
  Now := r;
  Write(c);
  TextColor(cl);
  a[i,j] := - c;
  now := r;
  GotoXY(b1,b2);
end;
{-------------------------------------------------------}
Procedure Ext;
var
 Gd, Gm :integer;
 h : char;
 k : byte;
begin
  Sound(100);
  Delay(2000);
  Nosound;
  Rcrd := true;
  For k := 1 to 10 do
    if col > max.score[k] then begin
        Recrd(k);
        rcrd := false;
      end;
  FullClnbuf;
  Gd := Detect;
  InitGraph(Gd, Gm, '');
  if GraphResult <> grOk then Halt(1);
  ClearDevice;
  SetColor(Magenta);
  SetTextStyle(TriplexFont, HorizDir,10);
  OutTextXY(150,100,'Game');
  OutTextXY(170,200,'OveR');
  SetColor(Green);
  SetTextStyle(SmallFont, HorizDir,20);
  OutTextXY(180,430,'Another Game ? ');
  h := readkey;
  if (h = 'y') or (h = 'Y') then
    begin
      CloseGraph;
      Game;
    end;
  Close(Tbl);
  Halt;
end; {Ext}
{-------------------------------------------------------}
Procedure StartUp;
var
  Gd, Gm : Integer;
begin
  Gd := Detect;
  InitGraph(Gd, Gm, '');
  if GraphResult <> grOk then Halt(1);
  ClearDevice;
  SetColor(Blue);
  SetTextStyle(3, HorizDir,8);
  OutTextXY(80,100,'Game Piton');
  SetTextStyle(2,HorizDir,5);
  SetColor(LightGreen);
  OutTextXY(230,460,'Game PITON written in 1998 by Kesha Enikeew AKA Ray');
  SetColor(White);
  SetTextStyle(1,HorizDir,2);
  OutTextXY(20,400,'Press "S" for Setup, "Q" to Quit, any other to continue');
  case ReadKey of
    's','S' : setup;
    'q','Q' : begin
                CloseGraph;
                halt;
              end;
  end;
  CloseGraph
end; {StartUp}
{------------------==================-------------------}
Procedure DrawTable;
 var y:integer;
 begin
   clrscr;
   TextColor(blue);
   GotoXY(40,2);
   Write('Game PITON');
   TextColor(7);
   for y := 20 to 79 do
     begin
       GotoXY(y, 3);
       Write('═');
       GotoXY(y, 25);
       Write('═');
     end;
   Write('╝');
   GotoXY(80, 2);
   Write('╗');
   For y := 3 to 23 do
     begin
       GotoXY(20, y);
       Write ('║');
       GotoXY(WhereX-1, WhereY + 1);
       Write('╚');
       GotoXY(80, y);
         Write ('║')
      end;
   GotoXY(20,2);
   Write('╔');
end; {DrawTable}
{-------------------------------------------------------}
Procedure Game;
Var y : byte;
begin
  Now := 7;
  SetCursorSize(16*256);
  ClrScr;
  TextBackGround(0);
  assign(Tbl,'hiscore.dat');
  {$I-}
  Reset(Tbl);
  {$I+}
  if IOResult <> 0 then
    ReWrite(tbl);
  FindFirst('Hiscore.dat',AnyFile,s);
  if s.size = 0 then
    begin
      if max.sp = 0 then
        max.sp := 5 ;
      max.Score[1] := 9;
      max.name[1] := 'Coder';
      Seek(tbl,0);
      Write(tbl,max);
      Close(tbl);
      Reset(tbl);
    end;
  {$I-}
  Read(tbl,max);
  {$I+}
  If IOResult <> 0 then Halt;
  StatMain;
  cl := 7;
  TextColor(7);
  e := 1;
  en[1] := 39;
  en[2] := 13;
  Num := 1;
  Dir := 1;
  b := 10;
  FullClnBuf;
  col := 9;
  a[39,13] := 1;
  GotoXY(40,13);
  repeat
    ai;
    l := 0;
    if keypressed or (c = #27) or (w = 77) or (w = 75) then
      begin
        if (c <> #27) and (w <> 77) and (W <> 75) then c := readkey;
        if c = #0 then
          Begin
            if (w <> 77) and (w <> 75) then w := ord(readkey);
            if (w = 77) or (w = 75) then
              begin
                l := 1;
                case w of

                 77 : case dir of
                       1 : begin
                             if WhereX > 79 then ext;
                             if a[whereX,WhereY] > 0 then ext;
                             if a[WhereX,WhereY] < 0 then
                               begin
                                 b := b - a[WhereX,WhereY];
                                 inc(col,-a[whereX,WhereY]);
                                 TextColor(now);
                               end;
                             Write('╗');
                             inc(num);
                             a[WhereX-1,WhereY] := Num;
                             dir := 2;
                             if b > 0 then dec(b);
                           end;
                       2 : begin
                             if (WhereY + 1) > 23 then ext;
                             if a[whereX-1,WhereY+1] > 0 then ext;
                             if a[WhereX-1,WhereY+1] < 0 then
                               begin
                                 b := b - a[WhereX-1,WhereY+1];
                                 inc(col, -a[WhereX-1,WhereY+1]);
                                 TextColor(now);
                               end;
                             GotoXY(WhereX-1,WhereY+1);
                             Write('╝');
                             inc(num);
                             a[WhereX-1,WhereY] := Num;
                             dir := 3;
                             if b > 0 then dec(b);
                           end;
                       3 : begin
                             if (WhereX - 2) < 21 then ext;
                             if a[whereX-2,WhereY] > 0 then ext;
                             if a[WhereX-2,WhereY] < 0 then
                               begin
                                 b := b - a[WhereX-2,WhereY];
                                 inc(col, -a[WhereX-2,WhereY]);
                                 TextColor(now);
                               end;
                             GotoXY(WhereX-2,WhereY);
                             Write('╚');
                             inc(num);
                             a[WhereX-1,WhereY] := num;
                             if b > 0 then dec(b);
                             Dir := 4
                           end;
                       4 : begin
                             if (WhereY - 1) < 3 then ext;
                             if a[whereX-1,WhereY-1] > 0 then ext;
                             if a[WhereX-1,WhereY-1] < 0 then
                               begin
                                 b := b - a[WhereX-1,WhereY-1];
                                 inc(col, -a[WhereX-1,WhereY-1]);
                                 TextColor(now);
                               end;
                             GotoXY(WhereX-1,WhereY-1);
                             Write('╔');
                             inc(num);
                             a[WhereX-1,WhereY] := Num;
                             if b > 0 then dec(b);
                             Dir := 1
                           end;
                       end;
                75 : case dir of
                       1 : begin
                             if WhereX > 79 then ext;
                             if a[whereX,WhereY] > 0 then ext;
                             if a[WhereX,WhereY] < 0 then
                               begin
                                 b := b - a[WhereX,WhereY];
                                 inc(col, -a[WhereX,WhereY]);
                                 TextColor(now);
                               end;
                             Write('╝');
                             inc(num);
                             a[WhereX-1,WhereY] := Num ;
                             if b > 0 then dec(b);
                             dir := 4
                           end;
                       2 : begin
                             if WhereY + 1 > 23 then ext;
                             if a[whereX-1,WhereY+1] > 0 then ext;
                             if a[WhereX-1,WhereY+1] < 0 then
                               begin
                                 b := b - a[WhereX-1,WhereY+1];
                                 inc(col, -a[WhereX-1,WhereY+1]);                               TextColor(now);
                               end;
                             GotoXY(WhereX-1,WhereY + 1);
                             Write('╚');
                             inc(num);
                             a[WhereX-1,WhereY] := Num;
                             if b > 0 then dec(b);
                             dir := 1;
                           end;
                       3 : begin
                             if WhereX - 2 < 21 then ext;
                             if a[whereX-2,WhereY] > 0 then ext;
                             if a[WhereX-2,WhereY] < 0 then
                               begin
                                 inc(b, - a[WhereX-2,WhereY]);
                                 inc(col, -a[WhereX-2,WhereY]);
                                 TextColor(now);
                               end;
                             GotoXY(WhereX-2,WhereY);
                             Write('╔');
                             inc(num);
                             a[WhereX-1,WhereY] := num;
                             if b > 0 then dec(b);
                             Dir := 2
                           end;
                       4 : begin
                             if WhereY - 1 < 3 then ext;
                             if a[whereX-1,WhereY-1] > 0 then ext;
                             if a[WhereX-1,WhereY-1] < 0 then
                               begin
                                 b := b - a[WhereX-1,WhereY-1];
                                 inc(col, -a[WhereX-1,WhereY-1]);
                                 TextColor(now);
                                end;
                             GotoXY(WhereX-1,WhereY - 1);
                             Write('╗');
                             inc(num);
                             a[WhereX-1,WhereY] := num ;
                             if b > 0 then dec(b);
                             Dir := 3
                            end;
                 end;
              end;
            end;
          end
        else if c = #27 then Ext;
      end;
      begin
        if l = 0 then
          begin
            case dir of
            1 : if WhereX > 79 then ext
                else
                  if a[WhereX,WhereY] > 0 then ext
                  else
                   begin
                      if a[WhereX,WhereY] < 0 then
                        begin
                          b:=b-a[WhereX,WhereY];
                          inc(col,-a[whereX,WhereY]);
                          TextColor(now);
                        end;
                      Write('═');
                      inc(num);
                      a[WhereX-1,WhereY] := Num;
                      if b > 0 then b := b - 1;
                    end;
            2: if (WhereY + 1) > 23 then ext
               else
                  if a[WhereX-1,WhereY+1] > 0 then ext
                  else
                    begin
                      if a[WhereX-1,WhereY+1] < 0 then
                        begin
                          b := b-a[WhereX-1,WhereY+1];
                          inc(col, -a[WhereX-1,WhereY+1]);
                          TextColor(now);
                        end;
                      GotoXY(WhereX-1,WhereY+1);
                      Write('║');
                      inc(num);
                      a[WhereX-1,WhereY] := Num;
                      if b > 0 then b := b - 1;
                    end;
            3 : if (WhereX-2) < 21 then ext
                else
                  if a[WhereX-2,WhereY] > 0 then ext
                  else
                    begin
                      if a[WhereX-2,WhereY] < 0 then
                        begin
                          b:=b-a[WhereX-2,WhereY];
                          inc(col, -a[WhereX-2,WhereY]);
                          TextColor(now);
                        end;
                      GotoXY(Wherex-2,WhereY);
                      Write('═');
                      inc(Num);
                      a[WhereX-1,WhereY] := Num ;
                      if b > 0 then dec(b);
                    end;
            4 : if (WhereY - 1) < 3 then ext
               else
                  if a[WhereX-1,WhereY-1] > 0 then ext
                  else
                    begin
                      if a[WhereX-1,WhereY-1] < 0 then
                        begin
                          b := b - a[WhereX-1,WhereY-1];
                          inc(col, -a[WhereX-1,WhereY-1]);
                          TextColor(now);
                        end;
                      GotoXY(WhereX-1,WhereY-1);
                      Write('║');
                      inc(Num);
                      a[WhereX-1,WhereY] := Num ;
                      if b > 0 then dec(b);
                    end;
           end;
         end;
    end;
    Stat1(WhereX,WhereY);
    if b = 0 then
      begin
        bg[1] := WhereX;
        bg[2] := WhereY;
        GotoXY(en[1],en[2]);
        Write(' ');
        a[WhereX-1,WhereY] := 0;
        en[1] := Last(e) mod 100;
        en[2] := Last(e) div 100;
        GotoXY(bg[1],bg[2]);
        inc(e);
      end;
  ClnBuf;
  Delay(1000);
  test := true;
  for i := 21 to 79 do
    for j := 3 to 24 do
      if a[i,j] < 0 then test := false;
  if test then apple;
  until false;
end;
Begin
  StartUp;
  Game;
end.