program quatris(input,output);
{
  Programm ist die modifizierte Version des de-kompilierten
  Programms QUATRIS.COM, geschrieben von Steven B. Perkins, 1989.
}
{$C-}
const
{ Meldungen }
  ScoreOpt    = 'STAND';
  Programmer  = 'Steven B. Perkins';
  ProgramName = 'Q U A T R I S   2.0';
  Coyright    = 'Copyright 1989 by';
  TotalMs     = 'T O T A L';
  EmpScore    = 'Spielerliste leer';
  ScoreMs     = '          STAND               NAME';
  ChampMs     = ' (Weltbester)';
  AgainMs     = 'Nochmal spielen? ';
  EndScore    = ', dein Endstand: ';
  HitMs       = ' Eingabe <CR>';
  GratMs      = 'Gratulation, ';
  TopTen      = ' du bist unter den 10 Besten!';
  Help1       = ' <- - Nach links      ';
  Help2       = ' ^  - Drehen Uhrzeiger';
  Help3       = ' -> - Nach rechts     ';
  Help4       = ' \/ - Folgender Stein ';
  Help5       = '[+] - Schneller       ';
  Help6       = 'SPC - Stein nach unten';
  Help7       = '                      ';
  Help8       = 'ESC - Abbruch';
  Help9       = 'RET - Cheftaste';
  NameMs      = 'Bitte Namen eingeben: ';
  LevelMs     = 'Welcher Grad ';
  LevelDig    = ' (0-9, 0=schwerster)? ';
  Stat1       = '        GRAD: ';
  Stat2       = '       STAND: ';
  Stat3       = ' REIHEN VOLL: ';
  Prefix      = '          ';
  ClrMs       = '              ';
  noname      = '                 ---';
{ Spielstanddatei }
  ScoreName   ='QUATRIS.SCO';
{ Spielewerte }
  PIECES      = 6;
  USRMAX      = 10;
{ Tasten zur Bewegung - siehe Hilfe in Meldungen oben }
  MoveLeft    = ^A;
  MoveRight   = ^F;
  Rotate      = ^_;
  SpeedUp     = ^V;
  ShowNext    = ^^;
{ Spezielle Tasten }
  cr          = #$0d;
  esc         = #$1b;
{ Koordinaten fuer die Meldungen }
  BoardStart   = 28;
  PieceStart   = 30;
{}
  HomeLine    =  1;
  StatLine    =  2;
  HelpLine    =  6;
  TotalLine   = 18;
  EndLine     = 22;
{ Verzoegerung fuer das Spiel }
  delmin      = 20;       { Min fuer Grad 0     }
  delfac      = 30;       { Max ist 9*30+20=290 }
type
  mstring     = string[20];
  user        = record
                  name:  mstring;
                  score: integer;
                end;
  UserData    = array[1..USRMAX]           of user;
  Piece_fix   = array[0..PIECES,0..1,0..1] of integer;
  board_line  = record
                  state:array[0..29] of boolean;
                end;
const
  xy_adjust   : Piece_fix = (((-1, 0),(-2, 0)),
                             ((-1, 0),( 1, 1)),
                             ((-1, 0),(-1, 1)),
                             ((-1, 1),( 0, 1)),
                             ((-1,-1),( 0,-1)),
                             ((-1, 0),( 0, 1)),
                             (( 0, 1),( 1, 1)));
var
  ScoreList   : UserData;
  ScoreFile   : file             of UserData;
  game_board  : array[0..17]     of board_line;
  PieceArr    : array[0..3]      of integer;
  PieceCount  : array[0..PIECES] of integer;
  CmdChr      : char;
  MaxUser,
  PieceY,
  PieceX,
  yCor,
  PieceIdx,
  rows,
  PieceTotal,
  xcur,
  ycur,
  level,
  score,
  NxtPiece,
  Piece,
  setCtrl     : integer;
  pieceDown,
  ShowMode,
  clrMode     : boolean;
  Player      : mstring;

{ ======================================================== }
{ Die folgenden Routinen behandeln den Spielstand          }
{ und haben mit dem eigentlichen Spiel nichts zu tun       }

procedure SetUpScore;
var
  i           : integer;
begin
  assign(ScoreFile,ScoreName);
  {$I-}reset(ScoreFile);{$I+}
  if (ioresult=0) then
  begin
    read(ScoreFile,ScoreList);
  end else
  begin
    for i:=1 to USRMAX do
    begin
      ScoreList[i].name:=noname;
      ScoreList[i].score:=0;
    end;
  end;
  close(ScoreFile);
end;

procedure getUser;
begin
  MaxUser:=USRMAX+1;
  repeat
    MaxUser:=MaxUser-1;
  until (MaxUser<1)                              OR
        (not (ScoreList[MaxUser].name=noname));
  if (MaxUser<1) then MaxUser:=0
                 else MaxUser:=MaxUser+1;
