home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
games
/
tbridge.zip
/
SCORE.BR
< prev
Wrap
Text File
|
1986-06-01
|
19KB
|
668 lines
{ ╔══════════════════════════════════════════════════════╗
║ SCORE.BR Module of BRIDGE.PAS ║ ║
║ ║
║ Last modified 10/29/85 ║
║ ║
║ Calculates, displays and outputs bridge score. ║
║ ║
╚══════════════════════════════════════════════════════╝
}
type
GameRecordType = array[1..3] of integer;
ScoreType = record
GamesWon,
OverLine,
Total : integer;
GameRecord : GameRecordType;
end;
GameTableType = record
CurGame : integer;
N_S,
E_W : ScoreType;
end;
var
Games : GameTableType;
procedure InitScore;
{ Initializes the scoring record }
begin
FillChar(Games, SizeOf(Games), chr(0));
end; { InitScore }
procedure DisplayScore(RubberBonus : integer);
const
FirstCol = 60;
FirstRow = 11;
LastCol = 79;
LastRow = 22;
BorderTop = 1;
BorderBottom = 12;
BorderLeft = 1;
BorderRight = 20;
procedure ClearBoard;
{ Clears the score board }
begin
Window(FirstCol + 1, FirstRow + 1, LastCol - 1, LastRow - 1);
ClrScr;
Window(FirstCol, FirstRow, LastCol, LastRow + 1);
end; { ClearBoard }
procedure DrawBorder;
{ Draw a border around the score board }
var
Row, Col : integer;
begin
SetColor(BorderColor);
GotoXY(BorderLeft, BorderTop);
Write('╔');
for Col := BorderLeft + 1 to BorderRight - 1 do
begin
if Col = (BorderLeft + (BorderLeft + BorderRight) div 2) then
Write('╤')
else
Write('═');
end;
Write('╗');
for Row := BorderTop + 1 to BorderBottom - 1 do
begin
GotoXY(BorderLeft, Row);
Write('║');
GotoXY(BorderRight, Row);
Write('║');
end;
GotoXY(BorderLeft, BorderBottom);
Write('╚');
for Col := BorderLeft + 1 to BorderRight - 1 do
if Col = (BorderLeft + (BorderLeft + BorderRight) div 2) then
Write('╧')
else
Write('═');
Write('╝');
GotoXY(4,BorderTop);
Write('[');
SetColor(ScoreColor);
Write('BRIDGE');
GotoXY(12, BorderTop);
Write('SCORE');
SetColor(BorderColor);
Write(']');
SetColor(ScoreBrdColor);
end; { DrawBorder }
procedure DrawLine(CurY : integer);
{ Draws a single Line }
var
CurX : integer;
begin
SetColor(BorderColor);
GotoXY(BorderLeft, BorderTop + CurY);
Write('╟');
SetColor(ScoreBrdColor);
for CurX := (BorderLeft + 1) to (BorderRight - 1) do
begin
GotoXY(CurX, BorderTop + CurY);
if CurX = (BorderLeft + (BorderLeft + BorderRight) div 2) then
Write('┼')
else
Write('─');
end;
GotoXY(BorderRight, BorderTop + CurY);
SetColor(BorderColor);
Write('╢');
SetColor(ScoreBrdColor);
end; { DrawLine }
procedure DisplayTotals(var Games : GameTableType;
RubberBonus : integer);
const
NorthCol = 4;
EastCol = 14;
procedure DispGame(var Games : GameTableType;
ThisGame : integer;
var CurY : integer );
begin
with Games do
begin
GotoXY(NorthCol, (BorderTop + CurY)); { The score under the Line }
with N_S do
begin
Write(GameRecord[ThisGame]:4);
Total := Total + GameRecord[ThisGame];
end;
GotoXY(EastCol,BorderTop + CurY);
with E_W do
begin
Write(GameRecord[ThisGame]:4);
Total := Total + GameRecord[ThisGame];
end;
CurY := CurY + 1;
end; { with }
end; { DispGame }
procedure DispTeamScores(var Games : GameTableType);
const
Start = 4;
var
i, CurY : integer;
begin
with Games do
for i := 1 to CurGame do
begin
CurY := Start + (2 * (i -1));
DispGame(Games, i, CurY);
if i < CurGame then
DrawLine(CurY);
end;
end; { DispTeamScores }
procedure DispTeamTotals(var Games : GameTableType);
const
TotalLine = 1;
OverLinePos = 2;
begin
with Games do
begin
GotoXY(NorthCol, BorderTop + OverLinePos);
Write(N_S.OverLine:4);
GotoXY(EastCol, BorderTop + OverLinePos);
Write(E_W.OverLine:4);
GotoXY(NorthCol,BorderBottom - TotalLine);
with N_S do
begin
Total := Total + OverLine;
Write(Total:4);
end;
GotoXY(EastCol,BorderBottom - TotalLine);
with E_W do
begin
Total := Total + OverLine;
Write(Total:4);
end;
end;
end; { DispTeamTotals }
procedure AddBonus(RubberBonus : integer);
begin
if RubberBonus > 0 then
with Games do
case Dummy of
North, South : N_S.Overline := N_S.Overline + RubberBonus;
East, West : E_W.Overline := E_W.Overline + RubberBonus;
end;
end; { AddBonus }
begin { DisplayTotals }
with Games do
begin
with Games do
begin
N_S.Total := 0;
E_W.Total := 0;
end;
if CurGame > 0 then
begin
AddBonus(RubberBonus);
DispTeamScores(Games);
end;
DispTeamTotals(Games);
end;
end; { DisplayTotals }
procedure DrawBoard;
procedure DrawDblLine;
const
DblLinePos = 3;
var
CurX : integer;
begin
SetColor(BorderColor);
GotoXY(BorderLeft, BorderTop + DblLinePos);
Write('╠');
SetColor(ScoreBrdColor);
for CurX := (BorderLeft + 1) to (BorderRight - 1) do
begin
GotoXY(CurX, BorderTop + DblLinePos);
if CurX = (BorderLeft + (BorderLeft + BorderRight) div 2) then
Write('╪')
else
Write('═');
end;
GotoXY(BorderRight, BorderTop + DblLinePos);
SetColor(BorderColor);
Write('╣');
SetColor(ScoreBrdColor);
end; { DrawDblLine }
procedure DrawTotalLine;
const
TotalLinePos = 2;
var
CurX : integer;
begin
SetColor(BorderColor);
GotoXY(BorderLeft, BorderBottom - TotalLinePos);
Write('╠');
SetColor(ScoreBrdColor);
for CurX := (BorderLeft + 1) to (BorderRight - 1) do
begin
GotoXY(CurX, BorderBottom - TotalLinePos);
if CurX = (BorderLeft + (BorderLeft + BorderRight) div 2) then
Write('╪')
else
Write('═');
end;
GotoXY(BorderRight, BorderBottom - TotalLinePos);
SetColor(BorderColor);
Write('╣');
SetColor(ScoreBrdColor);
end; { DrawTotalLine }
var
CurX, CurY : integer;
begin { DrawBoard }
GotoXY(BorderLeft + 4, BorderTop + 1);
Write('N/S E/W');
CurX := BorderLeft + (BorderLeft + BorderRight) div 2;
for CurY := (BorderTop + 1) to (BorderBottom - 1) do
begin
GotoXY(CurX,CurY);
Write('│');
end;
DrawDblLine;
DrawTotalLine;
end; { DrawBoard }
procedure RestoreScreen;
begin
ClrScr;
Window(FirstCol, FirstRow, LastCol, LastRow + 1);
ClrScr;
Window(1, 1, 80, 25);
ClearMenu;
GotoXY(1, 1);
end; { RestoreScreen }
procedure CompareTotals(RubberBonus : integer);
{ Checks to see if the team that won the rubber game also won the rubber }
begin
with Games do
begin
case Dummy of
North, South : begin
N_S.Total := N_S.Total + RubberBonus;
if E_W.Total > N_S.Total then Write(' E/W ')
else Write(' N/S ');
end;
East, West : begin
E_W.Total := E_W.Total + RubberBonus;
if N_S.Total > E_W.Total then Write(' N/S ')
else Write(' E/W ');
end;
end;
Write('won the rubber ');
end;
end; { CompareTotals }
begin { DisplayScore }
SetColor(NormalColor);
ClearMenu;
Window(FirstCol, FirstRow, LastCol, LastRow + 1);
DrawBorder;
SetColor(ScoreBrdColor);
ClearBoard;
DrawBoard;
DisplayTotals(Games, RubberBonus);
FlushBuffer;
Window(FirstCol - 12, 21, LastCol, 25);
GotoXY(4,1);
SetColor(NormalColor);
Write('Totals');
if (RubberBonus > 0) then
begin
SetColor(MessageColor);
if RubberBonus > 1 then
begin
GotoXY(5, 3);
Write(' ');
PrintTeam(Dummy);
Write(' won game ',Games.CurGame:1, ' and ');
Write(RubberBonus:1,' Pts ');
GotoXY(5, 4);
CompareTotals(RubberBonus);
end
else
begin
GotoXY(5, 4);
Write(' ');
PrintTeam(Dummy);
Write(' team won current game ');
end;
end;
GotoXY(6, 5);
FlushBuffer;
SetColor(NormalColor);
Write('Hit any key to continue');
ReadOne;
RestoreScreen;
end; { DisplayScore }
procedure OutputScore(RubberBonus : integer);
procedure OutputTotals(var Games : GameTableType);
procedure OutputGame(var Games : GameTableType;
ThisGame : integer);
{ Prints the underline total for the passed in game to the output file
and updates the overall total for each team }
begin
with Games do
begin
with N_S do
begin
Write(OutputFile, ' ':24, GameRecord[ThisGame]:4);
Total := Total + GameRecord[ThisGame];
end;
Write(OutputFile, ' | ');
with E_W do
begin
Writeln(OutputFile, GameRecord[ThisGame]:4);
Total := Total + GameRecord[ThisGame];
end;
end; { with }
end; { OutputGame }
procedure OutputTeamScores(var Games : GameTableType);
var
i : integer;
begin
with Games do
for i := 1 to CurGame do
begin
OutputGame(Games, i);
if i < CurGame then
Writeln(OutputFile, ' ':24 , '--------------');
end;
end; { OutputTeamScores }
procedure OutputOverLine(var Games : GameTableType);
begin
with Games do
begin
Write(OutputFile,' ':24 , N_S.OverLine:4);
Write(OutputFile, ' | ');
Writeln(OutputFile, E_W.OverLine:4);
Writeln(OutputFile, ' ':24 , '==============');
end;
end; { OutputOverLine }
procedure OutputTeamTotals(var Games : GameTableType);
begin
with Games do
begin
Writeln(OutputFile, ' ':24 , '==============');
Write(OutputFile, ' ':15 , 'Totals: ');
with N_S do
Write(OutputFile, Total + OverLine:4 , ' | ');
with E_W do
Write(OutputFile, Total + OverLine:4);
end;
end; { OutputTeamTotals }
begin { OutputTotals }
OutputOverLine(Games);
OutputTeamScores(Games);
OutputTeamTotals(Games);
end; { OutputTotals }
begin { OutputScore }
Writeln(OutputFile);
Writeln(OutputFile,' ':23 , 'BRIDGE SCORE');
Writeln(OutputFile,' ':22 , '=================');
Writeln(OutputFile,' ':25 , 'N/S | E/W');
OutputTotals(Games);
Writeln(OutputFile);
Writeln(OutputFile);
if (RubberBonus > 0) then
begin
Write(OutputFile,' ':10);
OutputTeam(Dummy);
if RubberBonus > 1 then
begin
Write(OutputFile,' team won rubber game ', Games.CurGame:1);
Writeln(OutputFile, ' and ',RubberBonus:1,' points');
end
else
Writeln(OutputFile, ' team won current game');
end;
Writeln(OutputFile);
end; { OutputScore }
procedure CalculateScore;
const
Game = 100; { Points neccesary to win Game }
ClubDiamondValue = 20; { score for Club and Diamond Tricks }
HeartSpadeValue = 30; { score for Heart and Spade Tricks }
NoTrumpValueOne = 40; { score for first No Trump trick }
NoTrumpOverOne = 30; { each No Trump trick after the first }
NotVulnerableOverTrick = 50;
VulnerableOverTrick = 100;
MakeDoubledContract = 50;
NotVulnerableLittleSlam = 500;
VulnerableLittleSlam = 750;
NotVulnerableGrandSlam = 1000;
VulnerableGrandSlam = 1500;
TwoGameRubberBonus = 700; { Bonus for wining rubber in two Games }
ThreeGameRubberBonus = 500; { bonus for wining rubber in three Games }
var { CalculateScore global variables }
Vulnerable : boolean;
Winner, Loser : ScoreType;
GameWon,
RubberWon : boolean;
procedure CalcVulnerabilityPnts(var W : ScoreType);
{ this routine determines the bonus points awarded to the user, taking }
{ into consideration the vulnerability of the team. }
begin
with Rel, Contract, W do
begin
case Vulnerable of
true : begin
if Level = 6 then { Small Slam }
OverLine := OverLine + VulnerableLittleSlam
else
if Level = 7 then
OverLine := OverLine + VulnerableGrandSlam
else
if Doubled > 0 then
OverLine := OverLine + MakeDoubledContract +
(((WonTricks-(Level+6))*VulnerableOverTrick)*(Doubled*2))
end;
false : begin { Small Slam }
if Level = 6 then
OverLine := OverLine + NotVulnerableLittleSlam
else
if Level = 7 then { Grand Slam }
OverLine := OverLine + NotVulnerableGrandSlam
else
if Doubled > 0 then
OverLine := OverLine + MakeDoubledContract +
(((WonTricks - (Level+6))*NotVulnerableOverTrick)
* (Doubled * 2));
end;
end; { case }
end; { with }
end; { CalcVulnerabilityPnts }
procedure CalcGamePnts(var W : ScoreType;
var RubberWon : boolean);
{ this routine is called if the team that is playing the Contract wins }
{ enough points to win the current Game. }
begin
with Rel, Contract, W do
begin
if GamesWon = 1 then
RubberWon := false
else
RubberWon := true;
end; { with }
end; { CalcGamePnts }
procedure CalcPenaltyPnts(var W : ScoreType);
{ this routine calculates the penalty points awarded to the team that }
{ lost the Bid in the case that the team that won the Bid did not win a }
{ sufficient Number of Tricks. }
begin
with Rel, Contract, W do
if Winner.GamesWon = 0 then { not Vulnerable }
if Doubled = 0 then
OverLine := OverLine + (50 * (Level + 6 - WonTricks))
else { Doubled > 0 }
OverLine := OverLine + 100 + (200 * ((Level + 6) - WonTricks - 1))
else { GamesWon > 0 }
if Doubled = 0 then
OverLine := OverLine + (100 * (Level + 6 - WonTricks))
else { Doubled > 0 }
OverLine := OverLine + 200 + (300 * ((Level + 6) - WonTricks - 1));
end; { CalcPenaltyPnts }
procedure CaseAssign(var W, L: ScoreType; Init: boolean);
{ this routine is called to assign the temporary varables Winner and }
{ Loser their appropriate values from ScoreTable. or to assign Winner }
{ and Loser to their appropriate fields of ScoreTable. }
begin
with Games do
case Init of
true : case Dummy of
North, South : begin
W := N_S;
L := E_W;
end;
East, West : begin
W := E_W;
L := N_S;
end;
end; { case }
false : case Dummy of
North, South : begin
N_S := W;
E_W := L;
end;
East, West : begin
E_W := W;
N_S := L;
end;
end; { end case }
end; { end case }
end; { end CaseAssign }
procedure CalculatePoints(var W : ScoreType; CurGame : integer;
var GameWon, RubberWon : boolean);
{ this routine calculates the points for the current Game and updates }
{ the teams Total scores. }
procedure CaseCalc(Value, CurGame : integer);
{ this routine is called by the CalculatePoints routine if the Trump }
{ Suit was a Club, Diamond, Heart, or Spade. }
begin
with Rel, Contract, W do
begin
if Doubled = 0 then
begin
GameRecord[CurGame] := GameRecord[CurGame] + (Level * Value);
OverLine := OverLine + ((WonTricks - (Level + 6)) * Value);
end { end if then }
else
GameRecord[CurGame] := GameRecord[CurGame] +
((Level * Value) * (Doubled * 2));
end; { with }
end; { CaseCalc }
begin { CalculatePoints }
GameWon := false;
with Rel, Contract, W do
begin
case Trump of
Club, Diamond : CaseCalc(ClubDiamondValue, CurGame);
Heart, Spade : CaseCalc(HeartSpadeValue, CurGame);
else { case's else - No_Trump }
if Doubled = 0 then
begin
GameRecord[CurGame] := GameRecord[CurGame] + NoTrumpValueOne +
((Level - 1) * NoTrumpOverOne);
OverLine := OverLine + ((WonTricks - 6 - Level) * NoTrumpOverOne);
end { if }
else
GameRecord[CurGame] := GameRecord[CurGame] + ((NoTrumpValueOne +
((Level - 1) * NoTrumpOverOne)) * (Doubled * 2));
end; { case }
CalcVulnerabilityPnts(W);
if GameRecord[CurGame] >= Game then { Won Game }
begin
GameWon := true;
GamesWon := GamesWon + 1;
CalcGamePnts(W, RubberWon);
end;
end; { with }
end; { CalculatePoints }
begin { CalculateScore }
RubberWon := false;
GameWon := false;
with Games do
begin
if CurGame = 0 then
CurGame := 1;
CaseAssign(Winner, Loser, true);
with Rel, Contract do
begin
if WonTricks >= Level + 6 then
with Winner do
begin
if GamesWon > 0 then
Vulnerable := true
else
Vulnerable := false;
CalculatePoints(Winner, CurGame, GameWon, RubberWon);
end { with }
else
CalcPenaltyPnts(Loser); { else WonTricks < Level + 6 }
CaseAssign(Winner, Loser, false);
end; { with }
if RubberWon then
begin
if CurGame = 2 then
begin
DisplayScore(TwoGameRubberBonus);
OutputScore(TwoGameRubberBonus);
end
else
if (CurGame = 3) then
begin
DisplayScore(ThreeGameRubberBonus);
OutputScore(ThreeGameRubberBonus);
end;
InitScore;
end
else
begin
if GameWon then
begin
DisplayScore(1); { 1 Indicates the game was won but not rubber }
OutputScore(1);
CurGame := CurGame + 1;
end
else
begin
DisplayScore(0); { 0 indicates the game was not won }
OutputScore(0);
end;
end;
end;
end; { CalculateScore }
{ end SCORE.BR }