{A simulation program to illustrate the birthday problem from the
field of statistics.
          Written by Merlin L. Hanson, September 1988.}
PROGRAM Birthday;
(* resource set indicies for BIRTHDAY *)  {copied from K-Resource}
CONST
        dialbox  = 0;   (* form/dialog *)
        ok       = 7;   (* BUTTON in tree DIALBOX *)
        speedbox = 1;   (* form/dialog *)
        slowbtn  = 2;   (* BUTTON in tree SPEEDBOX *)
        medumbtn = 3;   (* BUTTON in tree SPEEDBOX *)
        fastbtn  = 4;   (* BUTTON in tree SPEEDBOX *)
        exitbox  = 2;   (* form/dialog *)
        stoplft  = 2;   (* BUTTON in tree EXITBOX *)
        stoprght = 3;   (* BUTTON in tree EXITBOX *)
  {$I GEMCONST.PAS}
TYPE
  {$I GEMTYPE.PAS}
  T1to12  = 1..12;
  T28to31 = 28..31;
  T1to31  = 1..31;
  TColor  = (Gray,MyBlack);
  TPtr    = ^T3;
  T3      = ARRAY[1..16000] OF integer;
VAR
  ch             : char;
  MeanNbrSamples : real;
  NumberRuns     : integer;
  Rez            : (MediumRez,High);
  ResolutionChanged : boolean;
  StopMode          :(StopOnDuplicate,StopOnKeypress);
{$I GEMSUBS.PAS}
{$I CURSOR.PAS}

PROCEDURE SetScreen(Adr1,Adr2:long_integer;
             NewReolutionCode:integer);
  XBIOS(5);

PROCEDURE GetMonitorResolution;
  {If the monitor is in low resolution, change it to medium and remember
  that it was changed so it can be restored prior to program exit.
  Also, set up a variable to show what the resolution is,
  it will be needed for scaling graphics.}
  VAR
    RezCode        : 0..2;

  FUNCTION GetRez:integer;
    XBIOS(4);

  BEGIN {getmonitorresolution}
    ResolutionChanged := FALSE;
    RezCode := GetRez;
    CASE RezCode OF
      0 : BEGIN {low rez}
            SetScreen(-1,-1,1 {medium});
            ResolutionChanged := TRUE;
            Rez := MediumRez;
          END;
      1 : Rez := MediumRez;
      2 : Rez := High;
    END {case};
  END {getmonitorresolution};