end;

procedure tell_score;
var
  i           : integer;
begin
  clrscr;
  getUser;
  if (MaxUser=0) then writeln(EmpScore)
  else
  begin
    writeln(ScoreMs);
    for i:=1 to MaxUser-1 do
    begin
      write(Prefix);
      write(ScoreList[i].score:5,ScoreList[i].name:25);
      if (ScoreList[i].score=MAXINT) then writeln(ChampMs)
                                     else writeln;
    end;
    writeln;
    writeln;
  end;
end;

procedure end_game;
var
  usridx      : integer;

  function user_known:boolean;
  var
    match     : boolean;
    i         : integer;
  begin
    usridx:=1;
    repeat
      match:=(length(Player)=length(ScoreList[usridx].name));
      if match then
        for i:=1 to length(Player) do
          if upcase(Player[i])<>upcase(ScoreList[usridx].name[i]) then match:=false;
      usridx:=usridx+1;
    until ((usridx=USRMAX+1) OR match);
    usridx:=usridx-1;
    user_known:=match;
  end;

  procedure SortList;
  { Simple linear search }
  var
    i,j       : integer;
    data      : user;
    sorted    : boolean;
  begin
    for i:=2 to MaxUser do
    begin
      sorted:=false;
      data:=ScoreList[i];
      j:=i-1;
      while (not sorted) AND
            (j>0)           do
            if data.score>ScoreList[j].score then
            begin
              ScoreList[j+1]:=ScoreList[j];
              j:=j-1;
            end else sorted:=true;
      ScoreList[j+1]:=data;
    end;
  end;

  procedure wanna_more;
  begin
    write(AgainMs);
    read(kbd,CmdChr);
    CmdChr:=upcase(CmdChr);
    write(CmdChr);
    if (CmdChr='N') then
    begin
      rewrite(ScoreFile);
      write(ScoreFile,ScoreList);
      close(ScoreFile);
      halt;
    end;
  end;

begin { end_game }
  crtexit;
  gotoxy(1,EndLine);
  write(Player,EndScore,score,HitMs);
  readln(CmdChr);
  getUser;
  if (MaxUser<USRMAX) then
  begin
    if user_known then
      begin
        if (ScoreList[usridx].score<score) then
            ScoreList[usridx].score:=score;
        SortList;
      end else
      begin
        write(GratMs,Player,TopTen,HitMs);
        readln(CmdChr);
        if (MaxUser=0) then MaxUser:=1;
        ScoreList[MaxUser].score:=score;
        ScoreList[MaxUser].name:=Player;
        if not (MaxUser=1) then MaxUser:=MaxUser+1;
        SortList;
      end;
  end else
  begin
    if user_known then
    begin
      if (ScoreList[usridx].score<score) then
          ScoreList[usridx].score:=score;
      SortList;
    end;
  end;
  tell_score;
  wanna_more;
end;

{ ======================================================== }

procedure stop_game;
begin
  gotoxy(1,EndLine);
  crtexit;
  halt;
end;

procedure pos_str(x,y:integer; s:mstring);
begin
  gotoxy(x,y);
  write(s);
end;

procedure get_xy(var xset,yset:integer);
var
  x,y         : integer;
begin
  case setCtrl of
   0 : begin
         x:=+xset;
         y:=+yset;
       end;
   1 : begin
         x:=+yset;
         y:=-xset;
       end;
   2 : begin
         x:=-xset;
         y:=-yset;
       end;
   3 : begin
         x:=-yset;
         y:=+xset;
       end;
  end;
  xset:=xcur+x;
  yset:=ycur+y;
end;

procedure put_xy(xpos:integer;ypos:integer);
begin
  get_xy(xpos,ypos);
  if (ypos>=1) then
  begin
    gotoxy(BoardStart+xpos*2,ypos);
    if clrMode then write('.')
               else write('#');
  end;
end;

procedure disp_piece(DPiece:integer);
begin
  put_xy(0,0);
  put_xy(1,0);
  put_xy(xy_adjust[DPiece,0,0],xy_adjust[DPiece,0,1]);
  put_xy(xy_adjust[DPiece,1,0],xy_adjust[DPiece,1,1]);
end;

function PieceState(vx,vy:integer):boolean;
var
  x,y         : integer;
begin
  x:=vx;
  y:=vy;
  get_xy(x,y);
  PieceState:=(game_board[x].state[pred(y+9)]);
end;

function PieceFlag:boolean;
begin
  PieceFlag:=((PieceState(0,0))                                       OR
              (PieceState(1,0))                                       OR
              (PieceState(xy_adjust[Piece,0,0],xy_adjust[Piece,0,1])) OR
              (PieceState(xy_adjust[Piece,1,0],xy_adjust[Piece,1,1]))     );
