My first ever program (May 2016)

game2048.pas

program game2048;

uses crt;

type arr=array of array of integer;
var a,b:arr; i,n:byte; x:char; sc:integer;

function eq(a,b:arr):boolean;
var i,j:byte; bo:boolean;
begin
  bo:=true;
  for i:=0 to length(a)-1 do
    for j:=0 to length(a)-1 do
      if a[i,j]<>b[i,j] then bo:=false;
  eq:=bo;
end;

procedure kopy(a:arr; var b:arr);
var i,j:byte;
begin
  setlength(b,length(a));
  for i:=0 to length(a)-1 do
    setlength(b[i],length(a));
  for i:=0 to length(a)-1 do
    for j:=0 to length(a)-1 do
      b[i,j]:=a[i,j];
end;

function num(n:integer):byte;
var i:byte;
begin
  i:=0;
  repeat
    n:=n div 10;
    i:=i+1;
  until n=0;
  num:=i;
end;

procedure wrarr(a:arr);
var i,j,p,k:byte; b:array of byte;
begin
  writeln;
  p:=1;
  setlength(b,length(a));
  for j:=0 to length(a)-1 do
  begin
    for i:=0 to length(a)-1 do
      if num(a[i,j])>p then p:=num(a[i,j]);
    b[j]:=p;
    p:=1;
  end;
  for i:=0 to length(a)-1 do
  begin
    for j:=0 to length(a)-1 do
    begin
      write(a[i,j],' ');
      for k:=1 to b[j]-num(a[i,j]) do
        write(' ');
    end;
    writeln;
  end;
  writeln;
end;

function count0(a:arr):byte;
var i,j,k:byte; 
begin
  k:=0;
  for i:=0 to length(a)-1 do
    for j:=0 to length(a)-1 do
      if a[i,j]=0 then k:=k+1;
  count0:=k;
end;

procedure switch(a:arr);
var i,j:byte; 
begin
  if count0(a)>0 then 
  begin
    randomize;
    repeat
      i:=random(length(a));
      j:=random(length(a));
    until a[i,j]=0;
    a[i,j]:=2+2*random(2);
  end;
end;

procedure downright(a:arr; x:char; var sc:integer);
var i,j,k,b:byte; m:arr;
begin
  kopy(a,m);
  if x='s' then b:=1 else if x='d' then b:=0;
  for k:=0 to length(a)-1 do
    for i:=0 to length(a)-1-b do
      for j:=0 to length(a)-2+b do
        if (a[i+b,j+1-b]=0) and (a[i,j]>0) then
        begin
          a[i+b,j+1-b]:=a[i,j];
          a[i,j]:=0;
        end;
  for i:=length(a)-1-b downto 0 do
    for j:=length(a)-2+b downto 0 do
      if (a[i,j]=a[i+b,j+1-b]) and (a[i,j]>0) then
      begin
        a[i+b,j+1-b]:=2*a[i,j];
        a[i,j]:=0;
        sc:=sc+a[i+b,j+1-b];
      end;
  for k:=0 to length(a)-1 do
    for i:=0 to length(a)-1-b do
      for j:=0 to length(a)-2+b do
        if (a[i+b,j+1-b]=0) and (a[i,j]>0) then
        begin
          a[i+b,j+1-b]:=a[i,j];
          a[i,j]:=0;
        end;
  if eq(a,m) then kopy(m,a);
end;        

procedure upleft(a:arr; x:char; var sc:integer);
var i,j,k,b:byte; m:arr;
begin
  kopy(a,m);
  if x='w' then b:=1 else  if x='a' then b:=0;
  for k:=0 to length(a)-1 do
    for i:=b to length(a)-1 do
      for j:=1-b to length(a)-1 do
        if (a[i-b,j+b-1]=0) and (a[i,j]>0) then
        begin
          a[i-b,j+b-1]:=a[i,j];
          a[i,j]:=0;
        end;
  for i:=b to length(a)-1 do
    for j:=1-b to length(a)-1 do
      if (a[i,j]=a[i-b,j+b-1]) and (a[i,j]>0) then
      begin
        a[i-b,j+b-1]:=2*a[i,j];
        a[i,j]:=0;
        sc:=sc+a[i-b,j+b-1];
      end;
  for k:=0 to length(a)-1 do
    for i:=b to length(a)-1 do
      for j:=1-b to length(a)-1 do
        if (a[i-b,j+b-1]=0) and (a[i,j]>0) then
        begin
          a[i-b,j+b-1]:=a[i,j];
          a[i,j]:=0;
        end;
  if eq(a,m) then kopy(m,a);
end; 

function toend(a:arr):boolean;
var b:arr; s:integer; x:char; bo:boolean;
begin
  bo:=true;
    x:='w';
  kopy(a,b);
  upleft(b,x,s);
  if not eq(a,b) then bo:=false;
    x:='a';
  kopy(a,b);
  upleft(b,x,s);
  if not eq(a,b) then bo:=false;
    x:='s';
  kopy(a,b);
  downright(b,x,s);
  if not eq(a,b) then bo:=false;
    x:='d';
  kopy(a,b);
  downright(b,x,s);
  if not eq(a,b) then bo:=false;
  toend:=bo;
end;

begin
  write('Enter matrix size: ');
  readln(n);
  sc:=0;
  setlength(a,n);
  for i:=0 to n-1 do
    setlength(a[i],n);
  switch(a);
  while count0(a)>0 do
  begin
    switch(a);
    clrscr;
    writeln('SCORE: ',sc);
    wrarr(a);
    kopy(a,b);
    while eq(a,b) and (not toend(a)) do
    begin
      x:=readkey;
      if (x='w') or (x='a') then upleft(a,x,sc);
      if (x='s') or (x='d') then downright(a,x,sc);
    end;
  end;
  writeln('GAME OVER');
end.