Source Code 1992 March/Source_Code_CD-ROM_Walnut_Creek_March_1992.iso/msdos/turbopas/tppop16.arc/DICE.PAS

Pascal/Delphi Source File | 1988-09-29 | 9.1 KB | 369 lines

{$R-,S-,I+,D+,T+,F-,V-,B-,N-,L+ }
Unit Dice;

Interface

Uses Crt,
     Windows,
     popup;     { only required for the replacedment READKEY function }

Procedure PopDice;  { units listed in the INTERFACE are FAR }

Implementation

Type
  String20 = String[20];

Var
  Number  : Integer;
  Adds    : Integer;
  Done    : Boolean;
  OldLine : String20;
  OldNumber: Integer;
  OldSides : Integer;
  OldAdds  : Integer;
  Sides   : Integer;
  OldRoll : Integer;
  WinX    : Integer;
  WinY    : Integer;
  Line    : String20;
  Dee : Boolean;
  Adder : Boolean;

Const
    ESC = #27;
    CR = #13;
    BS = #8;
    F1 = #59;
    F2 = #60;
    F3 = #61;
    F4 = #62;
    F5 = #63;
    F6 = #64;
    F7 = #65;
    F8 = #66;
    F9 = #67;
    F10 = #68;
    Ctrl_End = #117;
    UpAr = #72;
    DnAr = #80;
    LfAr = #75;
    RtAr = #77;

Function IStr(Number : Integer) : String20;

{ converts an integer to a string and returns it }
{ as a function result, which is more convient.  }

Var
  Temp : String20;

Begin
  Str(Number,Temp);
  IStr := Temp;
End;

Procedure BreakUp(Line : String20;Var Number,Sides,Adds : Integer);

{ splits the string containing the dice roll into three numbers:    }
{  number of dice, how many sides, and modifier, i.e. 2d6+1 returns }
{  2 dice of six sides with a modifer of 1.                         }

Var
  Result : Integer;
  TempLine : String20;
  PlusMinus : Integer;
  Index : Integer;

Begin
  Index := Pos('d',Line);
  If Index = 0 Then Index := Succ(Length(Line));
  Val(Copy(Line,1,Pred(Index)),Number,Result);  { get number of sides }
  Delete(Line,1,Index);                         { and remove from string }
  If Line = ''            { if only dice count is given then use old }
    Then Begin            { number of sides and old modifier         }
      Sides := OldSides;
      Adds  := OldAdds;
    End
  Else Begin
    PlusMinus := Pos('+',Line);                        { look for modifier    }
    If PlusMinus = 0 Then PlusMinus := Pos('-',Line);  { it could be negative }
    If PlusMinus = 0
      Then Begin
        TempLine := Line;
        Line := '';
      End
    Else Begin
      TempLine := Copy(Line,1,Pred(PlusMinus));   { get number of sides    }
      Delete(Line,1,Pred(PlusMinus));             { and remove from string }
    End;
    If TempLine = ''
      Then Sides := OldSides
    Else Val(TempLine,Sides,Result);             { sides now as integer }
    If Sides = 0 Then Sides := OldSides;         { use old if zero }
    If Line[1] = '+' Then Delete(Line,1,1);
    Adds := 0;
    If Line <> '' Then
    Begin
      Val(Line,Adds,Result);                     { get modifier }
      If Result <> 0 Then Val(Copy(Line,1,Pred(Result)),Adds,Result);
    End;
  End;
  OldNumber := Number;                   { make old values equal new values }
  OldSides  := Sides;
  OldAdds   := Adds;
End;

Procedure Show(Line : String20);

{ given a string with a dice roll, breaks it up and displays it }

Begin
  GotoXY(2,2);
  ClrEol;
  BreakUp(Line,Number,Sides,Adds);
  Write(Number,'d',Sides);
  If Adds > 0 Then Write('+');
  If Adds <> 0 Then Write(Adds);
  Write(' = ');
End;

Procedure ShowOld;

{ displays the old dice roll }

Begin
  If OldRoll <> 0 Then
  Begin
    Show(OldLine);
    Write(OldRoll);
  End;
End;

Function Roll(Number,Sides,Adds : Integer) : Integer;

{ rolls the dice and adds the modifier }

Var
  Counter : Integer;

Begin
  For Counter := 1 to Number do Adds := Succ(Adds+Random(Sides));
  Roll := Adds;
End;

Procedure MkLine(Var Line : String20;Sides : Integer);

{ fixes the dice roll string in case of any oddities }

Var
 Position : Integer;

Begin
  If Line = ''                            { if no count the use 1d }
    Then Line := Concat('1d',IStr(Sides))
  Else Begin
    Position := Pos('d',Line);
    If Position <> 0
      Then Line := Copy(Line,1,Pred(Position))
    Else Begin
      Position := Pos('+',Line);
      If Position = 0 Then Position := Pos('-',Line);
      If Position <> 0 Then Line := Copy(Line,1,Pred(Position));
    End;
    Line := Line + 'd';
    Line := Concat(Line,IStr(Sides));
  End;
End;

Procedure FunctionKey(Var KeyCode : Char);

{ processes the function keys, F01 - F10 }

Var
  K : Char;

