2048 in Pascal.

2048.pas

uses crt;
const keyUp=72;
      keyDown=80;
      keyLeft=75;
      keyRight=77;
      highscoreFile='2048_highscore.txt';
type board_type=record
      size_h: longint;
      size_v: longint;
      board: array [-1..128, -1..128] of integer;
      merge_board: array [-1..128, -1..128] of boolean;
      score: qword;
     end;
var b: board_type;
    response: char;
    hs_name: array [0..10] of ansistring;
    hs_score: array [0..10] of qword;
procedure initBoard(var board: board_type; m, n: longint);
 var i, i2: longint;
 begin
  with board do begin
   fillchar(board, sizeof(board), 0);
   fillchar(merge_board, sizeof(merge_board), false);
   score:=0;
   size_h:=m;
   size_v:=n;
   for i:=-1 to size_h do begin
    board[-1][i]:=-1;
    board[size_v][i]:=-1;
   end;
   for i:=-1 to size_v do begin
    board[i][-1]:=-1;
    board[i][size_h]:=-1;
   end;
  end;
 end;
function hasEmpty(var board: board_type): boolean;
 var i, i2: longint;
 begin
  with board do
   for i:=0 to size_h-1 do
    for i2:=0 to size_v-1 do
     if board[i][i2]=0 then
      exit(true);
  exit(false);
 end;
function canMove(var board: board_type): boolean;
 const neighbor_x: array [1..4] of longint=(-1, 0, 1, 0);
       neighbor_y: array [1..4] of longint=(0, 1, 0, -1);
 var i, i2, i3: longint;
 begin
  if hasEmpty(board) then
   exit(true);
  with board do
   for i:=0 to size_h-1 do
    for i2:=0 to size_v-1 do
     for i3:=1 to 4 do
      if (board[i-neighbor_x[i3]][i2-neighbor_y[i3]]=board[i][i2]) then
       exit(true);
  exit(false);
 end;
procedure addRandom(var board: board_type);
 var x, y: longint;
 begin
  randomize();
  with board do begin
   repeat
    x:=random(size_h);
    y:=random(size_v);
   until board[x][y]=0;
   board[x][y]:=random(2)+1;
  end;
 end;
procedure movePiece(var board: board_type; x, y, diff_x, diff_y: longint);
 begin
  with board do
   while true do
    if board[x+diff_x][y+diff_y]=0 then begin
     board[x+diff_x][y+diff_y]:=board[x][y];
     board[x][y]:=0;
     x:=x+diff_x;
     y:=y+diff_y;
    end else if (board[x+diff_x][y+diff_y]=board[x][y]) and
                (not(merge_board[x+diff_x][y+diff_y])) then begin
     inc(board[x+diff_x][y+diff_y]);
     board[x][y]:=0;
     merge_board[x+diff_x][y+diff_y]:=true;
     score:=score+(1 shl board[x+diff_x][y+diff_y]);
     exit();
    end else exit();
 end;
procedure moveLeft(var board: board_type);
 var i, i2: longint;
 begin
  for i2:=1 to board.size_v-1 do
   for i:=0 to board.size_h-1 do
    movePiece(board, i, i2, 0, -1);
 end;
procedure moveUp(var board: board_type);
 var i, i2: longint;
 begin
  for i:=1 to board.size_h-1 do
   for i2:=0 to board.size_v-1 do
    movePiece(board, i, i2, -1, 0);
 end;
procedure moveRight(var board: board_type);
 var i, i2: longint;
 begin
  for i2:=board.size_v-2 downto 0 do
   for i:=0 to board.size_h-1 do
    movePiece(board, i, i2, 0, 1);
 end;
procedure moveDown(var board: board_type);
 var i,i2: longint;
 begin
  for i:=board.size_h-2 downto 0 do
   for i2:=0 to board.size_v-1 do
    movePiece(board, i, i2, 1, 0);
 end;
procedure printBoard(board: board_type);
 var i, i2: longint;
 begin
  with board do begin
   for i:=0 to size_h-1 do begin
    for i2:=0 to size_v-1 do
     if board[i][i2]<>0 then
      write((1 shl board[i][i2]):6)
     else
      write(0:6);
    writeln();
   end;
   writeln('Score: ', score);
  end;
 end;
procedure eraseMergeBoard(var board: board_type);
 begin
  with board do
   fillchar(merge_board, sizeof(merge_board), false);
 end;
function askConfirmation(mess: string): boolean;
 var response: char;
 begin
  write(mess+' (y/n): ');
  repeat
   response:=readkey()
  until response in ['y', 'n'];
  writeln();
  if response='y' then
   exit(true)
  else
   exit(false);
 end;
