Delphi XE3 (Waaay для багатьох {шепотів} 2,997 байта -> unololfed 4,560 байт)
Мені подобається називати це "романним кодом 2048 року"
Використовується більше байтів, ніж мені подобається, але це працює, і це було цікаво робити.
Я все ще збираюся спробувати зробити це коротше пізніше.
Триває гра
Гольф
uses System.SysUtils,Windows;type TDir=(dUp,dDown,dLeft,dRight,dInv);const t='_____________________________';er='| | | | |';nr='| %s | %s | %s | %s |';br='|______|______|______|______|';fn='%d';procedure mycls;var S:String;H:DWORD;CO:_COORD;begin H:=GetStdHandle(STD_OUTPUT_HANDLE);CO.X:=0;CO.Y:=0;SetConsoleCursorPosition(H,CO);S:=StringOfChar(Chr(32),2000);Writeln(S);SetConsoleCursorPosition(H,CO);end;var a:array[1..4,1..4]of integer;c,rx,ry,i,j:int8;m:string;GameOver,gs:boolean;function hz:boolean;var b,q:int8;begin for b:=1to 4do for q:=1to 4do if a[b,q]=0 then exit(true);end;function HM:boolean;var b,q:int8;begin if hz then exit(true);for b:=1to 4do for q:=1to 4do begin c:=a[b,q];if c in [a[b-1,q],a[b+1,q],a[b,q-1],a[b,q+1]] then result:=true;end;end;procedure rn(out n,m:int8);var z:int8;begin z:=0;repeat n:=Random(4)+1;m:=Random(4)+1;z:=z+1;until(a[n,m]=0)and(z>=3);end;function gn(n:integer):string;begin if n=0 then exit(' ');Result:=IntToStr(n).PadLeft(4,' ');end;procedure pm(d:TDir;score:boolean);var b,q,z:int8;begin case d of dUp:for z:=1to 3do for b:=1to 4do for q:=1to 3do begin if score then begin if a[q,b]=a[q+1,b] then begin a[q,b]:=a[q,b]+a[q+1,b];a[q+1,b]:=0;end;end else if a[q,b]=0 then begin a[q,b]:=a[q+1,b];a[q+1,b]:=0;end;end;dDown:for z:=1to 3do for b:=1to 4do for q:=2to 4do begin if score then begin if a[q,b]=a[q-1,b] then begin a[q,b]:=a[q,b]+a[q-1,b];a[q-1,b]:=0;end;end else if a[q,b]=0 then begin a[q-1,b]:=a[q,b];a[q-1,b]:=0;end;end;dLeft:for z:=1to 3do for q:=1to 4do for b:=1to 3do begin if score then begin if a[q,b]=a[q,b+1] then a[q,b]:=a[q,b]+a[q,b+1];a[q,b+1]:=0;end else if a[q,b]=0 then begin a[q,b]:=a[q,b+1];a[q,b+1]:=0;end;end;dRight:for z:=1to 3do for q:=1to 4do for b:=2to 4do begin if score then begin if a[q,b]=a[q,b-1] then begin a[q,b]:=a[q,b]+a[q,b-1];a[q,b-1]:=0;end;end else if a[q,b]=0 then begin a[q,b]:=a[q,b-1];a[q,b-1]:=0;end;end;end;end;function gd(s:string):TDir;begin s:=lowercase(s);if s='u'then exit(dUp);if s='d'then exit(dDown);if s='l'then exit(dLeft);if s='r'then exit(dRight);exit(dInv)end;procedure dg;var z:int8;begin writeln(t);for z:=1to 4do begin writeln(er);Writeln(Format(nr,[gn(a[z,1]),gn(a[z,2]),gn(a[z,3]),gn(a[z,4])]));Writeln(br);end;end;function hw:boolean;var b,q:int8; begin for b:=1to 4do for q:=1to 4do if a[b,q]=2048 then result:=true;end;function dm:boolean;var d:Tdir;begin d:=gd(m);if d=dInv then if not gs then exit(false)else exit(true);pm(d,false);pm(d,true);pm(d,false);exit(true);end;begin gs:=true;m:='';for j:=1to 4do for i:=1to 4do begin a[i,j]:=0;end;rx:=0;ry:=0;rn(rx,ry);a[rx,ry]:=2;repeat if (dm) then begin if hz then begin rn(rx,ry);a[rx,ry]:=2;end;gs:=false;end;mycls;GameOver:=true;if hw then WriteLn('You have won!')else if HM then begin GameOver:=false;dg;writeln('Direction: [U]=up, [D]=Down, [L]=Left, [R]=Right');readln(m);end else WriteLn('Game Over, no more possible moves :('#13#10'Try again next time')until GameOver;readln;end.
Безумовно
uses
System.SysUtils,Windows;
type
TDir=(dUp,dDown,dLeft,dRight,dInv);
const
t='_____________________________';
er='| | | | |';
nr='| %s | %s | %s | %s |';
br='|______|______|______|______|';
fn='%d';
procedure mycls;
var
S:String;
H:DWORD;
CO:_COORD;
begin
H:=GetStdHandle(STD_OUTPUT_HANDLE);
CO.X:=0;
CO.Y:=0;
SetConsoleCursorPosition(H,CO);
S:=StringOfChar(Chr(32),2000);
Writeln(S);
SetConsoleCursorPosition(H,CO);
end;
var
a:array[1..4,1..4]of integer;
c,rx,ry,i,j:int8;
m:string;
GameOver,gs:boolean;
function hz:boolean;
var b,q:int8;
begin
for b:=1to 4do
for q:=1to 4do
if a[b,q]=0 then exit(true);
end;
function HM:boolean;
var b,q:int8;
begin
if hz then exit(true);
for b:=1to 4do
for q:=1to 4do
begin
c:=a[b,q];
if c in [a[b-1,q],a[b+1,q],a[b,q-1],a[b,q+1]] then
result:=true;
end;
end;
procedure rn(out n,m:int8);
var z:int8;
begin
z:=0;
repeat
n:=Random(4)+1;
m:=Random(4)+1;
z:=z+1;
until(a[n,m]=0)and(z>=3);
end;
function gn(n:integer):string;
begin
if n=0 then exit(' ');
Result:=IntToStr(n).PadLeft(4,' ');
end;
procedure pm(d:TDir;score:boolean);
var
b,q,z:int8;
begin
case d of
dUp:
for z:=1to 3do
for b:=1to 4do
for q:=1to 3do
begin
if score then
begin
if a[q,b]=a[q+1,b] then
begin
a[q,b]:=a[q,b]+a[q+1,b];a[q+1,b]:=0;
end;
end
else
if a[q,b]=0 then
begin
a[q,b]:=a[q+1,b];a[q+1,b]:=0;
end;
end;
dDown:
for z:=1to 3do
for b:=1to 4do
for q:=2to 4do
begin
if score then
begin
if a[q,b]=a[q-1,b] then
begin
a[q,b]:=a[q,b]+a[q-1,b];a[q-1,b]:=0;
end;
end
else
if a[q,b]=0 then
begin
a[q-1,b]:=a[q,b];
a[q-1,b]:=0;
end;
end;
dLeft:
for z:=1to 3do
for q:=1to 4do
for b:=1to 3do
begin
if score then
begin
if a[q,b]=a[q,b+1] then
a[q,b]:=a[q,b]+a[q,b+1];a[q,b+1]:=0;
end
else
if a[q,b]=0 then
begin
a[q,b]:=a[q,b+1];a[q,b+1]:=0;
end;
end;
dRight:
for z:=1to 3do
for q:=1to 4do
for b:=2to 4do
begin
if score then
begin
if a[q,b]=a[q,b-1] then
begin
a[q,b]:=a[q,b]+a[q,b-1];a[q,b-1]:=0;
end;
end
else
if a[q,b]=0 then
begin
a[q,b]:=a[q,b-1];a[q,b-1]:=0;
end;
end;
end;
end;
function gd(s:string):TDir;
begin
s:=lowercase(s);
if s='u'then exit(dUp);
if s='d'then exit(dDown);
if s='l'then exit(dLeft);
if s='r'then exit(dRight);
exit(dInv)
end;
procedure dg;
var z:int8;
begin
writeln(t);
for z:=1to 4do
begin
writeln(er);
Writeln(Format(nr,[gn(a[z,1]),gn(a[z,2]),gn(a[z,3]),gn(a[z,4])]));
Writeln(br);
end;
end;
function hw:boolean;
var b,q:int8;
begin
for b:=1to 4do
for q:=1to 4do
if a[b,q]=2048 then
result:=true;
end;
function dm:boolean;
var
d:Tdir;
begin
d:=gd(m);
if d=dInv then if not gs then exit(false)else exit(true);
pm(d,false);
pm(d,true);
pm(d,false);
exit(true);
end;
begin
gs:=true;m:='';
for j:=1to 4do
for i:=1to 4do
begin
a[i,j]:=0;
end;
rx:=0;ry:=0;
rn(rx,ry);
a[rx,ry]:=2;
repeat
if (dm) then
begin
if hz then
begin
rn(rx,ry);
a[rx,ry]:=2;
end;
gs:=false;
end;
mycls;
GameOver:=true;
if hw then
WriteLn('You have won!')
else if HM then
begin
GameOver:=false;
dg;
writeln('Direction: [U]=up, [D]=Down, [L]=Left, [R]=Right');
readln(m);
end
else
WriteLn('Game Over, no more possible moves :('#13#10'Try again next time')
until GameOver;
readln;
end.
