program beans; {*emulates the card game BEANS. 12/17/94 *}

const         {*these are hardwired into 'evaluate;'*}
	NUMBEANS=30;
	MAXPLYRS= 5; {*Larger => bum display, too few cards in drawpile *}
	NUMCARDS=40;
	NUMRANKS=10; {*partially hardwired in 'showcard;' *}
	{* NUMRANKS>=10 is also sort of assumed in the rules!*}
	{*large values of NUMCARDS or numplyrs will mess up displays*}
	{*also of course lots of things need to be <32768 *}

{*variables and procedures constant across a game*}
var
	beans,help: array[1..MAXPLYRS] of integer;
	rank, suit: array[1..NUMCARDS] of integer;
	numplyrs,handsize,beansleft,nextdealer: integer;

procedure addbeans(i,j: integer);
begin
beans[i]:=beans[i]+j;
beansleft:=beansleft-j;
if beansleft=0 then writeln('All the beans are gone; the game ends.');
if beansleft<0 then begin
	beans[i]:=beans[i]+beansleft;
	beansleft:=0;
	writeln('There are not enough beans, but the beans that remain are awarded');
	writeln('   and the game ends.');
	end;
end;

procedure paws;
var i,j:integer;
begin
{*for i:=1 to 16000 do for j:=1 to 256 do begin end;*}
write('                                        [Hit the enny key when ready]');
readln;
end;

{*these next variables and procedures apply across a whole round*}
procedure playround;
var deck, drawpile:array[1..NUMCARDS] of integer;
	stack, hand: array[1..2,1..NUMCARDS] of integer;
	hlen: array[1..MAXPLYRS] of integer;
	slen: array[1..2] of integer;
	dlen, plyr: integer;
	cardsleft:boolean;

procedure drawempty;
var i:integer;
begin
dlen:=slen[1]-1;
for i:=1 to dlen do deck[i]:=stack[1,i];
stack[1,1]:=stack[1,slen[1]];
slen[1]:=1;
for i:=1 to slen[2]-1 do deck[dlen+i]:=stack[2,i];
dlen:=dlen+slen[2]-1;
stack[2,1]:=stack[2,slen[2]];
slen[2]:=1;
for i:=1 to dlen do drawpile[i]:=deck[i];
if dlen<2 then writeln('Uh-oh -- irregular situation, not enough cards!');
if dlen<2 then cardsleft:=FALSE;
end;

