program ten;
{$C-}
type
	card=byte;
	pile=array[1..52] of card;
	filename=String[65]; {65=length of a path+file name}
var
	clear_times:array[1..7] of integer;
	frequencies:array[1..10] of integer;
	results_file: text;
	pause_amount:integer;
	cards_played: integer;
	num_stacks, curr_stack, cards_remain: byte;
	stack: array[1..7] of pile;
	length: array[1..7] of card;
	deck: pile;
	recording:boolean;

Function Open(var fp:text; var Name:filename; mode:char): boolean;
var	proceed: boolean;
begin
{$I-}
	proceed:=TRUE;
	while proceed=TRUE do begin
		Write('Enter filename (hit return to abort): ');
		readln(Name);
		Assign(fp,Name);
		if mode='w' then rewrite(fp) else reset(fp);
		if IOresult <> 0 then begin
			if mode='r' then close(fp);
			Write('ERROR -- ');
			if mode='w' then write('File creation error:  ')
				else write('File not found: ');
			Writeln(Name);
			proceed:=TRUE;
			end
		else proceed:=FALSE;
		if Name='' then begin
			proceed:=FALSE;
			Open:=False
			end
		else Open:=TRUE;
		end;
end;
{$I+}

Procedure Pause;
var k:integer;
begin
	for k:=1 to pause_amount do k:=k;
	for k:=1 to pause_amount do k:=k;
	for k:=1 to pause_amount do k:=k;
	for k:=1 to pause_amount do k:=k;
	for k:=1 to pause_amount do k:=k;
end;

procedure finish;
var	i:byte;
begin
	if (num_stacks=1) and (length[1]=1) then begin
		gotoxy(20,5);
		write('A winning solution exists; let''s stop');
		if recording=TRUE then writeln(results_file,'Win declared.');
		end;
	if num_stacks=0 then begin
		gotoxy(30,5);
		Write('YOU WON!!!');
		end;
	if cards_remain=0 then begin
		gotoxy(30,16);
		write('you lost');
		end;
	gotoxy(1,24);
	if recording=TRUE then begin
		for i:=1 to 7-num_stacks do
			writeln(results_file, 'Stack #',i,' cleared after ',clear_times[i],' cards.');
		writeln(results_file, 'Frequency distribution: ');
		for i:=1 to 10 do writeln(results_file,i-1,': ',frequencies[i],' ');
		writeln(results_file, 'Game ended after ',cards_played,' cards.');
		writeln(results_file,num_stacks,' stacks remaining.');
		close(results_file);
		end;
	HALT;
end;

Procedure HandleInterrupt;
var ch:char;
begin
	Read(kbd,ch);
	if (ch='q') or (ch='Q') then finish;
{*
	if (ch='b') or (ch='b') then Break;
	if ((ch='h') or (ch='H')) then begin
		DisplayHelp;
		MakeWritingZones;
		ShowEnvironment;
		end;
	if (ch='o') or (ch='O') then HandleOops;
*}
	if ch=#27 then begin
		Gotoxy(25,25);write('Any key resumes');
		repeat ch:=#00 until KeyPressed;
		Gotoxy(25,25);write('               ');
		end;
	if (ch='f') or (ch='F') then pause_amount:=0;
	if (ch='+') then pause_amount:=(pause_amount) div 2;
	if (ch='-') and (pause_amount<7000)
		then pause_amount:=(2*pause_amount);
	if (ch='-') and (pause_amount=0) then pause_amount:=100;
	if (ch='s') or (ch='S') then pause_amount:=15000;
end;

procedure resetshuffle;
var	store_file: text;
	store_file_name: Filename;
	i:byte;
begin
	if NOT Open(store_file, store_file_name, 'r') then begin
		Writeln('Sorry!'); HALT; end;
	for i:=1 to 52 do readln(store_file,deck[i]);
	close(store_file);
end;

procedure saveshuffle;
var	store_file: text;
	store_file_name: Filename;
	i:byte;
begin
	if NOT Open(store_file, store_file_name, 'w') then begin
		Writeln('Sorry!'); HALT; end;
	for i:=1 to 52 do writeln(store_file,deck[i]);
	close(store_file);
end;

procedure openresults;
var	results_file_name: Filename;
	i:byte;
begin
	if NOT Open(results_file, results_file_name, 'w') then begin
		Writeln('Sorry!');HALT; end;
	recording:=TRUE;
end;

procedure shuffle;
var
	ch:char;
	avail: pile;
	i,j,k:byte;