end;

procedure InitStat;
begin
  gotoxy(1,27-9);
  writeln(ClrMs);
  writeln(ClrMs);
  writeln(ClrMs);
  if (ShowMode) then
  begin
    xcur:=-8;
    ycur:=BoardStart-9;
    setCtrl:=0;
    disp_piece(NxtPiece);
  end;
end;

procedure put_board;
var
  i,j         : integer;
begin
  for j:=1 to 29-9 do
  begin
    gotoxy(PieceStart,j);
    for i:=1 to 10 do
    begin
      if (game_board[i].state[pred(j+9)]) then write('# ')
                                          else write('. ');
    end;
  end;
end;

procedure init_board;
var
  i           : integer;
begin

{ Hilfe ausgeben }
  gotoxy(1,HelpLine);
  writeln(Help1);
  writeln(Help2);
  writeln(Help3);
  writeln(Help4);
  writeln(Help5);
  writeln(Help6);
  writeln(Help7);
  writeln(Help8);
  writeln(Help9);

{ Spielsteine darstellen }
  pos_str(55, 2,                '# # # #');

  pos_str(65, 3,                '#'    );
  pos_str(65, 4,                '# # #');

  pos_str(59, 5,                    '#');
  pos_str(55, 6,                '# # #');

  pos_str(67, 7,                  '# #');
  pos_str(65, 8,                '# #'  );

  pos_str(55, 9,                '# #'  );
  pos_str(57,10,                  '# #');

  pos_str(67,11,                  '#'  );
  pos_str(65,12,                '# # #');

  pos_str(55,13,                 '# #');
  pos_str(55,14,                 '# #');

  pos_str(74,16,'-----');
  pos_str(60,18,TotalMs);
  pos_str(56,20,ProgramName);
  pos_str(57,21,Coyright);
  pos_str(57,22,Programmer);

{ Spielsteinmenge anzeigen }
  for i:=0 to PIECES do
    pos_str(77,i*2+2,'0');
  pos_str(77,18,'0');

{ Spielfeld aufbauen }
  for i:=1 to 30-9 do
  begin
    pos_str(28,     i,'I');
    pos_str(30+10*2,i,'I');
  end;
  gotoxy(29,30-9);
  for i:=0 to 10*2 do
      write('-');
end;

procedure player_setting;
var
  i, CtrlSav,
  xsav, ysav  : integer;
begin
  CmdChr:='$';
  i:=1;
  repeat
    delay(delmin+level*delfac);
    if keypressed then
    begin
      read(kbd,CmdChr);
      case CmdChr of
{ Bewegung links }
        MoveLeft  : begin
                      clrMode:=true;
                      disp_piece(Piece);
                      clrMode:=false;
                      xcur:=xcur-1;
                      if PieceFlag then xcur:=xcur+1;
                      disp_piece(Piece);
                    end;
{ Bewegung rechts }
        MoveRight : begin
                      clrMode:=true;
                      disp_piece(Piece);
                      clrMode:=false;
                      xcur:=xcur+1;
                      if PieceFlag then xcur:=xcur-1;
                      disp_piece(Piece);
                    end;
{ Im Uhrzeigersinn drehen }
        Rotate :    begin
                      clrMode:=true;
                      disp_piece(Piece);
                      setCtrl:=(setCtrl+3) MOD 4;
                      if PieceFlag then setCtrl:=(setCtrl+1) MOD 4;
                      clrMode:=false;
                      disp_piece(Piece);
                    end;
{ Geschwindigkeit erhoehen }
        SpeedUp :   begin
                      if (level>0) then level:=level-1;
                    end;
{ Naechsten Stein anzeigen }
        ShowNext :  begin
                      ShowMode:=not ShowMode;
                      if ShowMode then score:=score-2;
                      CtrlSav:=setCtrl;
                      xsav:=xcur;
                      ysav:=ycur;
                      InitStat;
                      xcur:=xsav;
                      ycur:=ysav;
                      setCtrl:=CtrlSav;
                    end;
{ Cheftaste - Pause }
       cr   :       begin
                      clrscr;
                      write('A>');
                      read(kbd,CmdChr);
                      if (CmdChr=esc) then stop_game;
                      clrscr;
                      init_board;
                      put_board;
                    end;
{ Spielstein runter }
        ' ' :       begin
                      pieceDown:=true;
                      i:=5;
                    end;
      end;
    end;
    i:=i+1;
  until (i>5);
end;

procedure PopPiece;
var
  i,j         : integer;
