змейка

Uses Graph,crt;
 
type mas1=array[1..100] of integer;
type mas2=array[1..100] of integer;
 
{tablica znacheniy}
procedure znachenie(st:string;st2:string;st3:string);
var i:integer;
begin
  setcolor(2);
  line (32,12,512,12);
  line (32,12,32,460);
  line (32,460,512,460);
  line (512,12,512,460);
  setcolor(1);
  line (520,12,getmaxx-28,12);
  line (520,12,520,460);
  line (520,460,getmaxx-28,460);
  line (getmaxx-28,460,getmaxx-28,12);
  setcolor(4);
  settextstyle(0,0,1);
  setcolor(14);
  outtextxy(getmaxx-105,20,'"ZMEIKA"');
  setcolor(4);
  outtextxy(getmaxx-105,60,'Uroven:');
  settextstyle(1,0,6);
  outtextxy(getmaxx-90,70,st2);
  settextstyle(0,0,1);
  outtextxy(getmaxx-105,140,'Czizni:');
  settextstyle(1,0,6);
  outtextxy(getmaxx-90,150,st3);
  settextstyle(0,0,1);
  outtextxy(getmaxx-105,220,'Ballov:');
  settextstyle(1,0,6);
  outtextxy(getmaxx-90,230,st);
  settextstyle(0,0,1);
  outtextxy(getmaxx-105,getmaxy-30,'Exit-ESC');
end;
 
 
{proverka na vihod za granicu}
procedure prov(x:integer;y:integer;var chisl:byte);
begin
  if (x>=512) then begin chisl:=1;exit;end
  else
    if (y>=460) then begin chisl:=2;exit;end
    else
      if (x<=32) then begin chisl:=3;exit;end
      else
        if (y<=12) then begin chisl:=4;exit;end
  else chisl:=0;
end;
 
 
{proverkana konec urovnja}
function garn(kol1:integer;kol2:integer;v:integer):boolean;
var j:integer;
    st:string;
begin
  garn:=true;
  if (kol1=20) then begin
  j:=1;
  str(kol2,st);
  while not keypressed do
  begin
    setcolor(random(15)+1);
    settextstyle(1,0,7);
    outtextxy((getmaxx -50)-j,getmaxy div 2-60,st);
    outtextxy((getmaxx -30)-j,getmaxy div 2-60,' uroven proiden');
    inc(j);
    if j=1200 then exit;
    setcolor(15);
    settextstyle(2,0,6);
    outtextxy(getmaxx -280,getmaxy -20,'Naczmite lubuju klavishu...');
    delay(1000);
    cleardevice;
  end;
  garn:=false;
  delay(v);
  delay(v);
  delay(v);
  end else garn:=true;
end;
 
{pervyi uroven}
procedure uroven1(kol:integer;x:integer;y:integer;var proverka:boolean;V:integer);
var i:integer;
    a:mas1;
    b:mas2;
begin
  if kol=1 then begin
                  setcolor(4);
                  setfillstyle(1,14);
                  delay(v);
                  fillellipse(x,y,8,8);
                  delay(v);
                  setcolor(4);
                  a[1]:=x;
                  b[1]:=y;
                end
           else
  begin
 
    for  i:=1 to kol do if (x=a[i]) and (y=b[i]) then begin proverka:=false;exit;end;
    for i:=kol downto 1 do
    begin
      a[i+1]:=a[i];
      b[i+1]:=b[i];
    end;
    a[1]:=x;
    b[1]:=y;
    setcolor(4);
    setfillstyle(1,14);
    for i:=1 to kol do
    begin
      if i=1 then begin setfillstyle(1,9);fillellipse(a[i],b[i],8,8);end
      else begin setfillstyle(1,14);fillellipse(a[i],b[i],8,8);end
    end;
    delay(v);
    delay(v);
  end;
end;
 
 
procedure uroven2(kol:integer;x:integer;y:integer;var proverka:boolean;v:integer);
var i:integer;
    a:mas1;
    b:mas2;