procedure makebox(i,j:integer);
{*make a box on the screen starting at column i, row j; width 4 *}
{*leave cursor at position i+1,j *}
begin
gotoxy(i,j-1);write(#218);write(#196);write(#196);write(#196);write(#191);
gotoxy(i,j);write(#179);write('   ');write(#179);
gotoxy(i,j+1);write(#192);write(#196);write(#196);write(#196);write(#217);
gotoxy(i+1,j);
end;

procedure showcard(i: integer);
begin
if i=0 then write('   ') else begin
	if (rank[i]>1) AND (rank[i]<9) then write(rank[i],'-');
	if rank[i]=9 then write('D-');{* ragon-');*}
	if rank[i]=10 then write('W-');{* izard-');*}
	if rank[i]=1 then write('A-');{* ce-');*}
	if suit[i]=1 then write(#3);{*'Diamonds');*}
	if suit[i]=2 then write(#4);{*'Swords');*}
	if suit[i]=3 then write(#5);{*'Scepters');*}
	if suit[i]=4 then write(#6);{*'Shields');*}
	end;
end;

procedure nicecard(i,c,r:integer);
begin
makebox(c-1,r);
showcard(i);
gotoxy(c+4,r);
end;

procedure showstats;
var x,p,i: integer;
begin
ClrScr;
Gotoxy(33,1);
writeln('Pile sizes: Stack1=',slen[1],' Stack2=',slen[2],' Draw=',dlen);
write('Stacks: ');
nicecard(stack[1,slen[1]], 12,2);
nicecard(stack[2,slen[2]], 19,2);
Gotoxy(33,3);
writeln('Beanpile still has ',beansleft,' beans left.');writeln;
for p:=1 to numplyrs do begin
	writeln('Player ',p,' has ',beans[p],' beans and these cards: ');writeln;
	for i:=1 to hlen[p] do begin
		Gotoxy(8*i-7, 5*p+3);
		write(i,'.');
		if help[p]=1 then x:=0 else x:=hand[p,i];
		nicecard(x,8*i-4,5*p+2);write(' ');
		end;
	writeln;writeln;writeln;
	end;
writeln('Next play will be by player ', plyr,'.');writeln;
end;

{*****************One player routines follow****************}
procedure nextplayer;
var card, pile, OKlevel, optionlevel: integer;

procedure setOKlevel; {*set to 0 if move bad, 1 if optional, 2 if forced*}
begin
OKlevel:=0;
if rank[hand[plyr,card]]=9  then OKlevel:=1;
if rank[hand[plyr,card]]=10 then OKlevel:=1;
{*rules are unclear: if you have a Wizard matching rank or suit of a stack,
can you opt not to play it? I think so. Thus:*} if OKlevel=0 then begin
	if suit[hand[plyr,card]]=suit[stack[pile, slen[pile]]] then OKlevel:=2;
	if rank[hand[plyr,card]]=rank[stack[pile, slen[pile]]] then OKlevel:=2;
	end;
end;

procedure setOptionlevel; {*set to 0 if no moves, 1 if optional only, 2 else*}
begin
optionlevel:=0;
for card:=1 to hlen[plyr] do for pile:=1 to 2 do
	begin
		setOKlevel;
		if OKlevel=2 then optionlevel:=2;
		if (OKlevel=1) AND (optionlevel=0) then optionlevel:=1;
	end;
end;

procedure makemove(cardx,pilex:integer); {*assumes move is valid*}
var r,i:integer;
begin
r:=rank[hand[plyr,cardx]];
slen[pilex]:=slen[pilex]+1;
stack[pilex,slen[pilex]]:=hand[plyr,cardx];
for i:=cardx to hlen[plyr]-1 do hand[plyr,i]:=hand[plyr,i+1];
hlen[plyr]:=hlen[plyr]-1;
{*We FIRST have other players return beans if they must so plyr gets credits*}
{*rules are unclear here*}
if r=9 then begin
	writeln('Since a Dragon is played, all opponents must buy a card.');
	for i:=1 to numplyrs do if (i<>plyr) then begin
		hlen[i]:=hlen[i]+1;
		hand[i,hlen[i]]:=drawpile[dlen];
		dlen:=dlen-1;
		if dlen=0 then drawempty;
		addbeans(i,-1);
		if beans[i]<0 then begin
			beansleft:=beansleft+beans[i];beans[i]:=0;
			writeln('(Player ',i,' is broke, so the card is free.)');
			end;
		end;
	end;
if rank[stack[1,slen[1]]]=rank[stack[2,slen[2]]] then begin
	writeln('Two beans are awarded for making a pair.');
	addbeans(plyr,2);
	end;
if r=1 then begin
	writeln('Two beans are awarded for playing an Ace.');
	addbeans(plyr,2);
	end;
if r=3 then begin
	writeln('One bean is awarded for playing a 3.');
	addbeans(plyr,1);
	end;
if r=7 then begin
	writeln('One bean is awarded for playing a 7.');
	addbeans(plyr,1);
	end;
if hlen[plyr]=0 then begin
	writeln('Three beans are awarded for going out.');
	addbeans(plyr,3);
	cardsleft:=FALSE;
	end;
paws;
end;

procedure choosemove;
var i:integer;
begin
OKlevel:=0;
while OKlevel=0 do begin
	write('Card number? #');readln(card);
	write('Stack number? ');readln(pile);
	setOKlevel;
	if OKlevel=0 then writeln('Invalid move, try again');
	end;
makemove(card,pile);
end;

procedure drawcard;
var p,i:integer;
begin
hlen[plyr]:=hlen[plyr]+1;
hand[plyr,hlen[plyr]]:=drawpile[dlen];
dlen:=dlen-1;
if dlen=0 then drawempty;
{*this card may be played if playable, but evidently no other card can now
be played, nor can a player play if drawing a card as a result of another
players dragon*}
card:=hlen[plyr];
p:=0;
pile:=1; setOKlevel; if OKlevel>0 then p:=p+1;
pile:=2; setOKlevel; if OKlevel>0 then p:=p+2;
if p>0 then begin
	write('You drew the ');showcard(hand[plyr,card]);writeln;
	writeln('You may play this card if you wish.');
	end;
if (p=1) or (p=3) then writeln('Enter 1 to play on stack 1,');
if (p=2) or (p=3) then writeln('Enter 2 to play on stack 2,');
if p>0 then begin write('Enter 0 to hold the card. Your choice? ');readln(i);end;
if (p=1) and ( (i<0) or (i>1) ) then i:=0;
if (p=2) and ( (i<0) or (i=1) or (i>2) ) then i:=0;
if (p=3) and ( (i<0) or (i>2) ) then i:=0;
if (p>0) AND (i>0) then makemove(hlen[plyr],i);
end;

procedure humanmoves;
var i:integer;
begin
if optionlevel=0 then begin
	writeln('You have no valid moves and must draw a card. Hit RETURN when ready.');
	readln;
	drawcard;
	end;
if optionlevel=1 then begin
	writeln('The only cards you can play are your Dragons and Wizards, but the');
	writeln('rules allow you to draw a card instead in that case.');
	i:=0;
	while (i<1) or (i>2) do begin
		write('1.  Draw a card,  or  2. Play a card ? ');readln(i);
		end;
	if i=1 then drawcard;
	if i=2 then choosemove;
	end;
if optionlevel=2 then begin
	writeln('You have a card matching suit or rank, so you must play a card.');
	choosemove;
	end;
end;

function analyze(card,pile:integer):integer;   {*assumes just 2 players*}
var value,p1,p2,p3,l1,l2,l3,d,r1,s1,r2,s2,i,n:integer;
begin
;
{*Goal is first to tabulate numerical data about how situation would be
after card is played on pile. Then we combine to get 'goodness' measure *}
;
{*p1,p2,p3 are the beancounts. l1 l2 are the hand counts, l3=min. d=next dealer.
r1 s1 and r2 s2 are the stack cards.
Also have info on what other cards are in hand. -- what to measure?
Also have info on what cards have already been played, and how opponent
has reacted -- we will ignore this. *}
if nextdealer=plyr then d:=1 else d:=-1;
l1:=hlen[plyr]-1;l2:=hlen[3-plyr];
if card=0 then l1:=l1+1; {*signifies not playing a card*}
l3:=l1;if l2<l1 then l3:=l2;
if card=0 then begin
	r1:=rank[stack[pile,slen[pile]]];
	s1:=suit[stack[pile,slen[pile]]];
	end
else begin
	r1:=rank[hand[plyr,card]];s1:=suit[hand[plyr,card]];end;
r2:=rank[stack[3-pile,slen[3-pile]]];s2:=suit[stack[3-pile,slen[3-pile]]];
p1:=beans[plyr];p2:=beans[3-plyr];p3:=beansleft;
if r1=9 then begin
	l2:=l2+1;
	p2:=p2-1;
	if p2>=0 then p3:=p3+1;
	if p2<0 then p2:=0;
	end;
if (r1=1) then p1:=p1+2;
if (r1=3) or (r1=7) then p1:=p1+1;
if r1=r2 then p1:=p1+2;
if l1=0 then p1:=p1+3;
p3:=p3-(p1-beans[plyr]);
if p3<0 then begin p1:=p1-p3;p3:=0;end;
if card=0 then begin p1:=beans[plyr];p2:=beans[3-plyr];p3:=beansleft;end;
;
{*now, how does that feel?*}
{*NOTE: we later use -16000 as the value of a forbidden move. Anything
legal has to have a value greater than this *}
value:=0;
if p3=0 then begin {*...if game ended...*}
	if p1>p2 then value:=1000;
	if p1<p2 then value:=-1000;
	if p1=p2 then value:=-1;
	end;
{*what if round were to end but not game? : *}
if (l3=0) AND (p3>0) then value:=value+ round( ((p1-p2+2.5*d)/p3)*700 );
{*what if this didn't end the round but it was close? *}
if (l3=1) AND (l2=1) AND (p3>0) then value:=value+round( ((p1-p2-3+2*d)/p3)*500 );
if (l3=1) AND (l2>1) AND (p3>0) then value:=value+round( ((p1-p2-1*d)/p3)*400 );
{*what if we're sort of in the middle of the game?*}
if (l3>1) AND (p3>0) then value:=value+round( ((p1-p2)/(p3))*(300/l3) );
{*this reduces to 2(p1-p2) at the beginning of the game*}
n:=0;
for i:=1 to hlen[plyr] do if (i<>card) then begin
	if rank[hand[plyr,i]]=1 then value:=value+2;
	if rank[hand[plyr,i]]=3 then value:=value+1;
	if rank[hand[plyr,i]]=7 then value:=value+1;
	if rank[hand[plyr,i]]=9 then value:=value+4;
	if rank[hand[plyr,i]]=10 then value:=value+3;
	if (suit[hand[plyr,i]]=s1) or (suit[hand[plyr,i]]=s2) then n:=n+1;
	if (rank[hand[plyr,i]]=r1) or (rank[hand[plyr,i]]=r2) then n:=n+1;
	end;
value:=value+round(n/5);
{*it's good to keep flexible cards at hand*}
analyze:=value;
end;

procedure computermoves;
var v0,v1,v2, p, bestp, bestc, bestOK: integer;
begin
if optionlevel=0 then begin
	writeln('Computer must draw a card.');
	hlen[plyr]:=hlen[plyr]+1;
	hand[plyr,hlen[plyr]]:=drawpile[dlen];
	dlen:=dlen-1;
	if dlen=0 then drawempty;
	card:=hlen[plyr];
	v0:=analyze(0,1);
	pile:=1; setOKlevel; v1:=-16000; if OKlevel>0 then v1:=analyze(card,1);
	pile:=2; setOKlevel; v2:=-16000; if OKlevel>0 then v2:=analyze(card,2);
	if (v0>v1) AND (v0>v2) then begin
		writeln('Computer cannot or chooses not to play drawn card.');
		paws;
		end
	else begin
		bestp:=1; if v2>v1 then bestp:=2; 
		writeln('Computer decides to play the drawn card.');
		makemove(card,bestp);
		end;
	end;
if optionlevel=1 then optionlevel:=2; {*possibly requires analysis*}
if optionlevel=2 then begin
	bestOK:=-16000;bestc:=1;bestp:=1;
	for card:=1 to hlen[plyr] do for pile:=1 to 2 do begin
		setOKlevel;
		if OKlevel>0 then begin
			v1:=analyze(card,pile);
			if v1>bestOK then begin
				bestOK:=v1; bestc:=card; bestp:=pile; end;
			end;
		end;
	write('Computer decides to play ');showcard(hand[plyr,bestc]);writeln(' to pile ',bestp,'.');
	makemove(bestc,bestp);
	end;
end;

begin {*nextplayer*}
plyr:=plyr+1; if plyr>numplyrs then plyr:=1;
showstats;
setOptionlevel;
if help[plyr]=1 then computermoves else humanmoves
end;

{*****************whole round routines follow****************}
function firstfree(j:integer):integer;
var i, temp: integer;
begin
if j<1 then j:=1; if j>NUMCARDS then j:=NUMCARDS;
temp:=1;
for i:=1 to j-1 do if deck[j-i]=0 then temp:=j-i;
for i:=0 to NUMCARDS-j do if deck[NUMCARDS-i]=0 then temp:=NUMCARDS-i;
firstfree:=temp;
end;

procedure deal;
var i,j: integer;
begin
plyr:=nextdealer;
nextdealer:=nextdealer+1; if nextdealer>numplyrs then nextdealer:=1;
for i:=1 to NUMCARDS do deck[i]:=0;
for i:=1 to NUMCARDS do begin
	j:=round(random(NUMCARDS)+0.5);
	deck[firstfree(j)]:=i;
	end;
dlen:=NUMCARDS;
for j:=1 to numplyrs do begin
	for i:=1 to handsize do begin hand[j,i]:=deck[dlen]; dlen:=dlen-1; end;
	hlen[j]:=handsize;
	end;
for j:=1 to 2 do begin
	stack[j,1]:=deck[dlen];dlen:=dlen-1;
	slen[j]:=1;
	end;
for i:=1 to dlen do drawpile[i]:=deck[i];
i:=beans[plyr];
if rank[stack[1,1]]=rank[stack[2,1]] then addbeans(plyr,2);
if rank[stack[1,1]]=1 then addbeans(plyr,2);
if rank[stack[2,1]]=1 then addbeans(plyr,2);
if rank[stack[1,1]]=3 then addbeans(plyr,1);
if rank[stack[2,1]]=3 then addbeans(plyr,1);
if rank[stack[1,1]]=7 then addbeans(plyr,1);
if rank[stack[2,1]]=7 then addbeans(plyr,1);
if beans[plyr]>i then writeln('Dealer gets ',beans[plyr]-i,' bean(s) for dealing lucky cards.');
cardsleft:=TRUE;
end;

begin {*playround*}
writeln('Player ',nextdealer,' is the dealer.');
deal;
writeln('Hit any key when ready to see the deal.');readln;
while ((beansleft>0) AND cardsleft) do nextplayer;
if beansleft>0 then begin
	writeln('This round is over, but beans remain so we will play another.');
	end;
end;

{*****************main loop routines follow*****************}

procedure setup;
var i:integer;
begin
ClrScr;
writeln('This is a computer modelling of the game BEANS, distributed by');
writeln('Avid Press. The computer adaptation is by Dave Rusin 12/15/94.');
writeln('The simulation is faithful to the rules except that the players');
writeln('can see the cards of the other players.');
writeln;
;
numplyrs:=0;
while numplyrs<2 do begin
	write('How many people will be playing? ');readln(numplyrs);
	if numplyrs>MAXPLYRS then
		writeln('Sorry, I can not handle more than ',MAXPLYRS);
	if numplyrs>MAXPLYRS then numplyrs:=0;
	end;
for i:=1 to numplyrs do help[i]:=0;
writeln('Would you like the computer to think for (some) players? ');
write('How many? (0 thru ',numplyrs,'): ');readln(nextdealer);writeln;
if (nextdealer>2) then
	writeln('Warning! Likely to crash with more than 2 computer players!');
if (nextdealer>0) AND (numplyrs>2) then
	writeln('Warning! Machine will only try to beat player 2!');
for i:=1 to nextdealer do help[i]:=1;
;
handsize:=7; if numplyrs>=4 then handsize:=5;
{* no problem changing these if handsize*numplyrs < NUMCARDS +3 *}
beansleft:=NUMBEANS;
nextdealer:=1;
for i:=1 to NUMCARDS do rank[i]:=i-NUMRANKS*round((2*i-1)/(2*NUMRANKS)-0.5);
for i:=1 to NUMCARDS do suit[i]:=round((i-0.5)/NUMRANKS+0.5);
for i:=1 to numplyrs do beans[i]:=0;
end;

procedure announce;
var score,owner: array[1..MAXPLYRS] of integer;
	i,j,k: integer;
begin
for i:=1 to numplyrs do score[i]:=0;
for i:=1 to numplyrs do begin
	j:=1;
	while beans[i]<score[j] do j:=j+1;
	for k:=1 to i-j do begin score[i+1-k]:=score[i-k];owner[i+1-k]:=owner[i-k];end;
	score[j]:=beans[i];owner[j]:=i;
	end;
i:=1;
while score[i+1]=score[1] do i:=i+1;
if i=1 then writeln('Player ',owner[1],' wins!');
if i>1 then begin
	write(i,'-way tie for first place between players ');
	for j:=1 to i-1 do write(owner[j],' ');
	writeln('and ',owner[i]);
	end;
writeln('Player...Beans');
for i:=1 to numplyrs do writeln('   ',owner[i],'.......',score[i]);
end;

begin {*main loop*}
setup;
while beansleft>0 do playround;
announce;
end.

{*
Rules synopsis: Game is played with a deck of 40 cards, 4 suits of 10
numbers 1..10 each. There is also a pack of about 30 beans. The goal is
to accumulate as many of the beans as possible. While there are beans in
the pile, players continue to play rounds of the card game, alternating
dealership.
	In each round of the game, players receive 7 cards face down; two stacks
are started face up and the other cards are in a drawpile face down.
Players alternate starting right of the dealer. On a player's turn he or
she may put a card on a stack if the card matches the stack in suit or
rank, or if the card is a 9 or 10. If the player has no cards to play he
or she must draw one from the draw pile, which may then be played. If the
player's only possible cards to play are a 9 or 10, the player may elect
to draw instead of playing. Play continues until one player has played
his or her last card, or until the pile of beans is exhausted.
	If a player plays a 9, all other players draw a card, and also return one bean
to the pile (if they have any).
	Players receive beans based on the card they play; the several rewards
are additive: 1 bean for playing a 3 or 7; 2 beans for playing a 1; 2
beans for forming a pair (matching ranks on the stacks); 3 beans for
playing their last card.
	If ever the draw pile is exhausted the stack cards, under the top one, are
reshuffled and reused. All the cards are reused in subsequent rounds.
*}
{*TODO list:
Never did arrange to reshuffle draw pile.
There is an advanced version of BEANS not encoded here.
Computer playing is hardwired for pitting  plyr against 3-plyr  only.
Strategy not at all honed yet.
Also unknown whether to pass play when possible.
Ought to give more data about strategy -- e.g. print evaluations, make
      suggestions for human players, etc.
*}