begin
	for i:=1 to 52 do avail[i]:=i;
	for i:=1 to 52 do begin
		j:=1+random(53-i);
		deck[i]:=avail[j];
		for k:=j to 52-i do avail[k]:=avail[k+1];
		end;
	writeln('Deck shuffled.');
	write('Would you like to save this shuffle?');read(kbd,ch);writeln(' ');
	if ch='y' then saveshuffle;
end;

procedure initialize;
var	i:byte;
	ch:char;
begin
	Write('Would you like to reuse a previous shuffle?');read(kbd,ch);writeln(' ');
	if ch='y' then resetshuffle;
	recording:=FALSE;
	write('save a summary of results?');read(kbd,ch);writeln(' ');
	if ch='y' then openresults;
	pause_amount:=0;
	clrscr;
	for i:=1 to 7 do begin writeln('Pile #',i,': ');writeln(' '); end;
	gotoxy(1,16);
	write('Deck: ');
	gotoxy(1,22);
	writeln('Piles eliminated:                     Cards Played:           Current pile: ');
	write('Q:quit     ESC:pause             F:fastest   +:faster   -:slower   S:slowest');
	cards_played:=0;
	num_stacks :=7;
	cards_remain:=52;
	curr_stack:=1;
	for i:=1 to 10 do frequencies[i]:=0;
	for i:=1 to 7 do clear_times[i]:=0;
	for i:=1 to 7 do length[i]:=0;
	for i:=1 to 52 do deck[i]:=(deck[i] mod 13) + 1;
	for i:=1 to 52 do if deck[i]>9 then deck[i]:=0;
end;

procedure place_card;
var	i:byte;
begin
	cards_played:=cards_played+1;
	length[curr_stack]:=length[curr_stack]+1;
	frequencies[deck[1]+1]:=frequencies[deck[1]+1]+1;
	stack[curr_stack,length[curr_stack]]:=deck[1];
	cards_remain:=cards_remain-1;
	for i:=1 to cards_remain do deck[i]:=deck[i+1];
end;

procedure clear_stack;
var	i,j:byte;
begin
	clear_times[8-num_stacks]:=cards_played;
	num_stacks:=num_stacks-1;
	for j:=curr_stack to num_stacks do begin
		length[j]:=length[j+1];
		for i:=1 to length[j] do stack[j,i]:=stack[j+1,i];
		gotoxy(11,2*j+1);
		for i:=1 to 2*length[j] do write('  ');
		end;
	gotoxy(1,2*num_stacks+1);
	write('                      ');
	curr_stack:=curr_stack-1;
end;

function sum_ok(r,s,t:byte):boolean;
begin
	sum_ok:=FALSE;
	if ((r+s+t) mod 10) = 0 then sum_ok:=TRUE;
	if r=1 then begin r:=0; if ((r+s+t) mod 10)=0 then sum_ok:=TRUE; end;
	if s=1 then begin s:=0; if ((r+s+t) mod 10)=0 then sum_ok:=TRUE; end;
	if t=1 then begin t:=0; if ((r+s+t) mod 10)=0 then sum_ok:=TRUE; end;
end;

function num_places(a,b:byte; var z,y,x:byte):byte;
var	yes:array[1..3] of byte;
	p:byte;
begin
	p:=0;
	if sum_ok(stack[a,b-2],stack[a,b-1],stack[a,b])=TRUE then begin p:=p+1; yes[p]:=b-2; end;
	if sum_ok(stack[a,b-1],stack[a,b],stack[a,1])=TRUE then begin p:=p+1; yes[p]:=b-1; end;
	if sum_ok(stack[a,b],stack[a,1],stack[a,2])=TRUE then begin p:=p+1; yes[p]:=b; end;
	z:=yes[1];
	y:=yes[2];
	x:=yes[3];
	num_places:=p;
end;

function cango(a,l,m:byte):byte;
var	temp:byte;
begin
	temp:=0;
	if sum_ok(stack[a,l-2],stack[a,l-1],stack[a,l])=TRUE then temp:=temp+4;
	if sum_ok(stack[a,l-1],stack[a,l],stack[a,m])=TRUE then temp:=temp+2;
	if sum_ok(stack[a,l],stack[a,m],stack[a,m+1])=TRUE then temp:=temp+1;
	cango:=temp;
end;

function continues(a,z:byte):byte;
var	r:byte;
begin
	r:=length[a]-z;
	continues:=cango(a,z-1,3-r);
end;

function whoclears(i,n:byte):byte;
{*returns sum(2^i:6 spaces starting i from end can be cleared after 2 sets 
	of 3 starting with the one n spaces from end).*}
var	m:byte;
begin
	m:=n+1; {*n=0,1,2 -> m:=1,2,4 *}
	if m=3 then m:=4;
	whoclears:=m*i;
end;

