Delphi XE3 (Warte auf viele {whispers} 2.979 Bytes -> ungolfed 4.560 Bytes)
Ich nenne diesen "2048-Code den Roman". Es wurden
mehr Bytes verwendet als ich mag, aber es funktioniert und es hat Spaß gemacht, das zu tun.
Ich werde später immer noch versuchen, es kürzer zu machen.
Gerade stattfindendes Spiel
Golf gespielt
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.
Ungolfed
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.