begin
  PieceY:=PieceArr[pred(PieceIdx)];
  i:=1;
  while (i<PieceIdx) do
  begin
    if (PieceArr[pred(i)]<PieceY) then
    begin
      PieceArr[pred(PieceIdx)]:=PieceArr[pred(i)];
      PieceArr[pred(i)]:=PieceY;
      PieceY:=PieceArr[pred(PieceIdx)];
    end;
    i:=i+1;
  end;
  for i:=PieceY downto 2 do
    for j:=1 to 10 do
      game_board[j].state[pred(i)]:=game_board[j].state[pred(i-1)];
end;

procedure PushPiece;
var
  i           : integer;
  st          : boolean;
begin
  st:=true;
  PieceY:=PieceY+9;
  game_board[PieceX].state[pred(PieceY)]:=true;
  for i:=1 to 10 do
    if (game_board[i].state[pred(PieceY)]=false) then st:=false;
  if st then
  begin
    PieceArr[PieceIdx]:=PieceY;
    PieceIdx:=PieceIdx+1;
  end;
end;

procedure Push(x,y:integer);
begin
  PieceX:=x;
  PieceY:=y;
  get_xy(PieceX,PieceY);
  PushPiece;
end;

procedure play_game;
var
  stop        : boolean;

  procedure set_up_game;
  var
    i         : integer;
  begin
    clrscr;
    repeat
      gotoxy(1,HomeLine);
      write(NameMs);
      readln(Player);
    until (length(Player)>0);
    Player[1]:=upcase(Player[1]);
    ShowMode:=false;
    for i:=0 to 6 do
      PieceCount[i]:=0;
    rows:=0;
    PieceTotal:=0;
    repeat
      randomize;
      writeln;
      write(LevelMs,Player,LevelDig);
      read(kbd,CmdChr);
      level:=ord(CmdChr)-ord('0');
    until (level in [0..9]);
    crtinit;
    clrscr;
    init_board;
    for i:=1 to 10 do
      for yCor:=1 to 29 do
      begin
        if (yCor<30-9) then pos_str(28+i*2,yCor,'.');
        game_board[i].state[pred(yCor)]:=false;
      end;
    for i:=0 to 10+1 do
      game_board[i].state[pred(30)]:=true;
    for i:=1 to 30 do
    begin
      game_board[   0].state[pred(i)]:=true;
      game_board[10+1].state[pred(i)]:=true;
    end;
    if keypressed then read(kbd,CmdChr);
    score:=0;
    NxtPiece:=random(PIECES+1);
  end;

  procedure play_disp;
  begin
    gotoxy(1,StatLine);
    if (score<0) then score:=MAXINT;
    writeln(Stat1,level);
    writeln(Stat2,score);
    write  (Stat3,rows);
    Piece:=NxtPiece;
    NxtPiece:=random(PIECES+1);
    InitStat;
    setCtrl:=random(4);
    pieceDown:=false;
    xcur:=6;
    ycur:=1;
  end;

  procedure play_it;
  begin
    repeat
      if not pieceDown then
      begin
        clrMode:=false;
        disp_piece(Piece);
        player_setting;
        if (CmdChr=esc) then stop_game else
        begin
          clrMode:=true;
          disp_piece(Piece);
        end;
      end else score:=score+1;
      ycur:=ycur+1;
    until PieceFlag;
    if ShowMode then score:=score-2;
    ycur:=ycur-1;
    score:=score+44-round(10.0*sqrt(int(level)+0.2));
    PieceCount[Piece]:=PieceCount[Piece]+1;
    PieceTotal:=PieceTotal+1;
    gotoxy(75,Piece*2+2);
    write(PieceCount[Piece]:3);
    gotoxy(74,TotalLine);
    write(PieceTotal:4);
    clrMode:=false;
    disp_piece(Piece);
    PieceIdx:=0;
    Push(0,0);
    Push(1,0);
    Push(xy_adjust[Piece,0,0],xy_adjust[Piece,0,1]);
    Push(xy_adjust[Piece,1,0],xy_adjust[Piece,1,1]);
    if (PieceIdx>0) then
    begin
      while (PieceIdx>0) do
      begin
        PopPiece;
        rows:=rows+1;
        PieceIdx:=PieceIdx-1;
      end;
      if ((level>9-(rows div 10)) AND
          (level>0))                  then level:=9-(rows div 10);
      put_board;
    end;
  end;

begin { play_game }
  set_up_game;
  stop:=false;
  repeat
    play_disp;
    if PieceFlag then stop:=true
                 else play_it;
  until stop;
end;

BEGIN { ** M A I N ** }
  SetUpScore;
  if (paramcount=1) then 
  begin
    if (paramstr(1)=ScoreOpt) then tell_score;
  end else
  repeat
    play_game;
    end_game;
  until false;
END.