function samenextset(i,j,k:byte):byte;
{*return zero if the places that clear again (i,j,k>0) come up with different
possibilities of what 6's can be cleared. Otherwise return values >0 - will
clear last 3 on stack unless retrun value > 1; then it will clear last 1 &
first two. Use that option if we are considering 3 options but only last two
options clear again (and clear same sets).}
var	w:byte;
begin
	w:=0;
	if (i=j) and (k=i) then w:=1;
	if (i=j) and (k=0) then w:=1;
	if (i=k) and (j=0) then w:=1;
	if (j=k) and (i=0) then w:=2;
	samenextset:=w;
end;

function helpme(a,b,p,z,y,x:byte):byte;
var	q,i:byte;
	ch:char;
	good:boolean;
begin
	gotoxy(1,19);
	for i:=1 to 180 do write(' ');
	gotoxy(7,16); for i:=1 to cards_remain do write(deck[i],' ');
	write('          ');
	gotoxy(11,2*a-1);
	for i:=1 to length[a] do Write(stack[a,i],' ');
	write('      ');
	good:=FALSE;
	while good=FALSE do begin
{$C-}
	gotoxy(1,19);
	write('I need your help removing the ',stack[a,b],' in pile ',a,', since you have ');
	if p=2 then write('two');
	if p=3 then write('three');
	writeln(' choices.');
	write('Shall I remove the three cards starting (cyclicly) ');
	write(b-z,', or ',b-y);
	if p=3 then write(', or ',b-x);
	write(' cards from the right?');
	read(kbd,ch);
	write(ch);
	q:=3;
	if ch='0' then q:=0;
	if ch='1' then q:=1;
	if ch='2' then q:=2;
	if (q=b-z) or (q=b-y) then good:=TRUE;
	if (q=b-x) and (p=3) then good :=TRUE;
	if good=FALSE then write('Come on!');
	end;
	helpme:=b-q;
end;

{*RemarK: the next two functions ought to be improved *}

function rankone(n:byte):byte;
begin
	rankone:= (n+8) mod 10; {*rank 1=best, then 0, then 9, then dont care*}
end;

function ranktwo(n,m:byte):byte;
var	temp:byte;
begin
	temp:=0;
	if sum_ok(n,m,0)=true then temp:=temp+20;
	if sum_ok(n,m,1)=true then temp:=temp+4;
{*	if sum_ok(n,m,9)=true then temp:=temp+1;*}
	if n=1 then temp:=temp+8;
	if n=0 then temp:=temp+4;
	if n=9 then temp:=temp+1;
	if m=1 then temp:=temp+2;
	if m=0 then temp:=temp+1;
	ranktwo:=temp;
end;

function ranktwoprime(a,z:byte):byte;
var	r:byte;
begin
	r:=3-(length[a]-z);
	ranktwoprime:=ranktwo(stack[a,r],stack[a,r+1]);
end;

function lookfortie(p,i1,j1,k1:byte):byte;
var	i,j,k:byte;
begin
	if i1>0 then i:=1 else i:=0;
	if j1>0 then j:=1 else j:=0;
	if k1>0 then k:=1 else k:=0;
	if (p=2) then begin
		if i+j=0 then lookfortie:=2; {*use 1st 2 remainers to judge*}
		if i+j=1 then lookfortie:=1; {*go with highest of orig i,j,k*}
		if i+j>1 then lookfortie:=0; {*ask for help*}
		end;
	if (p=3) then begin
		if i+j+k=0 then lookfortie:=2;
		if i+j+k=1 then lookfortie:=1;
		if i+j+k>1 then lookfortie:=0;
		end;
end;