Begin
  K := popup.ReadKey;
  KeyCode := CR;
  Case K of
    F1  : MkLine(Line,100);
    F2  : MkLine(Line,20);
    F3  : MkLine(Line,12);
    F4  : MkLine(Line,4);
    F6  : MkLine(Line,6);
    F8  : MkLine(Line,8);
    F10 : MkLine(Line,10);
    Else KeyCode := #0;
  End;
End;

Procedure NumberKey(Var Line : String20;Var KeyCode : Char);

{ processes a numeric keystroke }

Begin
  If Length(Line) < 13           { 13 digits is the absolute limit }
    Then Line := Line + KeyCode
  Else KeyCode := #0;            { trash the key if string is full }
End;

Procedure AdderKey(Var Line : String20;Var KeyCode : Char);

{ process the + or - key for any dice modifiers }

Var
  Position : Integer;

Begin
  If (Not Adder)
    Then Begin
      If Line = ''              { if blank string the use old number and sides }
        Then Begin
          Str(OldNumber,Line);
          Line := Line + 'd';
          Line := Concat(Line,IStr(OldSides));
          Write(Line);
        End
      Else If Not Dee Then      { if the 'd' character hasn't been pressed }
      Begin
        Line := Line + 'd';
        Dee := True;
        Write('d');
      End;
      If Pos('d',Line) = Length(Line) Then  { if no sides the use old sides }
      Begin
        Line := Concat(Line,IStr(OldSides));
        Write(OldSides);
      End;
      Adder := True;
      Line := Line + KeyCode;
    end
  Else KeyCode := #0;
End;

Procedure DeeKey(Var Line : String20;Var KeyCode : Char);

{ fix the roll string when the 'd' key is pressed }

Begin
  If Not Dee
    Then Begin
      Dee := True;
      If Line = '' Then         { if no dice count then use 1 }
      Begin
        Line := '1';
        Write('1');
      End;
      Line := Line + 'd';
      KeyCode := 'd';
    End
  Else KeyCode := #0;
End;

Procedure BackSpace(Var Line : String20;Var KeyCode : Char);

{ process destructive backspace }

Begin
  If Line <> ''  { do nothing if blank line }
    Then Begin
      If Line[Length(Line)] = 'd' Then Dee := False;  { remove 'd' }
      If Line[Length(Line)] In['-','+'] Then Adder := False;  { remove + or - }
      Delete(Line,Length(Line),1);   { remove last character }
      Write(BS,' ');               { backspace and space - backup again later }
    End
  Else KeyCode := #0;
End;

Procedure CarriageExit(Var Line : String20);

{ Carriage Return processing }

Begin
  If Line = '' Then            { if blank line then use old dice roll }
  Begin
    Str(OldNumber,Line);
    Line := Line + 'd';
    Line := Concat(Line,IStr(OldSides));
    If OldAdds <> 0 Then
    Begin
      If OldAdds > 0 Then Line := Line + '+';
      Line := Concat(Line,IStr(OldAdds));
    End;
  End;
End;

Procedure GetLine(Var Line : String20);

{ accepts a dice roll from the keyboard, will not allow illegal keystrokes }
Var
  KeyCode : Char;

Begin
  Dee := False;
  Adder := False;
  Repeat
    KeyCode := popup.ReadKey;
    Case KeyCode of
      #0       : FunctionKey(KeyCode);
      Esc      : Done := True;             { exit the popup program }
      '0'..'9' : NumberKey(Line,KeyCode);  { digit key }
      #43,
      #45      : AdderKey(Line,KeyCode);   { + or - }
      #32,
      #68,
      #100     : DeeKey(Line,KeyCode);     { 'd', 'D' or space }
      BS       : BackSpace(Line,KeyCode);  { backspace }
      CR       : CarriageExit(Line);       { carriage return }
      Else KeyCode := #0;                  { trash illegal keys }
    End;

    If (KeyCode <> CR) And (KeyCode <> #0) Then Write(KeyCode);
  Until Done or (KeyCode = CR);
End;

Procedure PopDice;

{ saves the underlying screen, displays the menu, and accepts entry }

Begin
  Done := False;
  MakeWindow(31,1,59,6,Black,White,Single);   { save screen and make window }
  WriteLn(' F1   d100     F6   d6');          { display menu }
  WriteLn(' F2   d20      F8   d8');
  WriteLn(' F3   d12      F10  d10');
  Write  (' F4   d4       CR   Repeat');
  Drawbox(WinX,WinY,WinX+24,WinY+3,7,0,Double);  { draw data box }
  ShowOld;                                       { show the previous roll }
  Repeat
    GotoXY(2,1);
    ClrEol;
    Write('Roll: ',Line);
    GetLine(Line);
    If (Not Done) And (Line <> '') Then
    Begin
      Show(Line);
      OldRoll := Roll(Number,Sides,Adds);
      Write(OldRoll);
      If Line <> '' Then OldLine := Line;
      Line := '';
    End;
  Until Done;
  RemoveWindow;                         { restore original screen }
End;

Begin   { initialization code }
  DirectVideo := False;             { lets be safe          }
  OldLine  := '';                   { set up default values }
  OldNumber := 1;
  OldSides := 20;
  OldAdds  := 0;
  Sides    := 100;
  OldRoll  := 0;
  WinX     := 1;
  WinY     := 1;
  Line     := '';
  Randomize;
End.