(* TURBO PASCAL 1.0
Morrow Micro Decision MD-2
David C. Oshel, Jan 15, 1984, 1219 Harding Ave, Ames, Iowa 50010
Modified under Turbo Pascal 2.0 6-Jan-85
Alan D. Hull, 42489 Castle Ct., Canton, MI. 48188
*)
{ Modification history:
1/6/85 Added Delete key as a valid video erase in data entries.
Commented out the Inline exit code; replaced with Halt.
Added instructions
}
{ TITLE PAGE:
(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
(':: Adapted from "Cribbage" in APPLE PASCAL GAMES, by Douglas Hergert ::');
(':: and Joseph T. Kalash, pages 301-349. Sybex, 1981. ::');
(':: ::');
(':: January 8, 1984 d.c.o. ::');
(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
}
Type
charset = set of char;
str80 = string[80];
suitype = (hearts,diamonds,clubs,spades);
ranktype = 0..ranksize;
card = record
rank: ranktype;
suit: suitype
end;
handtype = array[1..dealsize] of card;
{Typed} Const
alpha:charset = [' '..'}'];
Var
deck: array[1..decksize] of card;
comp,
human,
crib: handtype;
common: card;
i,
hscore,
cscore: integer;
ch: char;
xplayx: integer;
{ Note: The following information is left in this source code for
historical purposes. Under version 2.0 of Turbo, just use
a Halt command. }
(*
This is the code for simulating an Exit with TURBO Pascal 1.0
--> Include this instead of Exit(Procname) in the procedure which
actually invokes the exit:
VAR
instructions: text;
buffer : string[80];
filename : string[14];
ok : boolean;
Procedure get_file( var ok: boolean);
begin
filename := 'CRIBBAGE.INS';
assign (instructions, filename);
{$I-} reset (instructions) {$I+} ;
ok := (Ioresult = 0);
if not ok then
begin
writeln (chr(7),chr(7),'Can''t find file ', filename);
delay (3000);
end;
end;
procedure print_instructions;
VAR
ch: char;
i: 1..24;
begin
while NOT Eof(instructions) do begin
ClrScr;
for i := 1 to 22 do begin
readln (instructions, buffer);
writeln (buffer);
end;
writeln;
if NOT Eof(instructions) then begin
write ('Press any key to continue...');
read (kbd, ch); writeln;
end
else begin
write ('Press any key to resume play.');
read (kbd, ch); writeln;
ClrScr;
end;
end; {while}
close (instructions);
end;
begin {list_instructions}
get_file(ok);
if ok then print_instructions;
end;
function getchar:char;
var ch,cr,bs,del: char;
goodset: charset;
bailout: boolean;
begin
cr:=chr(13); bs:=chr(8); del:=chr(127); goodset:=alpha+[cr,bs,del];
repeat
read(kbd,ch);
ch:=upcase(ch);
bailout:=(ch=chr(3)) or (ch=chr(27));
if eoln then ch:=cr
until bailout or (ch in goodset);
getchar:=ch;
if bailout then
halt { v2.0 updated exit }
(*
inline($2A/xplayx/ { LD HL,(xplayx) ;EXIT PROC }
$F9) { LD SP,HL }
*)
end; {getchar}
procedure getln(VAR s:str80);
var ch: char;
done: boolean;
begin
done:=false;
s:='';
repeat
ch:=getchar;
if (* bailout or *) (ch=chr(13)) then
begin
done:=true;
writeln
end
else if ((ch=chr(8)) or (ch=chr(127))) then
begin
if length(s) > 0 then
begin
write(chr(8),' ',chr(8));
s:=copy(s,1,length(s)-1)
end
else s:=''
end
else
begin
s:=concat(s,ch);
if ch in alpha then write(ch)
end
until done;
end; {getln}
procedure addpoints(who:boolean; amount:integer);
var winner: boolean;
begin
if who then
begin
hscore:=hscore+amount;
writeln('You''ve pegged ',hscore,' points.');
winner := (hscore >= winpoints)
end
else
begin
cscore:=cscore+amount;
writeln('I''ve pegged ',cscore,' points.');
winner := (cscore >= winpoints)
end;
if winner then
halt;
inline($2A/xplayx/ { LD HL,(xplayx) ;EXIT PROC }
$F9) { LD SP,HL }
end; {addpoints}
{$I Cribbage.PS2}
function getelement:integer;
label retry;
var irank,isuit: char;
rank: ranktype;
suit: suitype;
which: integer;
index: 1..dealsize;
many: -5..4;
procedure getcard(VAR rankchar:char; VAR suitchar:char);
var ch: char;
s: str80;
i: integer;
begin
repeat
write('__',chr(8),chr(8));
getln(s);
rankchar:=' '; suitchar:=' ';
for i:=1 to length(s) do
begin
ch:=s[i];
if (ch in ['A','2'..'9','T','J','Q','K']) then rankchar:=ch;
if (ch in ['S','H','D','C']) then suitchar:=ch
end;
if (rankchar=' ') or (suitchar=' ') then
begin
writeln(s,'?');
writeln('Suits = S,H,D,C (Spades,Hearts,Diamonds,Clubs)');
writeln('Ranks = A,2,3,4,5,6,7,8,9,T,J,Q,K (Ace is A, 10 is T!)');
writeln('Example: 8D (eight of Diamonds) or TH (ten of Hearts)');
writeln;
write('Try again from the start. Which card? ')
end
until (rankchar<>' ') and (suitchar<>' ');
writeln('{{{ ',rankchar,suitchar,' }}}');
end; {getcard}
begin
retry:
getcard(irank,isuit);
case irank of
'A': rank:=1;
'2','3','4','5','6','7','8','9': rank:=ord(irank)-ord('0');
'T': rank:=10;
'J': rank:=11;
'Q': rank:=12;
'K': rank:=13
end; {case}
case isuit of
'S': suit := spades;
'H': suit := hearts;
'D': suit := diamonds;
'C': suit := clubs
end; {case}
many:=0;
which:=0;
for index:=1 to dealsize do
begin
if human[index].rank = rank then
begin
many:=many+1;
if many>0 then which:=index;
if isuit<>' ' then
if human[index].suit = suit then
many:=-5
end
end;
if many=0 then
begin
writeln('What?! No such card exists.');
write('Which card? ');
goto retry
end;
if many>1 then
begin
writeln('There is more than one ',irank);
write('Please be more specific: ');
goto retry
end;
if (many=1) or (many<0) then getelement:=which;
end; {getelement}
procedure tocrib;
var cardnum: 1..dealsize;
numgone: 0..1;
begin
for numgone:=0 to 1 do
begin
write('Throw which card? [ ');
for cardnum:=1 to (dealsize-numgone) do showcard(human[cardnum]);
write(' ] ');
cardnum:=getelement;
crib[numgone+1]:=human[cardnum];
while cardnum <= (dealsize-1) do
begin
human[cardnum]:=human[cardnum+1];
cardnum:=cardnum+1
end;
human[cardnum].rank:=0
end;
end; {tocrib}
procedure sort(n:integer; var hand:handtype);
var
touched: boolean;
index: 1..dealsize;
tmp: card;
begin
repeat
touched:=false;
for index:=1 to (n-1) do
if hand[index].rank > hand[index+1].rank then
begin
tmp:=hand[index];
hand[index]:=hand[index+1];
hand[index+1]:=tmp;
touched:=true
end
until not touched;
end; {sort}
{$I Cribbage.PS3}
procedure compcrib;
type
bestrec = record
points: integer;
first, second: 1..dealsize
end;
var
tmp: handtype;
best: bestrec;
i,j,points: integer;
function compscore:integer;
var
index,points: integer;
num: 1..dealsize;
begin
num:=1;
for index:=1 to (i-1) do
begin
tmp[num]:=comp[index];
num:=num+1
end;
for index:=(i+1) to (j-1) do
begin
tmp[num]:=comp[index];
num:=num+1
end;
for index:=(j+1) to dealsize do
begin
tmp[num]:=comp[index];
num:=num+1
end;
tmp[5].rank:=0;
compscore:=score(tmp);
end; {function compscore}
begin {compcrib}
best.points:=-1;
sort(6,comp);
for i:=1 to (dealsize-1) do
for j:=i+1 to dealsize do
begin
points:=compscore;
if points > best.points then
begin
best.points:=points;
best.first:=i;
best.second:=j
end
end;
j:=1;
for i:=1 to (best.first-1) do
begin
tmp[j]:=comp[i];
j:=j+1
end;
for i:=(best.first+1) to (best.second-1) do
begin
tmp[j]:=comp[i];
j:=j+1
end;
for i:=(best.second+1) to dealsize do
begin
tmp[j]:=comp[i];
j:=j+1
end;
crib[3]:=comp[best.first];
crib[4]:=comp[best.second];
for i:=1 to playsize do comp[i]:=tmp[i];
end; {compcrib}
procedure count(who: boolean);
var
oldhuman: array[1..4] of card;
curcount: integer;
humcant,
compcant: boolean;
cnthand: array[1..8] of card;
last: 0..2;
cntnum: 1..8;
lastcnt: integer;
humleft,
comleft: 0..playsize;
i: -1..playsize;
points: integer;
function countscore(newcard: card):integer;
var
return: integer;
matched, index: 0..8;
begin
return:=0; matched:=0;
cnthand[cntnum]:=newcard;
if cnthand[cntnum].rank > 10
then curcount:=curcount+10
else curcount:=curcount+cnthand[cntnum].rank;
if cntnum=1 then
begin
cntnum:=cntnum+1;
countscore:=0
end
else
begin
if (curcount=15) or (curcount=31) then return:=2;
index:=cntnum;
while index >= 2 do
begin
if cnthand[index].rank=cnthand[index-1].rank then
matched:=matched+1
else index:=1;
index:=index-1
end;
case matched of
0: ;
1: return:=return+2;
2: return:=return+6;
3: return:=return+12
end; {case}
matched:=0;
index:=cntnum;
while index >= 2 do
begin
if cnthand[index].rank=(cnthand[index-1].rank -1) then
matched:=matched+1
else index:=1;
index:=index-1
end;
cntnum:=cntnum+1;
if matched > 2 then return:=return+matched+1;
countscore:=return
end;
end; {countscore}
function humplay:integer;
var i,j: integer;
begin
if human[1].rank > 10 then i:=10
else i:=human[1].rank;
if (humleft <= 0) or ((i+curcount) > 31) then
begin
humcant:=true;
humplay:=-1
end
else
begin
last:=1;
humcant:=false;
if human[2].rank > 10 then i:=10
else i:=human[2].rank;
if (humleft=1) or ((i+curcount) > 31) then
humplay:=1
else
begin
j:=0;
while j=0 do
begin
write('Play which card? [ ');
for i:=1 to playsize do
if human[i].rank <> 0 then showcard(human[i]);
write(' ] ');
i:=getelement;
if human[i].rank > 10 then j:=10
else j:=human[i].rank;
if (j+curcount) > 31 then
begin
writeln('Sorry, that''s more than 31');
j:=0
end
end;
humplay:=i
end
end
end; {humplay}
function complay:integer;
var
index: 1..playsize;
points, best: integer;
tmp: 0..10;
return: 1..playsize;
begin
best:=-1;
if comp[1].rank > 10 then tmp:=10
else tmp:=comp[1].rank;
if (comleft=0) or ((tmp+curcount) > 31) then
begin
compcant:=true;
complay:=-1
end
else
begin
compcant:=false;
last:=2;
for index:=1 to comleft do
begin
if comp[index].rank>10 then tmp:=10
else tmp:=comp[index].rank;
if (tmp<>0) and ((tmp+curcount) <= 31) then
begin
points:=countscore(comp[index]);
cntnum:=cntnum-1;
curcount:=curcount-tmp;
if points>best then
begin
best:=points;
return:=index
end
end
end;
complay:=return
end;
end; {complay}
begin {count -- at last!}
humleft:=playsize;
comleft:=playsize;
humcant:=false;
compcant:=false;
last:=0;
cntnum:=1;
if common.rank=11 then
begin
if who then
begin
writeln('I get a point for Nobs!');
addpoints(false,1);
end
else
begin
writeln('YOU get a point for Nobs!!');
addpoints(true,1);
end
end;
for curcount:=1 to playsize do
oldhuman[curcount]:=human[curcount];
curcount:=0;
while (humleft > 0) or (comleft > 0) do
begin
if who then
begin
who:=false;
i:=humplay;
if i>0 then
begin
write('You played a ');
showcard(human[i]);
writeln('.');
points:=countscore(human[i]);
if points>0 then
begin
writeln('You got ',points,' points');
addpoints(true,points);
end;
while i<=(playsize-1) do
begin
human[i]:=human[i+1];
i:=i+1
end;
human[humleft].rank:=0;
humleft:=humleft-1
end
end;
if not who then
begin
who:=true;
i:=complay;
if i>0 then
begin
write('I play a ');
showcard(comp[i]);
writeln('.');
points:=countscore(comp[i]);
if points>0 then
begin
writeln('I got ',points,' points.');
addpoints(false,points);
end;
while i <= (playsize-1) do
begin
comp[i]:=comp[i+1];
i:=i+1
end;
comp[comleft].rank:=0;
comleft:=comleft-1
end
end;
if lastcnt<>curcount then writeln('Total is ',curcount,'.');
lastcnt:=curcount;
if (humcant and compcant) or ((humleft=0) and (comleft=0)) then
begin
case last of
0: ;
1: begin
writeln('You got a point for last card.');
addpoints(true,1);
who:=false
end;
2: begin
writeln('I got a point for last card.');
addpoints(false,1);
who:=true
end
end; {case}
writeln;
writeln('Total is now 0.');
writeln;
humcant:=false;
compcant:=false;
last:=0;
cntnum:=1;
curcount:=0
end;
end;
for curcount:=1 to playsize do
human[curcount]:=oldhuman[curcount];
end; {count}
procedure check(num: integer; question: str80);
begin
repeat
write(question);
getln(user);
val(user,usernum,code);
if code<>0
then writeln(user,'??')
else writeln;
until code=0;
if usernum<>num then
begin
writeln('Unless there''s a bug in my program, you should have taken ',num,' points!');
writeln('I get ',abs(num-usernum),', regardless!');
addpoints(false,abs(num-usernum));
if usernum>num then usernum:=num
end;
if (usernum > 0) then addpoints(true,usernum);
writeln;
end; {check}
begin {play}
inline($21/0/0/ { LD HL,0000h ; MARK PROC }
$39/ { ADD HL,SP ; FOR EXIT }
$22/xplayx); { LD (xplayx),HL }
repeat { forever -- we get out by simulating an Exit(Play) }
shuffle;
deal;
if who then writeln('It''s my crib.')
else writeln('It''s your crib.');
sort(6,human);
tocrib;
compcrib;
sort(4,crib);
if who then
begin
repeat
write('Cut which card [1-40] ? ');
getln(user);
val(user,usernum,code);
if code<>0
then writeln(user,'??')
else writeln
until (code=0) and (usernum in [1..40]);
common:=deck[usernum+12]
end
else
begin
common:=deck[13+random(40)]
end;
write('The UPCARD is ');
showcard(common);
writeln;
cpoints:=score(comp);
hpoints:=score(human);
crbpnts:=score(crib);
writeln;
count(who);
writeln;
if who then
begin
write('[ ');
for usernum:=1 to playsize do showcard(human[usernum]);
write(' ] [ ');
showcard(common);
writeln(' ]');
check(hpoints,'How many points you got? ');
writeln('I''ve got ',cpoints,' points in my hand');
addpoints(false,cpoints);
writeln('I have ',crbpnts,' points in my crib');
addpoints(false,crbpnts);
end
else
begin
writeln('I''ve got ',cpoints,' in my hand');
addpoints(false,cpoints);
writeln;
write('[ ');
for usernum := 1 to playsize do showcard(human[usernum]);
write(' ] [ ');
showcard(common);
writeln(' ]');
check(hpoints,'How many points in YOUR hand? ');
writeln;
write('[ ');
for usernum:=1 to playsize do showcard(crib[usernum]);
write(' ] [ ');
showcard(common);
writeln(' ]');
check(crbpnts,'How much in the crib? ');
end;
who:=not who
until false
end; {play}
BEGIN {MAIN}
1:
lowvideo;
clrscr;
writeln(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
writeln(':: W E L C O M E TO K I D D I E K R I B B A G E ! ::');
writeln(':: ::');
writeln(':: Adapted from "Cribbage" in APPLE PASCAL GAMES, by Douglas Hergert ::');
writeln(':: and Joseph T. Kalash, pages 301-349. Sybex, 1981. ::');
writeln(':: ::');
writeln(':: TURBO Pascal 1.0, Copyright 1983 by Borland Intl. 1/17/84 DCO ::');
writeln(':: Updated for Turbo Pascal 2.0 1/06/85 ADH ::');
writeln(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
writeln;
writeln('It''s you against me, kid! Whoever pegs 121 points first wins!');
writeln;
write('Do you want instructions? <Y>');
read(kbd,ch); writeln(ch);
if NOT (ch in ['n','N'])
then list_instructions;
writeln;
if cscore>hscore
then writeln('Ho Ho!! I peg out and win this game!')
else writeln('You pegged out and won the game! Congratulations!');
writeln; writeln; writeln;
write('Do you want another game? ');
read(kbd,ch); writeln(ch);
if ch in ['n','N']
then writeln('OK, see you later!')
else goto 1
END.
