Sign In
Create Account
Follow Us on Twitter
Subscribe on Youtube
program tripleyahtzee;
{ This program allows the user to play a games of Triple Yahtzee. }
uses crt;
const
numdice=5;
sides=6;
type
dietype=0..sides;
dicetype=array[1..numdice] of dietype;
modetype=(regular,triple);
scores=(aces,twos,threes,fours,fives,sixes,threeofakind,fourofakind,fullhouse,smallstraight,largestraight,yahtzee,
chance,bonusyahtzee,upper,bonus,lower,total);
scorecardtype=array[1..3,aces..total] of integer;
settype1=set of scores;
settype2=array [1..3] of settype1;
var
done:boolean;
dice:dicetype;
mode:modetype;
scorecard:scorecardtype;
dieuses:settype1;
available:settype2;
numrolls:integer;
{ ------------------------------------------------------------------------- }
procedure instruct;
{ This procedure allows the user to get instructions on how to play Triple
Yahtzee. }
var
yn:char;
begin
repeat
clrscr;
write('Do you want instructions (Y/N)? ');readln(yn);
yn:=upcase(yn);
until yn in ['Y','N'];
if yn='Y' then
begin
clrscr;
writeln(' Triple Yahtzee can be played in two modes, Yahtzee or Triple Yahtzee.');
writeln('Yahtzee is played by rolling five dice up two three times. After the first');
writeln('roll you have the option to reroll 1 to 5 of them or accept the roll. The');
writeln('same thing can be done after the second roll. After the third roll, however,');
writeln('you MUST take whatever the dice are. When you decide to accept the roll, you');
writeln('can then score it in any of the open boxes. In the boxes 1s, 2s, 3s, 4s, 5s,');
writeln('and 6s all the 1s, 2s, etc. rolled on the dice are added together and put in');
writeln('that box. If the sum of the scores in the 1s through 6s boxes is greater');
writeln('than or equal to 63 you will get a 35 point bonus. The other boxes are 3 of');
writeln('a kind, 4 of a kind, full house, small straight, large straight, Yahtzee, and');
writeln('chance. 3 and 4 of a kind allow you to put in the sum of all five dice if');
writeln('3 or 4 of the dice are the same. Full house scores 25 points if the dice are');
writeln('three of a kind and a pair. A 1,2,3,4; 2,3,4,5; 3,4,5,6 scores 30 points in');
writeln('small straight while a 1,2,3,4,5 or a 2,3,4,5,6 scores 40 points in large');
writeln('straight. A five of a kind scores 50 points in the Yahtzee box. The sum of');
writeln('all five dice, no matter what they are, can be placed in chance. If the dice');
writeln('do not fit into any box, you can take a zero in one of them. If you get a');
writeln('a Yahtzee, you can also use it as a wild if the Yahtzee box has already been');
writeln('filled and the appropriate number box has been filled. The Yahtzee may then');
writeln('be scored as normal in any of the special combination boxes. Also, for every');
writeln('Yahtzee after the first that was scored in a Yahtzee box, you will get 100');
writeln('extra points. Triple Yahtzee is the same as regular Yahtzee except there are');
writeln('three columns. Each column''s score is multiplied by its number.');
writeln;
write('Press ENTER to continue.');
readln;
clrscr;
writeln(' When the dice are rolled, use the arrow keys to move between the dice and');
writeln('move them up and down. Press ENTER when you have decided which dice to');
writeln('reroll. Dice that are up will be kept, dice that are down will be rerolled.');
writeln('Then use the arrow keys to move around the scorecard and press ENTER when');
writeln('the arrows are pointing at the place you want to score the dice. If scoring');
writeln('the dice in the box you have chosen will score a zero, you will be asked if');
writeln('you are sure you want to get a zero there. If you accepted the dice by');
writeln('accident, press ESC to reroll them.');
writeln;
writeln('Disclaimer, this game is NOT endorsed by --------.');
writeln;
write('Press ENTER to continue.');
readln;
end;
end; { instruct }
{ ------------------------------------------------------------------------- }
procedure selectmode(var typer:modetype;var card:scorecardtype);
{ This procedure allows the user to decide whether to play regular Yahtzee or
Triple Yahtzee. }
var
yaht:char;
i:scores;
j,k:1..3;
begin
repeat
clrscr;
write('Do you want to play Yahtzee or Triple Yahtzee (Y/T): ');readln(yaht);
yaht:=upcase(yaht);
until yaht in ['Y','T'];
clrscr;
if yaht='Y' then typer:=regular
else typer:=triple;
if typer=regular then k:=1 else k:=3;
for i:=aces to chance do
for j:=1 to k do
card[j,i]:=-1;
for i:=bonusyahtzee to total do
for j:=1 to k do
card[j,i]:=0;
end; { selectmode }
{ ------------------------------------------------------------------------- }
procedure box(xstart,ystart,xlength,ylength:integer);
{ This procedure creates a box of doubleline ASCII characters with the upper
left-hand corner at xstart,ystart. }
var
i,j:integer;
begin
gotoxy(xstart,ystart);
write('É');
for i:=2 to xlength-1 do
write('Í');
writeln('»');
for i:=2 to ylength-1 do
begin
gotoxy(xstart,i+ystart-1);
write('º');
for j:=2 to xlength-1 do
write(' ');
writeln('º');
end;
gotoxy(xstart,ystart+ylength-1);
write('È');
for i:=2 to xlength-1 do
write('Í');
write('¼');
end;
{ ------------------------------------------------------------------------- }
procedure input(var ch:integer;var bool:boolean);
{ This is a universal input routine for inputing data from the keyboard. The
boolean checks for function keys and other special keys. Ch stores the
ASCII code for the character. }
begin
ch:=ord(readkey);
if ch=0 then
begin
bool:=true;
ch:=ord(readkey);
end
else
bool:=false;
end; { input }
{ ------------------------------------------------------------------------- }
procedure rolldice(var sixers:dicetype;var j:integer);
{ This procedure allows the user to roll the five dice up to three times. }
var
key,x,y,i:integer;
chosen,arrow:boolean;
keep:array[1..5] of boolean;
begin
if j=0 then
for i:=1 to 5 do
sixers[i]:=0
else
j:=j-1;
repeat
for i:=1 to 5 do
keep[i]:=true;
j:=j+1;
for i:=1 to 5 do
if sixers[i]=0 then
sixers[i]:=random(6)+1;
for i:=1 to 5 do
begin
box(6*i-5,1,5,3);
gotoxy(6*i-3,2);
write(sixers[i]);
end;
gotoxy(1,4);
x:=3;
y:=4;
chosen:=false;
if j<>3 then
repeat
if keep[trunc((x+3)/6)] then
begin
gotoxy(x,y);
write(chr(24));
gotoxy(x,y);
end
else
begin
gotoxy(x,y-1);
write(chr(25));
gotoxy(x,y-1);
end;
input(key,arrow);
if arrow and (key in [72,75,77,80]) then
case key of
{up} 72:begin
keep[trunc((x+3)/6)]:=true;
for i:=1 to 3 do
begin
gotoxy(x-2,3+i);
writeln(' ');
end;
box(x-2,1,5,3);
gotoxy(x,2);
write(sixers[trunc((x+3)/6)]);
end;
{left} 75:begin
if keep[trunc((x+3)/6)]=true then
gotoxy(x,y)
else
gotoxy(x,y-1);
write(' ');
if x<>3 then
x:=x-6
else
x:=27;
end;
{right} 77:begin
if keep[trunc((x+3)/6)]=true then
gotoxy(x,y)
else
gotoxy(x,y-1);
write(' ');
if x<>27 then
x:=x+6
else
x:=3;
end;
{down} 80:begin
keep[trunc((x+3)/6)]:=false;
for i:=1 to 3 do
begin
gotoxy(x-2,i);
write(' ');
end;
box(x-2,4,5,3);
gotoxy(x,5);
write(sixers[trunc((x+3)/6)]);
end;
end { case }
else if key=13 then chosen:=true;
until chosen;
for i:=4 to 6 do
begin
gotoxy(1,i);
writeln(' ');
end;
for i:=1 to 5 do
if not keep[i] then dice[i]:=0;
until (j=3) or (keep[1] and keep[2] and keep[3] and keep[4] and keep[5]);
end; { rolldice }
{ ------------------------------------------------------------------------- }
procedure printcard(rort:modetype;var score:scorecardtype);
{ This procedure prints the scorecard for Triple Yahtzee. }
var
i:integer;
j:scores;
begin
if rort=regular then
begin
gotoxy(1,9);
writeln('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍ» ÉÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍ»');
writeln('º Aces º º º Upper º º');
writeln('º Twos º º º Bonus º º');
writeln('º Threes º º º Lower º º');
writeln('º Fours º º º Total º º');
writeln('º Fives º º ÈÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍͼ');
writeln('º Sixes º º');
writeln('ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍ͹');
writeln('º 3 of a Kind º º');
writeln('º 4 of a Kind º º');
writeln('º Full House º º');
writeln('º Sm. Straight º º');
writeln('º Lg. Straight º º');
writeln('º Yahtzee º º');
writeln('º Chance º º');
writeln('º Bonus Yahtzees º º');
write ('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍͼ');
end
else
begin
gotoxy(1,7);
writeln(' ÉÍÍÍÍËÍÍÍÍËÍÍÍÍ» ÉÍÍÍÍÍËÍÍÍÍÍËÍÍÍÍÍ»');
writeln(' º x1 º x2 º x3 º º x1 º x2 º x3 º');
writeln('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÎÍÍÍÍÎÍÍÍ͹ ÉÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÎÍÍÍÍÍÎÍÍÍÍ͹');
writeln('º Aces º º º º º Upper º º º º');
writeln('º Twos º º º º º Bonus º º º º');
writeln('º Threes º º º º º Lower º º º º');
writeln('º Fours º º º º º Total º º º º');
writeln('º Fives º º º º ÌÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÊÍÍÍÍÍÊÍÍÍÍ͹');
writeln('º Sixes º º º º º Grand Totalº º');
writeln('ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÎÍÍÍÍÎÍÍÍ͹ ÈÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
writeln('º 3 of a Kind º º º º');
writeln('º 4 of a Kind º º º º');
writeln('º Full House º º º º');
writeln('º Sm. Straight º º º º');
writeln('º Lg. Straight º º º º');
writeln('º Yahtzee º º º º');
writeln('º Chance º º º º');
writeln('º Bonus Yahtzees º º º º');
write ('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÊÍÍÍÍÊÍÍÍͼ');
end;
i:=0;
repeat
i:=i+1;
for j:=aces to total do
begin
case j of
aces:begin
gotoxy(15+5*i,10);
end;
twos:begin
gotoxy(15+5*i,11);
end;
threes:begin
gotoxy(15+5*i,12);
end;
fours:begin
gotoxy(15+5*i,13);
end;
fives:begin
gotoxy(15+5*i,14);
end;
sixes:begin
gotoxy(15+5*i,15);
end;
threeofakind:begin
gotoxy(15+5*i,17);
end;
fourofakind:begin
gotoxy(15+5*i,18);
end;
fullhouse:begin
gotoxy(15+5*i,19);
end;
smallstraight:begin
gotoxy(15+5*i,20);
end;
largestraight:begin
gotoxy(15+5*i,21);
end;
yahtzee:begin
gotoxy(15+5*i,22);
end;
chance:begin
gotoxy(15+5*i,23);
end;
bonusyahtzee:begin
gotoxy(15+5*i,24);
end;
upper:begin
gotoxy(47+6*i,10);
end;
bonus:begin
gotoxy(47+6*i,11);
end;
lower:begin
gotoxy(47+6*i,12);
end;
total:begin
gotoxy(47+6*i,13);
end;
end; { case }
if (score[i,j]<>-1) then
if j<upper then
write(score[i,j]:2)
else
write(score[i,j]:3);
end;
gotoxy(57,15);
if rort=triple then write(score[1,total]+2*score[2,total]+3*score[3,total]:5);
until ((rort=regular)and(i=1))or((rort=triple)and(i=3));
end; { printcard }
{ ------------------------------------------------------------------------- }
function gameover(var card:scorecardtype;typer:modetype):boolean;
{ This function determines whether or not the scorecard is filled. }
var
i,k:integer;
j:scores;
temp:boolean;
begin
temp:=true;
if typer=regular then k:=1 else k:=3;
for i:=1 to k do
for j:=aces to chance do
if card[i,j]=-1 then temp:=false;
gameover:=temp;
end; { gameover }
{ ------------------------------------------------------------------------- }
procedure makesets(var set1:settype1;var set2:settype2;typer:modetype;var card:scorecardtype;sixers:dicetype);
{ This procedure creates the sets that contain the uses of the dice and
where they can be put. }
var
i,j,temp:integer;
k:scores;
temp2:array[1..6] of integer;
begin
if typer=regular then i:=1 else i:=3;
set1:=[chance];
set2[1]:=[];
set2[2]:=[];
set2[3]:=[];
for j:= 1 to i do
for k:=aces to chance do
if card[j,k]=-1 then set2[j]:=set2[j]+[k];
for i:=1 to 4 do
for j:=i+1 to 5 do
if sixers[i]>sixers[j] then
begin
temp:=sixers[i];
sixers[i]:=sixers[j];
sixers[j]:=temp;
end;
for i:=1 to 5 do
temp2[i]:=0;
temp2[1]:=sixers[1];
for i:=2 to 5 do
if temp2[i-1]<>sixers[i] then temp2[i]:=sixers[i];
for i:=1 to 4 do
for j:=i+1 to 5 do
if temp2[i]>temp2[j] then
begin
temp:=temp2[i];
temp2[i]:=temp2[j];
temp2[j]:=temp;
end;
for i:=1 to 6 do
begin
if sixers[i]=1 then set1:=set1+[aces];
if sixers[i]=2 then set1:=set1+[twos];
if sixers[i]=3 then set1:=set1+[threes];
if sixers[i]=4 then set1:=set1+[fours];
if sixers[i]=5 then set1:=set1+[fives];
if sixers[i]=6 then set1:=set1+[sixes];
if (i<5)and(sixers[i]=sixers[i+1])and(sixers[i+1]=sixers[i+2]) then set1:=set1+[threeofakind];
if (i<4)and(sixers[i]=sixers[i+1])and(sixers[i+1]=sixers[i+2])and(sixers[i+2]=sixers[i+3]) then
set1:=set1+[fourofakind];
if (i<4)and((temp2[i]=temp2[i+1]-1)and(temp2[i+1]=temp2[i+2]-1)and(temp2[i+2]=temp2[i+3]-1)) then
set1:=set1+[smallstraight];
if (i<3)and((sixers[i]=sixers[i+1]-1)and(sixers[i+1]=sixers[i+2]-1)and(sixers[i+2]=sixers[i+3]-1)
and(sixers[i+3]=sixers[i+4]-1)) then set1:=set1+[largestraight];
end;
if (sixers[1]=sixers[2])and(sixers[2]=sixers[3])and(sixers[3]=sixers[4])and(sixers[4]=sixers[5]) then
set1:=set1+[yahtzee];
if (sixers[1]=sixers[2])and(sixers[2]=sixers[3])and(sixers[3]<>sixers[4])and(sixers[4]=sixers[5]) then
set1:=set1+[fullhouse];
if (sixers[1]=sixers[2])and(sixers[2]<>sixers[3])and(sixers[3]=sixers[4])and(sixers[4]=sixers[5]) then
set1:=set1+[fullhouse];
if (yahtzee in set1)and not(yahtzee in set2[1])and not(yahtzee in set2[2])and not(yahtzee in set2[3])
and(card[1,yahtzee]<>0)and(card[2,yahtzee]<>0)and(card[3,yahtzee]<>0) then
for k:=aces to sixes do
if (k in set1)and not(k in set2[1])and not(k in set2[2]) and not(k in set2[3]) then
set1:=set1+[fullhouse..largestraight];
end; { makesets }
{ ------------------------------------------------------------------------- }
procedure placescore(sixers:dicetype;var card:scorecardtype;typer:modetype;set1:settype1;set2:settype2;var rolls:integer);
{ This procedure allows the user to score the dice in any of the slots. }
var
i,x,y,key,temp:integer;
ok,arrow:boolean;
j,ypos:scores;
sure:char;
begin
x:=1;
y:=1;
ypos:=aces;
repeat
if y in [1..6] then
gotoxy(14+5*x,9+y)
else
gotoxy(14+5*x,10+y);
write(chr(26));
if y in [1..6] then
gotoxy(17+5*x,9+y)
else
gotoxy(17+5*x,10+y);
write(chr(27));
input(key,arrow);
if arrow and (key in [72,75,77,80]) then
begin
if y in [1..6] then
gotoxy(14+5*x,9+y)
else
gotoxy(14+5*x,10+y);
write(' ');
if y in [1..6] then
gotoxy(17+5*x,9+y)
else
gotoxy(17+5*x,10+y);
write(' ');
case key of
{ up } 72:if ypos<>aces then
begin
ypos:=pred(ypos);
y:=y-1;
end
else
begin
ypos:=chance;
y:=13;
end;
{ lt } 75:if x<>1 then
x:=x-1
else if typer<>regular then
x:=3;
{ rt } 77:if (x<>3) and (typer<>regular) then
x:=x+1
else if x=3 then
x:=1;
{ dn } 80:if ypos<>chance then
begin
ypos:=succ(ypos);
y:=y+1;
end
else
begin
ypos:=aces;
y:=1;
end;
end; { case }
end;
if ypos in set2[x] then ok:=true else ok:=false;
if ok and not arrow and(key=13) then
begin
if not(ypos in set1) then
begin
gotoxy(38,17);
write('Are you sure you want to take a zero (Y/N)?');
repeat
sure:=upcase(readkey);
until sure in ['Y','N'];
gotoxy(38,17);
write(' ');
if sure='Y' then
begin
card[x,ypos]:=0;
rolls:=0;
end
else
ok:=false;
end
else
begin
rolls:=0;
case ypos of
aces:begin
temp:=0;
for i:=1 to 5 do
if sixers[i]=1 then temp:=temp+1;
card[x,ypos]:=temp;
end;
twos:begin
temp:=0;
for i:=1 to 5 do
if sixers[i]=2 then temp:=temp+2;
card[x,ypos]:=temp;
end;
threes:begin
temp:=0;
for i:=1 to 5 do
if sixers[i]=3 then temp:=temp+3;
card[x,ypos]:=temp;
end;
fours:begin
temp:=0;
for i:=1 to 5 do
if sixers[i]=4 then temp:=temp+4;
card[x,ypos]:=temp;
end;
fives:begin
temp:=0;
for i:=1 to 5 do
if sixers[i]=5 then temp:=temp+5;
card[x,ypos]:=temp;
end;
sixes:begin
temp:=0;
for i:=1 to 5 do
if sixers[i]=6 then temp:=temp+6;
card[x,ypos]:=temp;
end;
threeofakind:card[x,ypos]:=sixers[1]+sixers[2]+sixers[3]+sixers[4]+sixers[5];
fourofakind:card[x,ypos]:=sixers[1]+sixers[2]+sixers[3]+sixers[4]+sixers[5];
fullhouse:card[x,ypos]:=25;
smallstraight:card[x,ypos]:=30;
largestraight:card[x,ypos]:=40;
yahtzee:card[x,ypos]:=50;
chance:card[x,ypos]:=sixers[1]+sixers[2]+sixers[3]+sixers[4]+sixers[5];
end; { case }
if (yahtzee in set1)and(largestraight in set1) then card[x,bonusyahtzee]:=card[x,bonusyahtzee]+1;
temp:=0;
for j:=aces to sixes do
if card[x,j]<>-1 then temp:=temp+card[x,j];
card[x,upper]:=temp;
if card[x,upper]>=63 then card[x,bonus]:=35;
temp:=0;
for j:=threeofakind to chance do
if card[x,j]<>-1 then temp:=temp+card[x,j];
card[x,lower]:=temp;
card[x,total]:=card[x,upper]+card[x,bonus]+card[x,lower]+100*card[x,bonusyahtzee];
end;
end;
if not(arrow)and(key=27)and(rolls<>3) then
ok:=true;
until ok and not arrow and ((key=13)or((key=27)and(rolls<>3)));
if y in [1..6] then
gotoxy(14+5*x,9+y)
else
gotoxy(14+5*x,10+y);
write(' ');
if y in [1..6] then
gotoxy(17+5*x,9+y)
else
gotoxy(17+5*x,10+y);
write(' ');
printcard(mode,card);
if gameover(card,typer) then
begin
gotoxy(38,17);
write('Press ENTER to continue...');
readln;
end;
end; { placescore }
{ ------------------------------------------------------------------------- }
procedure quit(var bool:boolean);
{ This procedure determines whether or not the user wants to stop playing. }
var
yn:char;
begin
repeat
clrscr;
write('Do you want to quit (Y/N)? ');readln(yn);
yn:=upcase(yn);
until yn in ['Y','N'];
if yn='Y' then bool:=true;
end; { quit }
{ ========================================================================= }
begin
randomize;
instruct;
done:=false;
repeat
selectmode(mode,scorecard);
printcard(mode,scorecard);
numrolls:=0;
repeat
rolldice(dice,numrolls);
makesets(dieuses,available,mode,scorecard,dice);
placescore(dice,scorecard,mode,dieuses,available,numrolls);
until gameover(scorecard,mode);
quit(done);
until done;
end.
Note: you can download Turbo Pascal 5.5 here:Download Turbo Pascal, Turbo Pascal 5.5 Download or Antique Software: Turbo Pascal v5.5
3 replies to this topic
#1
Posted 05 December 2009 - 07:05 AM
WingedPanther
-
- Moderators
-
- 16,831 posts
A spammer's worst nightmare
I was digging around in my room when I found an old floppy disk (3.5", 1.44 MB!) from when I was in school... We're talking 1990. Here's the Yahtzee/Triple Yahtzee program I wrote :)
Back to top|
|
|
#2
Posted 04 March 2010 - 12:46 AM
Bioshox
-
- Members
-
- 207 posts
Programming Professional
#3
Posted 05 March 2010 - 02:34 PM
chili5
-
- Members
-
- 7,247 posts
Writes binary right handed and hex left handed
Woah, that is very cool. :) I'll download a turbo pascal compiler later to try it out.
It's incredible that you have a program that you made 20 years ago. :) So one question: if you had to do that program now, could you make it in a better way or would you do it exactly the same way?
It's incredible that you have a program that you made 20 years ago. :) So one question: if you had to do that program now, could you make it in a better way or would you do it exactly the same way?
#4
Posted 05 March 2010 - 02:55 PM
WingedPanther
-
- Moderators
-
- 16,831 posts
A spammer's worst nightmare
To me, it's showing its age. Don't get me wrong, it works well, and I'm still proud of it, but I would do it very differently today. Of course, I'd do it with a GUI. The way I draw the game board, in particular, annoys me. I also remember all the DUMB stuff I did in setting it up. The thing I'm proudest of, though, is my little input routine. :D