function besmart(a,b,p,z,y,x:byte):byte; {*a=stack #; b=stack length; p:=# of choices=2 or 3*}
var	ruleused,w,i,j,k,sofar:byte;
	seekhelp:boolean;
begin
	{* be arbitrary if stacks (not deck!) end up the same anyway. THen
		do comparisons to pick best remainders when you can.
		Finally ask for help if stuck.*}
	sofar:=0;
	if b=3 then begin
		sofar:=z;
		ruleused:=1;
		end;
	if (b=4) AND (p=2) AND (stack[a,z-1]=stack[a,y-1]) then sofar:=z;
	if (b=4) AND (p=3) AND (stack[a,1]=stack[a,2]) AND (stack[a,1]=stack[a,3])
		then sofar:=z;
	if (b=4) and (sofar>0) then ruleused:=2;
	if (sofar=0) then begin
		seekhelp:=FALSE;
		if b=4 then begin
			i:=rankone(stack[a,z-1]);
			j:=rankone(stack[a,y-1]);
			if p=3 then k:=rankone(stack[a,x-1]);
			ruleused:=3;
			end;
		if b=5 then begin
			i:=ranktwo(stack[a,z-2],stack[a,z-1]);
			j:=ranktwo(stack[a,y-2],stack[a,y-1]);
			if p=3 then k:=ranktwo(stack[a,x-2],stack[a,x-1]);
			ruleused:=4;
			end;
		if b>5 then begin
			i:=continues(a,z);
			j:=continues(a,y);
			if p=3 then k:=continues(a,x);
			w:=lookfortie(p,i,j,k);
			if w=2 then begin
				i:=ranktwoprime(a,z);
				j:=ranktwoprime(a,y);
				if p=3 then k:=ranktwoprime(a,x);
				ruleused:=6;
				end;
			if w=1 then ruleused:=5;
			if w=0 then begin {* two or more keep going *}
				i:=whoclears(i,b-z);
				j:=whoclears(j,b-y);
				if p=3 then k:=whoclears(k,b-x) else k:=0;
				w:=samenextset(i,j,k);
				if w=0 then seekhelp:=TRUE;
				if w>0 then begin
					i:=1;
					j:=1;
					k:=w;
					ruleused:=7;
					end;
				end;
			{*I should be able to say, take the option which eliminates
			the most cards. Also, if there is a tie it may be because the
			same set of cards is eliminated; don't bother player then!*}
			end;
		if seekhelp=FALSE then begin
		sofar:=z;
			if j>i then sofar:=y;
			if (p=3) AND (k>i) AND (k>j) then sofar:=x;
			end;
		end;
	if (sofar=0) then begin
		sofar:=helpme(a,b,p,z,y,x);
		ruleused:=8;
		end;
	besmart:=sofar;
	if recording=TRUE then begin
		for i:=1 to b do write(results_file,stack[a,i],' ');
		write(results_file,'(',cards_played,' cards) Choice: ',b-sofar,' Reason ',ruleused,': ');
		if ruleused=1 then writeln(results_file, 'only 3 cards ');
		if ruleused=2 then writeln(results_file, 'all choices leave same card');
		if ruleused=3 then writeln(results_file, 'leaves best of the 4 cards ');
		if ruleused=4 then writeln(results_file, 'leaves best pair ');
		if ruleused=5 then writeln(results_file, 'only choice to delete 6 cards ');
		if ruleused=6 then writeln(results_file, 'leaves best initial pair on stack');
		if ruleused=7 then writeln(results_file, 'all choices which can kill 6 cards kill the same sets of 6 ');
		if ruleused=8 then writeln(results_file, 'user request');
		end;
end;

procedure clear_all_3s;
var
	i,a,b,z,y,x,p,q:byte;
	gomore:boolean;
begin
	a:=curr_stack;
	if length[a]>2 then gomore:=TRUE else gomore:=FALSE;
	while gomore=TRUE do begin
		gomore:=FALSE;
		b:=length[a];
		p:=num_places(a,b,z,y,x);
		if p>1 then q:=besmart(a,b,p,z,y,x);
		if p=1 then q:=z;
		if p>0 then begin
			gomore:=TRUE;
			deck[cards_remain+1]:=stack[a,((q-1) mod b) + 1];
			deck[cards_remain+2]:=stack[a,((q) mod b)+1];
			deck[cards_remain+3]:=stack[a,((q+1) mod b)+1];
			cards_remain:=cards_remain+3;
			length[a]:=length[a]-3;
			gotoxy(2*length[a]+11,2*a-1);
			write('           ');
			for i:=1 to length[a] do stack[a,i]:=stack[a,i+q-(b-2)];
			if length[a]<3 then gomore:=FALSE;
			if (length[a]=1) AND (num_stacks=1) then finish;
			if length[a]=0 then clear_stack;
			end;
		end;
end;

procedure show_state;
var	i,j:byte;
begin
	for i:=1 to num_stacks do begin
		gotoxy(11,2*i-1);
		for j:=1 to length[i] do Write(stack[i,j],' ');
		end;
	gotoxy(7,16);
	for j:=1 to cards_remain do Write(deck[j],' ');
	Write('      ');
	gotoxy(18,22);write(7-num_stacks);
	gotoxy(52,22);write(cards_played);
	gotoxy(78,22);write(curr_stack);
end;

procedure progress;
begin
	curr_stack:=curr_stack+1;
	if curr_stack>num_stacks then curr_stack:=1;
	show_state;
	if keypressed then handleinterrupt;
	pause;
end;


begin
	shuffle;
	initialize;
	while (num_stacks>0) AND (cards_remain>0) do begin
		place_card;
		clear_all_3s;
		progress;
		end;
	finish;
end.