veryinterestinggame

program VERYINTERESTINGGAME_rip_PrO100AnRuWka1337;
uses crt;
//паскаль охуенен)
const
  dy = 65;
  nmax=15;
  mmax=21;
  tmax=10;
  start_health=3;
  you = '&';
  wall = '█';
  trap = '*';
  star = '$';
  emp = ' ';
  t  = '@';
  heart = '¤';
Type Tfield = array[0..nmax+1,0..mmax+1] of char;
Type Tteleports = array[1..tmax] of record
  f:record
    x:integer;
    y:integer;
  end;
  t:record
    x:integer;
    y:integer;
  end;
end;
var buf:char; teleports:Tteleports; stars_on_field,health,youx,youy:integer;
procedure set_vertical_wall(var field:Tfield; x,y,length:integer);
  var i:integer;
  begin
      i:=x;
      while (i<=nmax)and(i<x+length) do
      begin
        field[i,y]:=wall;
        inc(i);
      end;
  end;
procedure set_horizontal_wall(var field:Tfield; x,y,length:integer);
  var j:integer;
  begin
      j:=y;
      while (j<=mmax)and(j<y+length) do
      begin
        field[x,j]:=wall;
        inc(j);
      end;
  end;
procedure add_tp(var field:Tfield; var teleports:Tteleports; x1,y1,x2,y2:integer);
  var i:integer;
  begin
    i:=tmax;
    while (i>0)and(teleports[i].f.x=0) do
      dec(i);
    inc(i);
    teleports[i].f.x:=x1;
    teleports[i].f.y:=y1;
    teleports[i].t.x:=x2;
    teleports[i].t.y:=y2;
    field[x1,y1]:=t;
    field[x2,y2]:=t;
    teleports[i+1].t.x:=x1;
    teleports[i+1].t.y:=y1;
    teleports[i+1].f.x:=x2;
    teleports[i+1].f.y:=y2;
  end;
procedure set_you(var field:Tfield; x,y:integer);
  begin
    field[x,y]:=you;
    youx:=x;
    youy:=y;
  end;
procedure add_star(var field:Tfield; x,y:integer);
  begin
    if field[x,y]<>star then
    begin
      field[x,y]:=star;
      inc(stars_on_field);
    end;
  end;
procedure init_tp;
  var i:integer;
  begin
    for i:=1 to tmax do
    begin
      teleports[i].f.x:=0;
      teleports[i].f.y:=0;
    end;
  end;