begin
  setcolor(14);
  rectangle(64,76,128,204);
  rectangle(256,236,320,364);
  rectangle(416,76,480,204);
  setfillstyle(1,4);
  floodfill(90,90,14);
  floodfill(260,240,14);
  floodfill(430,90,14);
  if kol=1 then begin
                  if (x>64) and (x<128) and (y>76) and (y<204) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  if (x>256) and (x<320) and (y>236) and (y<364) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  if (x>416) and (x<480) and (y>76) and (y<204) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  setcolor(4);
                  setfillstyle(1,14);
                  delay(v);
                  fillellipse(x,y,8,8);
                  delay(v);
                  setcolor(4);
                  a[1]:=x;
                  b[1]:=y;
                end
           else
  begin
 
    if (x>64) and (x<128) and (y>76) and (y<204) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
    if (x>256) and (x<320) and (y>236) and (y<364) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
    if (x>416) and (x<480) and (y>76) and (y<204) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
 
    for  i:=1 to kol do if (x=a[i]) and (y=b[i]) then begin proverka:=false;exit;end;
    for i:=kol downto 1 do
    begin
      a[i+1]:=a[i];
      b[i+1]:=b[i];
    end;
    a[1]:=x;
    b[1]:=y;
    setcolor(4);
    setfillstyle(1,14);
    for i:=1 to kol do
    begin
      if i=1 then begin setfillstyle(1,9);fillellipse(a[i],b[i],8,8);end
      else begin setfillstyle(1,14);fillellipse(a[i],b[i],8,8);end
    end;
    delay(v);
    delay(v);
  end;
end;
 
procedure uroven3(kol:integer;x:integer;y:integer;var proverka:boolean;v:integer);
var i:integer;
    a:mas1;
    b:mas2;
begin
  setcolor(4);
  rectangle(128,108,176,412);
  rectangle(128,60,432,108);
  rectangle(384,108,432,412);
  setfillstyle(1,4);
  floodfill(130,110,4);
  floodfill(130,70,4);
  floodfill(390,110,4);
  if kol=1 then begin
                  if (x>128) and (x<176) and (y>108) and (y<412) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  if (x>128) and (x<432) and (y>60) and (y<180) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  if (x>384) and (x<108) and (y>432) and (y<412) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  setcolor(4);
                  setfillstyle(1,14);
                  delay(v);
                  fillellipse(x,y,8,8);
                  delay(v);
                  setcolor(4);
                  a[1]:=x;
                  b[1]:=y;
                end
           else
  begin
 
    if (x>128) and (x<176) and (y>108) and (y<412) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  if (x>128) and (x<432) and (y>60) and (y<180) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
                  if (x>384) and (x<108) and (y>432) and (y<412) then begin  proverka:=false;exit;end
                                                 else proverka:=true;
 
    for  i:=1 to kol do if (x=a[i]) and (y=b[i]) then begin proverka:=false;exit;end;
    for i:=kol downto 1 do
    begin
      a[i+1]:=a[i];
      b[i+1]:=b[i];
    end;
    a[1]:=x;
    b[1]:=y;
    setcolor(4);
    setfillstyle(1,14);
    for i:=1 to kol do
    begin
      if i=1 then begin setfillstyle(1,9);fillellipse(a[i],b[i],8,8);end
      else begin setfillstyle(1,14);fillellipse(a[i],b[i],8,8);end
    end;
    delay(v);
    delay(v);
  end;
end;
 
 
procedure proverka_uroven_2(x1:integer;y1:integer; var prov_ur_2:boolean);
begin
  if (x1>64) and (x1<128) and (y1>76) and (y1<204) then begin  prov_ur_2:=false;exit;end
                                                 else prov_ur_2:=true;
    if (x1>256) and (x1<320) and (y1>236) and (y1<364) then begin  prov_ur_2:=false;exit;end
                                                 else prov_ur_2:=true;
    if (x1>416) and (x1<480) and (y1>76) and (y1<204) then begin  prov_ur_2:=false;exit;end
                                                 else prov_ur_2:=true;
end;
 
procedure proverka_uroven_3(x1:integer;y1:integer; var prov_ur_3:boolean);
begin
  if (x1>128) and (x1<176) and (y1>108) and (y1<412) then begin  prov_ur_3:=false;exit;end
                                                 else prov_ur_3:=true;
                  if (x1>128) and (x1<432) and (y1>60) and (y1<180) then begin  prov_ur_3:=false;exit;end
                                                 else prov_ur_3:=true;
                  if (x1>384) and (x1<108) and (y1>432) and (y1<412) then begin prov_ur_3:=false;exit;end
                                                 else prov_ur_3:=true;
end;
 
 
Var  grDriver:Integer;
     grMode:Integer;
     ErrCode:Integer;
 
     {peremennye}
     x,y,i,j,x1,y1,kol1,kol2,n,v:integer;
     f,proverka,proverka2,prov2,prov_ur_2,prov_ur_3:boolean;
     k:char;
     st1,st2,st3,st4:string;
     l,chisl,bf,czizn,zader,nomer_urovnja,sz:byte;
 