procedure gameInit(var board: board_type);
 var m, n: longint;
 begin
  writeln();
  write('Number of rows: ');
  readln(m);
  write('Number of columns: ');
  readln(n);
  initBoard(board, m, n);
 end;
function getScore(var board: board_type): qword;
 begin
  exit(board.score);
 end;
procedure printWelcomeScreen();
 begin
  clrscr();
  writeln();
  writeln('@@@@@@@@   @@@@@@@@         @@    @@@@@@@@');
  writeln('@@@@@@@@   @@@@@@@@        @@@    @@@@@@@@');
  writeln('      @@   @@    @@       @@@@    @@    @@');
  writeln('      @@   @@    @@      @@ @@    @@    @@');
  writeln('@@@@@@@@   @@    @@     @@  @@    @@@@@@@@');
  writeln('@@         @@    @@    @@   @@    @@    @@');
  writeln('@@         @@    @@   @@@@@@@@@   @@    @@');
  writeln('@@@@@@@@   @@@@@@@@         @@    @@@@@@@@');
  writeln('@@@@@@@@   @@@@@@@@         @@    @@@@@@@@');
  writeln();
  writeln('1) Play');
  writeln('2) View highscore');
  writeln('3) Exit');
  write('Choice: ');
 end;
procedure loadHighscore();
 var t: text;
     n, v: longint;
     s, score, _name: ansistring;
 begin
  assign(t, highscoreFile);
  reset(t);
  n:=0;
  while not eof(t) do begin
   inc(n);
   readln(t, s);
   _name:=copy(s, 1, pos(',', s)-1);
   score:=copy(s, pos(',', s)+1, length(s));
   hs_name[n]:=_name;
   val(score, hs_score[n], v);
  end;
  close(t);
 end;
procedure checkHighscore(score: qword);
 var i, i2: longint;
     _name: ansistring;
 begin
  for i:=1 to 10 do
   if (hs_score[i]<=score) then begin
    writeln('You got the #', i, ' position on the scoreboard!');
    write('Please enter your name: ');
    readln(_name);
    for i2:=10 downto i+1 do begin
     hs_score[i2]:=hs_score[i2-1];
     hs_name[i2]:=hs_name[i2-1];
    end;
    hs_name[i]:=_name;
    hs_score[i]:=score;
    exit();
   end;
 end;
procedure gameRoutine();
 begin
  repeat
   gameInit(b);
   while canMove(b) do begin
    if hasEmpty(b) then
     addRandom(b);
    clrscr();
    printBoard(b);
    case readkey() of
     'q': if askConfirmation('Do you want to quit the game?') then begin
           writeln('Game over');
           writeln('Total score: ', getScore(b));
           checkHighscore(getScore(b));
           write('Press any key to return to main screen');
           readkey();
           exit();
          end;
     'r': if askConfirmation('Do you want to restart the game?') then
           gameInit(b);
     #0: begin
          case ord(readkey()) of
           keyUp: moveUp(b);
           keyDown: moveDown(b);
           keyLeft: moveLeft(b);
           keyRight: moveRight(b);
          end;
          eraseMergeBoard(b);
         end;
    end;
   end;
   writeln('Game over');
   writeln('Total score: ', getScore(b));
   checkHighscore(getScore(b));
  until not(askConfirmation('Do you want to play again?'));
 end;
procedure printHighscore();
 var i: longint;
 begin
  clrscr();
  writeln('High score: ');
  writeln();
  for i:=1 to 10 do
   writeln(i, ': Name: ', hs_name[i], ' Score: ', hs_score[i]);
  writeln();
  writeln('Press any key to return to main menu');
  readkey();
 end;
procedure writeHighscore();
 var t: text;
     i: longint;
 begin
  assign(t, '2048_highscore.txt');
  rewrite(t);
  for i:=1 to 10 do
   writeln(t, hs_name[i], ',', hs_score[i]);
  close(t);
 end;
begin
 hs_score[0]:=not(1 shl 63);
 loadHighscore();
 while true do begin
  printWelcomeScreen();
  repeat
   response:=readkey()
  until response in ['1', '2', '3'];
  case response of
   '1': gameRoutine();
   '2': printHighscore();
   '3': break;
  end;
 end;
 writeHighscore();
end.

2048_highscore.txt

test0,100000
test1,10000
test2,5000
test3,4000
test4,3000
test5,2000
test6,1000
test7,100
test8,10
test9,2