procedure init(var field:Tfield; var stars:integer);
  var i,j:integer;
  begin
    stars_on_field:=-1;
    health:=start_health;
    buf:=emp;
    init_tp;
    for i:=1 to nmax do
      for j:=1 to mmax do
        field[i,j]:=' ';
    for i:=0 to nmax+1 do
    begin
      field[i,0]:=wall;
      field[i,mmax+1]:=wall;
    end;
    for j:=0 to mmax+1 do
    begin
      field[0,j]:=wall;
      field[nmax+1,j]:=wall;
    end;

    set_horizontal_wall(field,1,11,7);
    set_horizontal_wall(field,2,9,3);
    field[3,11]:=wall;
    set_vertical_wall(field,1,13,3);
    field[2,18]:=wall;
    field[3,19]:=wall;
    field[4,20]:=wall;
    j:=2;
    for i:=12 downto 5 do
    begin
        field[i,j]:=wall;
        inc(j);
    end;
    j:=2;
        for i:=12 to 15 do
    begin
        field[i,j]:=wall;
        inc(j);
    end;
    set_horizontal_wall(field,15,5,7);
    field[3,3]:=wall;
    field[3,5]:=wall;
    set_horizontal_wall(field,4,2,5);
    field[5,2]:=wall;
    field[5,6]:=wall;
    field[6,3]:=wall;
    field[6,5]:=wall;
    field[7,4]:=wall;
    field[9,1]:=wall;
    field[4,9]:=wall;
    j:=19;
    for i:=5 to 11 do
    begin
        field[i,j]:=wall;
        dec(j);
    end;
    field[12,13]:=wall;
    set_vertical_wall(field,5,12,5);
    set_vertical_wall(field,7,10,5);
    set_vertical_wall(field,7,9,3);
    set_vertical_wall(field,7,13,3);
    set_vertical_wall(field,10,7,3);
    field[11,6]:=wall;
    field[11,8]:=wall;
    set_vertical_wall(field,4,15,3);
    field[5,14]:=wall;
    field[5,16]:=wall;
    set_vertical_wall(field,13,9,2);
    set_vertical_wall(field,13,11,2);
    field[14,12]:=wall;
    field[14,13]:=wall;
    set_horizontal_wall(field,11,16,5);
    field[10,17]:=wall;
    field[10,19]:=wall;
    field[12,16]:=wall;
    field[12,20]:=wall;
    field[13,17]:=wall;
    field[13,19]:=wall;
    field[14,18]:=wall;
    field[8,21]:=wall;
    for i:=2 to 9 do
    begin
        add_star(field,1,i);
        if i<9 then add_star(field,i,1);
    end;
    for i:=14 downto 9 do
      add_star(field,i,21);
    for i:=19 downto 13 do
       add_star(field,15,i);
    for i:=1 to 4 do
      add_star(field,15,i);
    for i:=18 to 21 do
      add_star(field,1,i);
    for i:=10 to 12 do
      add_star(field,4,i);
    add_star(field,5,10);
    for i:=9 to 11 do
      add_star(field,6,i);
    add_star(field,7,11);
    add_star(field,8,10);
    add_star(field,8,12);
    add_star(field,9,11);
    add_star(field,7,6);
    add_star(field,9,4);
    add_star(field,2,8);
    add_star(field,10,5);
    add_star(field,9,7);
    add_star(field,5,4);
    add_star(field,2,12);
    add_star(field,14,10);
    add_star(field,12,10);
    add_star(field,11,11);
    add_star(field,10,13);
    add_star(field,7,16);
    add_star(field,6,17);
    add_star(field,3,18);
    add_star(field,9,16);
    add_star(field,7,18);
    add_star(field,6,19);
    add_star(field,5,20);
    add_star(field,14,14);
    add_star(field,12,18);
    field[1,1]:=trap;
    for i:=7 to 9 do
      field[i,2]:=trap;
    field[11,2]:=trap;
    field[14,2]:=trap;
    field[11,5]:=trap;
    field[5,11]:=trap;
    field[7,12]:=trap;
    field[9,10]:=trap;
    field[3,16]:=trap;
    field[6,17]:=trap;
    field[3,20]:=trap;
    field[6,20]:=trap;
    for i:=8 to 10 do
      field[i,20]:=trap;
    field[11,18]:=trap;
    field[4,4]:=trap;
    field[2,14]:=heart;
    field[14,8]:=heart;
    add_tp(field,teleports,9,1,8,21);
    add_tp(field,teleports,1,10,6,4);
    add_tp(field,teleports,13,18,15,12);
    set_you(field,8,11);
  end;
function decode(s:string):string;
  var i:integer;
  begin
    result:='';
    for i:=1 to length(s) do
      result:=result+chr(ord(s[i])-17);
  end;
function find_stars_on_field(field:tfield):integer;
  var i,j:integer;
  begin
    result:=0;
    for i:=1 to nmax do
      for j:=1 to mmax do
        if field[i,j]=star then
          inc(result);
  end;
procedure write_field(field:Tfield);
  var i,j:integer;
  begin
    for i:=0 to nmax+1 do
    begin
      for j:=0 to mmax+1 do
        write(field[i,j]);
      writeln();
    end;
    writeln('  ',star,' осталось: ', stars_on_field);
    writeln;
    writeln('    здоровье: ', health);
  end;

procedure clean;
  begin
      clrscr;
      writeln('                    KEK_GAME   ');
      writeln;
  end;
procedure show_start_dialog;
  var ok:char;
  begin
    writeln('                    KEK_GAME   ');
    writeln('  привет, Настя! Эта топовая игра для тебя :D');
    writeln('Управление через WASD: w - вверх, a - влево, s - вниз, d - вправо');
    writeln('             === Правила ===');
    writeln('    ',trap,' = минус нога (с)');
    writeln('    нужно собрать все ',star);
    writeln('    ',heart,' = "плюс нога" :D');
    writeln('    можно пользоваться порталами ',t);
    writeln('                 ты - ',you,'            ');
    writeln('             ===============' );
    writeln('         для старта нажми W ');
    writeln('   (возможно нужно поменять раскладку) ');
    ok:=readKey;
    while ok<>'w' do
      ok:=ReadKey;
  end;
procedure show_lose_dialog(var surr:Boolean);
var s:char; i:integer;
  begin
    writeln;
    writeln;
    writeln('    ты проиграла :)');
    writeln('        поробуй еще,нажми  W  ');
    s:=readkey;
    i:=1;
    while (s<>'w')and(i<30) do
    begin
      inc(i);
      s:=ReadKey;
    end;
    if i=30 then
          surr:=true;
    clean;
  end;