Begin
  {nastroika graficheskogo modulja}
  grDriver:=Detect;
  InitGraph(grDriver, grMode, 'e:\tp\bgi');
  ErrCode:=GraphResult;
 
  {nachalo}
  setcolor(4);
  settextstyle(4,0,10);
  outtextxy(getmaxx div 2-150,getmaxy div 2-100,'Start');
  setcolor(15);
  settextstyle(2,0,6);
  outtextxy(getmaxx -280,getmaxy -20,'Naczmite lubuju klavishu...');
  settextstyle(0,0,1);
  readkey;
 
  randomize;
 
  f:=true;
  l:=0;
  x:=40;
  y:=20;
  v:=12000;
  czizn:=3;
  kol1:=1;
  kol2:=3;
  chisl:=0;
  proverka:=true;
  proverka2:=true;
  bf:=0;
  zader:=0;
 
  x1:=random(29)+1; x1:=x1*16+24;
  y1:=random(27)+1; y1:=y1*16+4;
 
  {1-yi uroven}
  while f<>false do
  begin
    {upravlenie klavishami}
    if keypressed then
    begin
      k:=readkey;
      if k=#27 then f:=false;
      if k=#77 then l:=1;
      if k=#80 then l:=2;
      if k=#75 then l:=3;
      if k=#72 then l:=4;
    end;
 
    {nadpis,urovni}
    inc(zader);
    if (zader<10) then begin
                         setcolor(random(15)+1);
                         settextstyle(4,0,7);
                         str(kol2,st3);
                         outtextxy(130,180,st3);
                         outtextxy(140,180,'  uroven ');
                       end;
 
    {kontrol upravlenija}
    if (bf=0) then bf:=l else
    if ((l=1) and (bf=3)) or ((l=2) and (bf=4)) or ((l=3) and (bf=1)) or ((l=4) and (bf=2))
    then l:=bf else bf:=l;
 
    if l=1 then x:=x+16;
    if l=2 then y:=y+16;
    if l=3 then x:=x-16;
    if l=4 then y:=y-16;
 
    {esli zmeika dostigla shar}
    if (x=x1) and (y=y1) then begin
                                if (kol2=3) then
                                begin
                                  x1:=random(29)+1;
                                  x1:=x1*16+24;
                                  y1:=random(27)+1;
                                  y1:=y1*16+4;
                                  inc(kol1);
                                end
 
 
                                else if (kol2=2) then
                                begin
                                  repeat
                                    x1:=random(29)+1;x1:=x1*16+24;
                                    y1:=random(27)+1;y1:=y1*16+4;
                                    prov_ur_2:=true;
                                    proverka_uroven_2(x1,y1,prov_ur_2);
                                    if (prov_ur_2=true) then inc(kol1);
                                  until (prov_ur_2=true);
                               end
                                 else if (kol2=3) then
                                begin
                                  repeat
                                    x1:=random(29)+1;x1:=x1*16+24;
                                    y1:=random(27)+1;y1:=y1*16+4;
                                    prov_ur_3:=true;
                                    proverka_uroven_3(x1,y1,prov_ur_3);
                                    if (prov_ur_3=true) then inc(kol1);
                                  until (prov_ur_3=true);
                               end;
 
                             end
                             else  begin
                                     setcolor(2);
                                     setfillstyle(1,15);
                                     fillellipse(x1,y1,8,8);
                                     str(kol1,st1);
                                     str(kol2,st2);
                                     str(czizn,st3);
                                     znachenie(st1,st2,st3);
                                     setcolor(4);
                                   end;
 
  {proverka na konec urovnja}
  if garn(kol1,kol2,v)=false then begin
                                    inc(kol2);
                                    kol1:=1;
                                    x:=40;
                                    y:=20;
                                  end;
 
  setcolor(4);
  prov(x,y,chisl);
  if (chisl=0) then begin
                      if (kol2=1) then begin
                                         uroven1(kol1,x,y,proverka,v);
                                       end;
 
                      if (kol2=2) then uroven2(kol1,x,y,proverka,v);
                      if (kol2=3) then uroven3(kol1,x,y,proverka,v);
                    end
  else if (chisl=1) then x:=24
        else if (chisl=2) then y:=4
              else if (chisl=3) then x:=520
                   else if (chisl=4) then y:=468;
  if proverka=false then begin
                           setcolor(15);
                           settextstyle(0,0,3);
                           outtextxy(140,180,'Stolknovenie !');
                           settextstyle(2,0,7);
                           dec(czizn);
                           if (czizn=0) then begin
                                               outtextxy(130,228,'Vy proigrali! Konec Igry');
                                               readln;
                                               halt;
                                               end
                                          else begin
                                                 proverka:=true;
                                                 kol1:=1;
                                                 x:=40;
                                                 y:=20;
                                                 outtextxy(220,430,'Naczmite lubuju klavishu!');
                                                 readln;
                                                 end;
                          end;
    cleardevice;
  end;
  closegraph;
end.