Delphi XE3 (Waaay to many {whispers} 2.979 bytes -> ungolfed 4.560 bytes)
I like to call this "2048 code the novel"
Used more bytes than I like but it works and it was fun to do.
Im still going to try make it shorter later on.
Game in progress
Golfed
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.
@Doorknob I'm pretty sure that 2048 doesn't quit upon obtaining a 2048 tile. Many of my friends have gotten a 4096 tile or even higher. So making this as close as possible to the original would remove that restriction. – mbomb007 – 2015-02-24T18:04:02.297
@Doorknob Do the cells only need to always have the same shape, or does the number of rows (in a text based answer) used by a cell have to equal the number of columns? The currently accepted answer only keeps them constant, but not "square".
– Adám – 2016-08-02T01:48:13.723@Adám Huh, the challenge claims that the tiles have to be congruent squares but apparently I didn't actually enforce that rule. I guess I can't really invalidate nearly all the answers, so I suppose I have to go with the former. – Doorknob – 2016-08-02T06:50:24.950
@Doorknob In that case, you have a new winner ;-)
– Adám – 2016-08-02T07:03:36.630Does outputting Colored squares count? @RohanRjhunjhunwala offered a no-deadline bounty on this (500 rep) for writing one in S.I.L.O.S, and an extra 250 with GUI. however, S.I.L.O.S only has rectangle/ellipse drawing. I could, however, draw different colored squares though. – Matthew Roh – 2017-03-23T09:56:11.593
Instead of accepting either rows of single characters (first five examples) and/or separated tiles (last one), why not assign ascending powers of two to individual characters to normalize the output? – millinon – 2014-03-14T03:41:16.903
@millinon Because it's supposed to be as similar as possible to the actual 2048 game (it would make the title meaningless), and it would remove some of the challenge. – Doorknob – 2014-03-14T03:50:06.833
1"If there are no possible merges left, the game is lost" Shouldn't there be an "and the board is full" in there somewhere? – Peter Taylor – 2014-03-14T08:25:27.890
does space suffice as a tile separator? – John Dvorak – 2014-03-14T10:41:08.053
If the starting board is a single
2, no merges are possible. Does that mean the task is to render a 4x4 square with a random 2 inside, and then the message "you lose"? – John Dvorak – 2014-03-14T10:48:57.303@Peter
s/merge/move/:-P Edited – Doorknob – 2014-03-14T11:48:45.127@Jan Yes, space is a valid separator. – Doorknob – 2014-03-14T11:49:07.517
5Funny how all your questons get a ton of votes, but not many answers. – TheDoctor – 2014-03-14T13:02:21.503
@Doorknob Actually it is always a 2 on a random position (i played it to see how it worked) but it can be a 4 when the random position already contains a 2. At least thats what it seemed to be. – Teun Pronk – 2014-03-14T13:22:42.323
@TheDoc I've been trying to post more interesting and difficult challenges; I'm beginning to feel more and more that challenges you can complete in only 5 minutes or so just aren't as fun. – Doorknob – 2014-03-14T14:58:28.380
@Teun Well, for simplicity let's just assume it can only be a 2, since we're still not sure of the exact details (what happens if a 2 appears on a 8? Are there any other factors? Etc) – Doorknob – 2014-03-14T14:59:40.670
@Doorknob probably find another cell :P but I agree.. My code is long enough already lol – Teun Pronk – 2014-03-14T15:00:25.693
@TeunPronk The source code says:
var value = Math.random() < 0.9 ? 2 : 4;, so on any given new tile there is a 10% chance it will be4. – The Guy with The Hat – 2014-03-14T15:01:12.160Now its your fault I´ve been playing 2048 the whole weekend and today the productivity of our office has dropped to 0. – asr – 2014-03-17T10:09:27.760
hmm... will Bash strike back here... hmm... – None – 2014-04-06T10:43:06.973