PROCEDURE ScreenBuffer;
  VAR
    P_Template : TPtr;

  PROCEDURE ScreenRAM;
    VAR
      P_Screen : TPtr;

    PROCEDURE DoIt;
      VAR
        i : integer; 
        Month : integer;
        Date  : integer;
        X_Day : ARRAY[1..366]OF 0..640;
        Y_Day : ARRAY[1..366]OF 0..400;
        DayUsed : ARRAY[1..366]OF boolean;
        Speed   : (Slow,Medium,Fast);
        FirstSimulation : boolean;
    
      PROCEDURE ProcessDialogBoxes;
        VAR
          MyBox     : dialog_ptr;
          junk      : integer;
          SpeedCode : integer;
          ExitCode  : integer;

        PROCEDURE PrintTitle;

            TYPE
              CtrlParms   = ARRAY[0..11]OF integer;
              IntInParms  = ARRAY[0..15]OF integer;
              IntOutParms = ARRAY[0..45]OF integer;
              PtsInParms  = ARRAY[0..11]OF integer;
              PtsOutParms = ARRAY[0..11]OF integer;
            VAR
              Control : ctrlparms;
              IntIn   : intinparms;
              IntOut  : intoutparms;
              PtsIn   : ptsinparms;
              PtsOut  : ptsoutparms;
              y       : integer;

            PROCEDURE VDI_Call(Cmd,SubCmd : integer;
                            NbrInt,NbrPts : integer;
                                 VAR Ctrl : ctrlparms;
                                VAR IntIn : intinparms;
                               VAR IntOut : intoutparms;
                                VAR PtsIn : ptsinparms;
                               VAR PtsOut : ptsoutparms;
                                Translate : boolean);
              EXTERNAL;

          PROCEDURE TextHeight(Height : integer);
            BEGIN {textheight}
              PtsIn[0] := 0;
              PtsIn[1] := Height;
              VDI_Call(12,0,0,2,Control,IntIn,IntOut,PtsIn,PtsOut,FALSE);
            END {textheight};

          PROCEDURE TextEffects(Code:integer);
            {Set graphics text for special effects,
            such as italic, bold,..  .}
            BEGIN {texteffects};
              IntIn[0] := (Code);
              VDI_Call(106,0,1,0,Control,IntIn,IntOut,PtsIn,PtsOut,FALSE);
            END {texteffects};

          BEGIN {printtitle}
            TextHeight(30);
            TextEffects(16 {outlined});
            IF Rez = MediumRez
              THEN y := 35
              ELSE y := 70;
            Draw_String(160,y, 'BIRTHDAY SIMULATOR');
            TextEffects(0 {back to normal});
            {Set height back to normal.}
            IF Rez = MediumRez
              THEN TextHeight(6)
              ELSE TextHeight(13);
          END {printtitle};

        BEGIN {processdialogboxes}
          Hide_Mouse;
          ClrScr;
          PrintTitle;
          Find_Dialog(DialBox,MyBox);
          Center_Dialog(MyBox);
          Show_Mouse;
          Junk := Do_Dialog(MyBox,0);
          ClrScr;
          Find_Dialog(SpeedBox,MyBox);
          Center_Dialog(MyBox);
          SpeedCode := Do_Dialog(MyBox,0);
          CASE SpeedCode OF
            SlowBtn  : Speed := Slow;
            MedumBtn : Speed := Medium;
            FastBtn  : Speed := Fast;
          END {case};
          ClrScr;
          Find_Dialog(ExitBox,MyBox);
          Center_Dialog(MyBox);
          ExitCode := Do_Dialog(MyBox,0);
          CASE ExitCode OF
            StopLft  : StopMode := StopOnDuplicate;
            StopRght : StopMode := StopOnKeypress;
          END {case};
          Hide_Mouse;
          ClrScr;
        END {processdialogboxes};
    
      PROCEDURE DoOneSimulation;
        VAR
          Day : integer;

        FUNCTION DaysThisMonth(Month:T1to12; LeapYear:boolean) : integer;
          {Given a month, 1..12, and the truth value of leap year; return the
          number of days in the specified month.}
          VAR
            i    : integer;
            S    : string;
            Days : 28..31;
          BEGIN
            S := '  31 28 31 30 31 30 31 31 30 31 30 31';
            i := Month * 3;
            Days := (ORD(s[i])-48)*10 + ORD(s[i+1])-48;
            IF LeapYear AND (Month = 2)
              THEN DaysThisMonth := Days+1
              ELSE DaysThisMonth := Days;
          END {daysthosmonth};
    
        FUNCTION DayNumber:integer;
          {Return a random number in the interval 1..366.
          The frequency of day 60 (treated as leap day in ALL years)
          Will have a frequency of 1/4 the frequency of the other numbers.}
          VAR
            x : integer;
      
          FUNCTION RandomNumber:integer;
            {Make a drawing from a random number generator and return a number
            in the range 1..1462. (1462=365*4 + 1)}
            VAR
              N : long_integer;
              M : integer;
      
            FUNCTION Rndm:long_integer;
              {Returns a 24-bit psuedo-random number.}
              XBIOS(17);
      
            BEGIN {randomnumber}
              N := Rndm;
              {Reduce N to a number in the range 0..2047 by extracting 11
              bits from the middle of the 24-bit number.}
              M := INT(SHR(N,6) & $07FF);
              IF (M > 0) AND (M < 1462)
                THEN RandomNumber := M
                     {note recursion}
                ELSE RandomNumber := RandomNumber;
            END {randomnumber};
      
          BEGIN {daynumber}
            x := RandomNumber;
            IF x = 1461
              THEN x := 366 {leap day, for now}
              ELSE x := x MOD 365 {0 <= x < 365} + 1;
            {The calendar always has a leap day included, day 60.
            The random drawing routines yield 366 as the leap day.
            The essential property is the ratio of leap day to the
            other days. Since this is a random number, interchange
            leap day and day 366 (December 31).}
            IF x = 366
              THEN
                x := 60
              ELSE
                IF x = 60
                  THEN
                    x := 366;
            DayNumber := x;
          END {daynumber};
      
        PROCEDURE ConvertDay(DayNbr : integer;
                          VAR Month : T1to12;
                           VAR Date : T1to31);
          {Convert a number in the range 1..366 so that the month and date
          within the month are resolved.}
          VAR
            Mo : integer;
            Find : boolean;
            {Offset contains the day number of the first of the month.}
            Offset : ARRAY[1..12]OF integer;
      
          BEGIN {convertday}
            IF DayNbr = 366
              THEN
                BEGIN
                  Month := 2;
                  Date  := 29;
                END
              ELSE
                BEGIN {ordinary day}
                  Offset[1] := 0;
                  FOR Mo := 2 TO 12 DO
                    Offset[Mo] := Offset[Mo-1]+DaysThisMonth(Mo-1,FALSE);
                  Month := 12;
                  Find := FALSE;
                  REPEAT
                    IF DayNbr > Offset[Month]
                      THEN Find := TRUE
                      ELSE Month := Month-1;
                  UNTIL Find;
                  Date := DayNbr-Offset[Month];
                END {ordinary day};
          END {convertday};
      
        PROCEDURE MyLine(x,y,w,h:integer);
          BEGIN
            IF Rez = High
              THEN Line(x,y,w,h)
              ELSE Line(x,y DIV 2,w,h DIV 2);
          END {myline};
      
        PROCEDURE MyLine_To(x,y:integer);
          BEGIN
            IF Rez = High
              THEN Line_To(x,y)
              ELSE Line_To(x,y DIV 2);
          END {mylineto};
      
        PROCEDURE MyDrawString(x,y:integer; S:str255);
          BEGIN
            IF Rez = High
              THEN Draw_String(x,y,S)
              ELSE Draw_String(x,y DIV 2,S);
          END {mydrawstring};
      
        PROCEDURE DrawCalendar;
          {Draw a calendar representing a full year.}
          VAR y, Month, DayNumber : integer;
      
          PROCEDURE DrawMonth(Month,Y_Position:integer);
            {Draw a series of boxes representing the days of the month.}
            VAR Day, x : integer;
      
            PROCEDURE DrawNameOfMonth(y,Month:integer);
              {Print a 3-letter abbreviation at the left of the screen to
              identify the month.}
              VAR
                S,S2          : str255;
                i,FirstLetter : integer;
              BEGIN
                S := 'JanFebMarAprMayJunJulAugSepOctNovDec';
                S2 := '';
                FirstLetter  := ((Month-1)*3)+1;
                FOR i := FirstLetter TO FirstLetter+2 DO
                  S2 := CONCAT(S2,S[i]);
                MyDrawString(8,y+10,S2);
              END {drawnameofmonth};
      
            PROCEDURE DrawDay(x,y:integer);
              {Draw a box representing a day. It's upper left corner is
              specified by x and y.  In addition, define its x, y position in
              arrays X_Day and Y_Day so that the box can be modified later.}
              CONST
                w = 10;
                h = 10;
              VAR
                x1,y1 : integer;
              BEGIN {drawday}
                x1 := x+w;
                y1 := y+h;
                MyLine   (x,y,x1,y);  {top}
                MyLine_To(x1,y1);     {right side}
                MyLine_To(x, y1);     {bottom}
                MyLine_To(x, y );     {left side}
                X_Day[DayNumber] := x;
                Y_Day[DayNumber] := y;
                DayNumber := DayNumber+1;
              END {drawday};
      
            BEGIN {drawmonth}
              DrawNameOfMonth(y,Month);
              X := 40;
              FOR Day := 1 TO DaysThisMonth(Month,TRUE) DO
                BEGIN
                  DrawDay(x,y);
                  x := x + 18;
                END;
            END {drawmonth};
      
          BEGIN {drawcalendar}
            DayNumber := 1;
            Y := 20;
            FOR Month := 1 TO 12 DO
              BEGIN
                DrawMonth(Month,Y);
                Y := Y + 26
              END;
          END {drawcalendar};
    
        FUNCTION PhysicalBase:TPtr;
          XBIOS (2);
    
        PROCEDURE SimulateBirthdays;
          VAR
            Duplicate : boolean;
            Total     : real;
            MaxCount  : long_integer;
            Draws     : long_integer;

          PROCEDURE ProcessDay;
            {Draw a day, fill in the calendar with the appropriate legend,
            remember that the day was drawn, and count the draw.}
            VAR
              SampleDay : integer;

            PROCEDURE DarkenDay(DayToDarken:integer;Color:TColor);
              VAR x,y,LineNumber : integer;
              BEGIN
                x := X_Day[DayToDarken];
                y := Y_Day[DayToDarken];
                IF Color = MyBlack
                  THEN
                    BEGIN
                      {The 'gray' boxes will be solid black on a color monitor.
                      The duplicate box will be solid red, assuming the user
                      hasn't changed the color for pen 2.}
                      IF Rez = MediumRez
                        THEN Line_Color(Red);
                      FOR LineNumber := y TO y+10 DO
                        MyLine(x,LineNumber,x+10,LineNumber);
                      {Change back to the black pen for the next box.}
                      IF Rez = MediumRez
                        THEN Line_Color(Black);
                    END
                  ELSE {gray}
                    LineNumber := y;
                    REPEAT
                      MyLine(x,LineNumber,x+10,LineNumber);
                      LineNumber := LineNumber+2;
                    UNTIL LineNumber > y+10;
              END {darkenday};
      
            BEGIN {processday}
              {DayNumber is a drawing from 1..366}
              SampleDay := DayNumber;
              IF DayUsed[SampleDay]
                THEN
                  BEGIN
                    DarkenDay(SampleDay,MyBlack);
                    IF StopMode = StopOnDuplicate
                      THEN Duplicate := TRUE;
                  END
                ELSE
                  BEGIN
                    DarkenDay(SampleDay,Gray);
                    DayUsed[SampleDay] := TRUE;
                  END;
              Draws := Draws+1;
            END {processday};
      
          PROCEDURE Wait;
            {Add a time delay between draws to create a little suspense.}
            VAR Ctr : long_integer;
            BEGIN
              Ctr := 0;
              REPEAT
                Ctr := Ctr+1;
              UNTIL Ctr > MaxCount;
            END {wait};
      
          BEGIN {simulatebirthdays}
            CASE Speed OF
              Slow   : MaxCount := 80000;
              Medium : MaxCount := 40000;
              Fast   : MaxCount := 0;
            END {case};
            Draws := 0;
            Duplicate := FALSE;
            REPEAT
              ProcessDay;
              Wait;
            UNTIL Duplicate OR (KeyPress AND (StopMode = StopOnKeypress));
            IF KeyPress
              THEN Read(ch); {The character that caused the stop, not the 'q'.}
            GoToXY(24,18);
            WriteLn('Press ''q'' to quit, any other key to continue');
            GoToXY(25,5);
            IF StopMode = StopOnKeypress
              THEN
                Write(' ':20,'There were ',Draws, ' dates drawn.')
              ELSE
                BEGIN
                  Total := MeanNbrSamples*NumberRuns + Draws;
                  NumberRuns := NumberRuns+1;
                  MeanNbrSamples := Total/NumberRuns;
                  Write('There were ',Draws,
                        ' dates drawn.  The aggregate average is ',
                         MeanNbrSamples:5:1,' samples.');
                END;
          END {simulatebirthdays};
    
        {$P-}   {Screen RAM will be out my addressing range.}
        BEGIN {doonesimulation}
          IF FirstSimulation
            THEN
              BEGIN
                {Make a blank calendar and save a copy of it.  It takes about
                3 seconds to draw a calendar on the screen;  but only a
                fraction of a second to copy from a buffer to the screen
                once the original drawing has been done.}
                FOR Day := 1 TO 366 DO
                  BEGIN
                    ConvertDay(Day,Month,Date);
                    {WriteLn(Month:2,Date:4);}
                    DayUsed[Day] := FALSE;
                  END;
                DrawCalendar;
                P_Screen := PhysicalBase;
                {Copy calendar template to my buffer.  Note that this simple
                statement copies the entire array!}
                P_Template^ := P_Screen^;
                FirstSimulation := FALSE;
              END
            ELSE
              BEGIN
                ClrScr;
                {Copy my buffer to the screen RAM.}
                P_Screen^ := P_Template^;
                FOR Day := 1 TO 366 DO
                  DayUsed[Day] := FALSE;
              END;
          SimulateBirthdays;
        END {doonesimulation};
        {$P+}
    
      BEGIN {doit}
        Set_Clip(0,0,640,400);
        Init_Mouse;
        ProcessDialogBoxes;  {Hides the mouse.}
        NumberRuns := 0;
        FirstSimulation := TRUE;
        REPEAT
          DoOneSimulation;
          Read(ch);
          ClrScr;
        UNTIL (ch = 'q') OR (ch = 'Q');
        Show_Mouse;
      END {doit};

    BEGIN {screenram}
      DoIt;
    END {screenram};

  BEGIN {screenbuffer}
    {Procedure ScreenBuffer and ScreenRAM are to get around the 32K
    bytes per block restriction of Level 1.x Personal Pascal.}
    NEW(P_Template);
    ScreenRAM;
  END {screenbuffer};

BEGIN {main}
  ClrScr;
  IF Init_GEM >= 0 THEN
    BEGIN
        IF Load_Resource('BIRTHDAY.RSC')
          THEN
            BEGIN
              GetMonitorResolution;
              ScreenBuffer;
              IF ResolutionChanged
                THEN SetScreen(-1,-1,0 {back to low});
            END
        ELSE
          BEGIN
            WriteLn('Can''t find .RSC file');
            Read(ch);
            HALT;
          END;
      Exit_GEM;
    END;
END {program}.
             (* Table of contents for the program*)
    4 PROGRAM Birthday;
   16  |{$I GEMCONST.PAS}
   18  |{$I GEMTYPE.PAS}
   32 {$I GEMSUBS.PAS}
   33 {$I CURSOR.PAS}
   35 PROCEDURE SetScreen(Adr1,Adr2:long_integer;
   39 PROCEDURE GetMonitorResolution;
   47  |FUNCTION GetRez:integer;
   50  |BEGIN {getmonitorresolution}
   64 PROCEDURE ScreenBuffer;
   68  |PROCEDURE ScreenRAM;
   72  | |PROCEDURE DoIt;
   83  | | |PROCEDURE ProcessDialogBoxes;
   90  | | | |PROCEDURE PrintTitle;
  106  | | | | | |PROCEDURE VDI_Call(Cmd,SubCmd : integer;
  116  | | | | |PROCEDURE TextHeight(Height : integer);
  117  | | | | | |BEGIN {textheight}
  123  | | | | |PROCEDURE TextEffects(Code:integer);
  126  | | | | | |BEGIN {texteffects};
  131  | | | | |BEGIN {printtitle}
  145  | | | |BEGIN {processdialogboxes}
  174  | | |PROCEDURE DoOneSimulation;
  178  | | | |FUNCTION DaysThisMonth(Month:T1to12; LeapYear:boolean) : integer;
  194  | | | |FUNCTION DayNumber:integer;
  201  | | | | |FUNCTION RandomNumber:integer;
  208  | | | | | |FUNCTION Rndm:long_integer;
  212  | | | | | |BEGIN {randomnumber}
  223  | | | | |BEGIN {daynumber}
  243  | | | |PROCEDURE ConvertDay(DayNbr : integer;
  254  | | | | |BEGIN {convertday}
  262  | | | | | | | |BEGIN {ordinary day}
  277  | | | |PROCEDURE MyLine(x,y,w,h:integer);
  284  | | | |PROCEDURE MyLine_To(x,y:integer);
  291  | | | |PROCEDURE MyDrawString(x,y:integer; S:str255);
  298  | | | |PROCEDURE DrawCalendar;
  302  | | | | |PROCEDURE DrawMonth(Month,Y_Position:integer);
  306  | | | | | |PROCEDURE DrawNameOfMonth(y,Month:integer);
  321  | | | | | |PROCEDURE DrawDay(x,y:integer);
  330  | | | | | | |BEGIN {drawday}
  342  | | | | | |BEGIN {drawmonth}
  352  | | | | |BEGIN {drawcalendar}
  362  | | | |FUNCTION PhysicalBase:TPtr;
  365  | | | |PROCEDURE SimulateBirthdays;
  372  | | | | |PROCEDURE ProcessDay;
  378  | | | | | |PROCEDURE DarkenDay(DayToDarken:integer;Color:TColor);
  405  | | | | | |BEGIN {processday}
  423  | | | | |PROCEDURE Wait;
  433  | | | | |BEGIN {simulatebirthdays}
  465  | | | |BEGIN {doonesimulation}
  498  | | |BEGIN {doit}
  501  | | | |ProcessDialogBoxes;  {Hides the mouse.}
  512  | |BEGIN {screenram}
  516  |BEGIN {screenbuffer}
  523 BEGIN {main}
                                    *)