Shareware Overload/ShartewareOverload.cdr/games/tbridge.zip/SCORE.BR

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 }