program Marriage_Tournament;
{Morven's Marriage tournament, designed to produce a constellation of
    "stable marriages".
A constellation of marriages is "unstable" if there exist 2
    people, both of whom prefer each other to their current partners.
MODIFIED RULES (which may lead to unstable marriages):
    Not necessarily the same  number of males and females
    There is a time of courtship
    Females have a "time to old maid panic", when they settle
            for the current fiance.}
{Adapted from W. Kreutzer's SIMULA model, for OOP Turbo Pascal
and toolboxes,   By Lin Jensen, Bishop's University, November, 1996}

USES simobj, mcobj, statobj, qnetobj, clock, queue, coproc, proc_man,
     MESSAGE, usebios;
const
     Meanlengthofcourtship = 5.0;
     Sigmalengthofcourtship= 2.0;

TYPE
{-------------------------------------------------------------------------}
{ This program uses arrays allocated at run time }
{-------------------------------------------------------------------------}
   FlexArray = Array[1..2] of integer;      {upper limit only important for
                        range checking. Do you ever enable range checking?}
   Aptr = ^FlexArray;
{-------------------------------------------------------------------------}
{ OBJECT CLASS DECLARATIONS }

    PersonP = ^person;
    Person = object (procdescr)
        Preferences    : Aptr;       {[1..noOfCandidates]}
                      {holds indices of candidates, most favoured first}
        CurrentFiancee : personP;
        stillUndecided : boolean;
        Engaged        : Boolean;
        constructor Init (noOfCandidates:integer; indexP:integer);
        procedure report; virtual;
    end;

    MaleP = ^male;
    FemaleP = ^female;

    Male = object (person)
        CurrentProposee:FemaleP;
        procedure LifeCycle; virtual;
        constructor Init (noOfCandidates:integer; indexP:integer);
     private
        procedure ProposeToNextBestFemale (nextbestChoice:FemaleP);
    end;

    Female = object (person)
        qOfSuitors         : PortDescr;    {wait for messages of proposal}
        CurrentProposer    : maleP;
        TimeToOldMaidPanic : real;
        procedure LifeCycle; virtual;
        constructor Init (noOfCandidates:integer; indexP:integer);
     private
        procedure TentativelyAcceptOrRejectProposal;
        procedure PanicNow;
    end;

   Flexmale = Array[1..2] of MaleP;  {arrays holding pointers to persons}
   MaleAptr = ^FlexMale;

   FlexFemale = Array[1..2] of FeMaleP;
   FeMaleAptr = ^FlexFeMale;

{====================================================================}
VAR                         {GLOBAL}
   NoOfFemales,
   NoOfMales      : Integer;
   LengthOfSim    : Real;
   TableOfFemales : FemaleAptr;   {init to [1..noOfFemales]}
   TableOfMales   : MaleAPtr;
   Panic          : RandomUniform;
   Courtship      : RandomNormal;
   data : text;
{====================================================================}
{method implementations}

constructor Person.Init (noOfCandidates:integer; indexP:integer);
var
    nameP  : string;
    partner: integer;
begin
    Readln (data, NameP);
    procdescr.init (NameP,indexP);
{        Preferences    : Aptr;  }     {[1..noOfCandidates]}
                      {holds indices of candidates, most favoured first}
    GetMem (preferences, noOfCandidates*sizeof(integer));
    for partner := 1 to noOfCandidates do
       read (data, preferences^[partner]);
    Readln (data);
        CurrentFiancee := NIL;
        stillUndecided := true;
        Engaged        := false;
end;  {person.init}

constructor Female.Init (noOfCandidates:integer; indexP:integer);
begin
   person.init (noOfCandidates, indexP);
        qOfSuitors.Init;    {Port: wait for messages of proposal}
        qOfSuitors.SpecificLabel (Name);
        CurrentProposer    := NIL;
        TimeToOldMaidPanic := Panic.Uniform;
end;

constructor male.Init (noOfCandidates:integer; indexP:integer);
begin
   person.init (noOfCandidates, indexP);
        CurrentProposee:= NIL;
end;

procedure person.report;
begin
    procdescr.report;
    if StillUndecided then
       write ('                     is currently engaged to ')
    else
       write ('                        agrees to marry ');
    if CurrentFiancee = Nil then
       writeln (' nobody (sigh)!')
    else
       writeln (currentFiancee^.name);
end;

procedure ExchangeRings (bride: FemaleP; groom : MaleP);
begin
   writeln (bride^.name, ' accepts the proposal of ',groom^.name,' at ',
             TheClock.Telltime:7:2);
   bride^. CurrentFiancee := groom;
   bride^. Engaged        := TRUE;
   groom^. CurrentFiancee := bride;
   groom^. Engaged        := TRUE;
end; {exchangerings}

procedure male.lifecycle;
var
   partner : integer;
begin
   {sleep_for (StartGun.NegExp); }   {Time to get started - randomize males}
   for partner := 1 to NoOfFemales do
       ProposeToNextBestFemale (TableOfFemales^[preferences^[partner]]);
   writeln;
   writeln (' :( :( :( ', name, ' has no luck, leaves for Golden Lion Pub');
   write   ('               to drown sorrows at ');
               theClock.rite; writeln;
   writeln;
end;

procedure Male.ProposeToNextBestFemale (nextBestChoice : FemaleP);
var
    lovenote: noteptr;
begin
  IF nextBestChoice^.StillUndecided then
   begin
    New (lovenote, init);
    WRITE (NAME:25, ' IS WOOING ',NEXTBESTCHOICE^.NAME, ' at');
               theClock.rite; writeln;
    nextBestChoice^.qOfSuitors.SEND (lovenote);
    suspend;                        {wait for reply}
    CurrentProposee := nextBestChoice;
    SLEEP_FOR (Courtship.Normal);    {time of courtship}
       {she could have paniced while I was dithering}
    If StillUndecided and CurrentProposee^.StillUndecided then
      begin
        Write (Name, ' proposes to ', Currentproposee^.name, ' at ');
               theClock.rite; writeln;
        CurrentProposee^.Currentproposer := Addr(self);
        resume (currentProposee);
        suspend;                        {wait for rejection}
      end;              {else, she paniced, go on to next on list}
   end;  {if still undecided}
end; {propose to...}

procedure Female.lifecycle;
var
   newOffer       : noteptr;
begin
   newOffer := qOfSuitors.RECEIVE;      {wait for first offer}
  { SLEEP_FOR (0.1); }                    {open the envelope -- IMPORTANT
                                         guarantee time for him to suspend!}
   resume (newoffer^.sender);           {smile at him}
   suspend;                             {allow time for courtship}
   ExchangeRings (addr(self){this female}, CurrentProposer);
   WHILE Theclock.telltime < timetoOldMaidPanic DO   {not totally what we want}
       TentativelyAcceptOrRejectProposal;
   {Panic, settle on currentFiancee}
   PanicNow;
   suspend;                         {do nothing more, stay around for report}
end;

procedure Female.TentativelyAcceptOrRejectProposal;
var
   newOffer       : noteptr;
   YesterdaysHero : MaleP;
  begin
     newOffer := qOfSuitors.RECEIVE;      {wait for another offer}
     SLEEP_FOR (0.1);                     {open the envelope -- IMPORTANT
                                         guarantee time for him to suspend!}
     RESUME (newoffer^.sender);
     suspend;                             {allow time for courtship}
     if Theclock.telltime >=TimeToOldMaidpanic then
        PanicNow                       {don't even pay attention to newoffer}

     else
     {--- NOW make a decision ----}
     if preferences^[CurrentProposer^.index] <
        preferences^[CurrentFiancee^.index] then
         begin
           {This guy is better than the old one}
           {Break engagement}
           YesterdaysHero := maleP(CurrentFiancee);
           write (name, ' breaks her engagement to ',
                  yesterdaysHero^.name,' at'); TheClock.rite; writeln;
           Engaged := false;
           YesterdaysHero^.engaged := false;
           YesterdaysHero^.CurrentFiancee := NIL;
           resume (YesterdaysHero);        {send him hunting again}
           ExchangeRings (addr(self){this female}, CurrentProposer);
         end
     else
         begin      {blissfully happy, send new one away}
           RESUME (CurrentProposer);
           write (Name, ' rejects ',CurrentProposer^.name, ' at ');
           TheClock.rite; writeln;
         end;
  end;  {tentatively}

procedure Female.PanicNow;
begin
   StillUndecided := false;
   CurrentFiancee^.StillUndecided := false;
   writeln;
   write ('****  ',name ,' panics and settles on ',currentFiancee^.name,' at');
   theClock.rite; writeln;
   writeln;
end;

{====================================================================}
procedure ReadAndInitialize;
var
   PersonIndex    : integer;      {for initialization step}
   hilda          : FemaleP;
   stan           : MaleP;
   courtseed, panicseed : integer;

begin        {Read and Initialize}
   assign (data, 'cupid.dat');
   reset  (data);               {open input file}
                                {read parameters of tournament}
   readln (data, noOfFemales);
   readln (data, noOfMales);
   readln (data, courtseed, panicseed);  {random number seeds}
   readln (data, lengthOfSim);           {how long is tournament}
   Panic.init (panicSeed, 30, 120);     {initialize random no. gens}
   Courtship.init (courtSeed, MeanLengthofCourtship, SigmaLengthofCourtship);

{IMPORTANT! Instantiate Tables with length read in----}
   GetMem (TableOfFemales, sizeof(FemaleP)*noOfFemales);
   GetMem (TableOfmales, sizeof(maleP)*noOfmales);

   {instantiate persons, this reads their names and preferences from data}
   for personindex := 1 to noOfFemales do
     begin
       new (hilda, init (NoOfMales, personindex));
       TableOfFemales^[personIndex] := hilda;
       resume (hilda);
     end;
   for personindex := 1 to noOfMales do
     begin
       new (stan, init (NoOfFeMales, personindex));
       TableOfmales^[personIndex] := stan;
       resume (stan);
     end;
   close(data);
end; {read and initialize}

begin        {main program}
    ReadAndInitialize;
{    Monitor.report; }
{    monitor.trace;  }
    Monitor.RunSimulation (LengthOfSim, 100);
    Reporter.ReportAll;                      
end.