procedure show_win_dialog;
  var s:string; c:char; i:integer;
  begin //+17
    writeln;
    write('       ');
    for i:=1 to 65 do
    begin
        write(wall);
        delay(10);
    end;
    clean;
    writeln('');
    write('      ');
    s:=('ЮсђѓѠ=1ѓќ1ыёєѓсѠ1KU1р1тќ1яјцюѝ1іяѓць1єшюсѓѝ1ѓцтѠ1ѐятьщчц?1Хсусъ1уђѓёцѓщэђѠ1щ1ѐяфєьѠцэ1ѐяђьц1ѓуяцфя1ўышсэцюсP1K:');
    s:=decode(s);
    for i:=1 to 17 do
    begin
      write(s[i]);
      delay(dy);
    end;
    write(s[18],s[19]);
    delay(300);
    for i:=20 to 57 do
    begin
      write(s[i]);
      delay(dy);
    end;
    delay(100);
    writeln;
    write('                 ');
    for i:=58 to s.Length-2 do
    begin
      write(s[i]);
      delay(dy);
    end;
    write(s[i+1],s[i+2]);
    writeln('');
    writeln('_______________________$$_____$$$$$$$$$$$_______$$$_____$$¬______');
    writeln('________________________$_______________$$_______$$_______$______');
    writeln('________________________$_______________$$______$$$$$$$$$$$______');
    writeln('________________________$_______________$$_____$$$$$$$_____$_____');
    writeln('________________________$$_______________$$____$$$$$$$_____$_____');
    writeln('________________________$$________________$$$$$$$$$$$$_____$_____');
    writeln('_______________________$$________________________$$$$_____$______');
    writeln('_______________________$$___________________________$$___$$______');
    writeln('______________________$$______________________________$$$__$_____');
    writeln('______________________$$___________________________________$$____');
    writeln('______________________$$__________________________________$$$$$$$');
    writeln('__________________$$$$$$$______$$$________________$$$______$_____');
    writeln('______________________$$_______$$$________________$$$_____$$_____');
    writeln('_______________________$$______$$$______$$$$______$$$______$$$$$_');
    writeln('____________________$$$$$$$____________$$$$$$____________$$$_____');
    writeln('_________________________$$$______________________________$$_____');
    writeln('________________________$$_$$___________________________$$__$$___');
    writeln('______________________$$_____$$______________________$$$$¬_______');
    writeln('______________________________$$$$$$____________$$$$$$___________');
    write('____________________________________$$$$$$$______________________');
    delay(5500);
    c:=readkey;
   end;
procedure find_you(field:Tfield; var x,y:integer);
  var i,j:integer; found:boolean;
  begin
      found:=false;
      i:=1;
      while (not found)and(i<=nmax) do
      begin
        j:=1;
        while (not found)and(j<=mmax) do
        begin
          if field[i,j]=you then
          begin
            found:=true;
            x:=i;
            y:=j;
          end;
          inc(j);
        end;
        inc(i);
      end;
  end;
procedure tp(var field:Tfield; {'from' changes to 'to':}var x,y:integer);
var i:integer; found:Boolean;
  begin
    i:=1;
    while not found do
    begin
      found:=(teleports[i].f.x=x)and(teleports[i].f.y=y);
      inc(i);
    end;
    dec(i);
    x:=teleports[i].t.x;
    y:=teleports[i].t.y;
  end;
procedure move(var field:Tfield; step:char);
  var x,y,newx,newy:integer;
  begin
    x:=youx;
    y:=youy;
    newx:=x;
    newy:=y;
    case step of
    'w': if x>1 then
            dec(newx);
    'a': if y>1 then
            dec(newy);
    's': if x<nmax then
            inc(newx);
    'd': if y<mmax then
            inc(newy);
    end;
    if field[newx,newy]<>wall then
    begin
      field[youx,youy]:=buf;
      if (field[newx,newy]=trap)or(field[newx,newy]=t) then
          buf:=field[newx,newy]
      else
          buf:=emp;
      case field[newx,newy] of
        heart: begin inc(health); end;
        trap: begin dec(health); end;
        star: begin dec(stars_on_field); end;
        t: begin tp(field,newx,newy) end;
      end;
      set_you(field, newx,newy);
      clean;
      write_field(field);
    end;
  end;
procedure play;
  var win,dead,surr:Boolean; step:char; field:Tfield; stars,collected_stars:integer;
  begin
    while (not surr)and(not win) do
      begin
      win:=false;
      dead:=false;
      collected_stars:=0;
      init(field,stars);
      write_field(field);
      while (not win)and(not dead) do
      begin
          step:=readkey;
          move(field,step);
          win:=stars_on_field=0;
          dead:=health=0;
      end;
      clean;
      if win then
        show_win_dialog
      else
        show_lose_dialog(surr);
    end;
  end;
begin
  show_start_dialog;
  clean;
  play;
end.