stv_background/stvpas.pas

PROGRAM stvpas(input, output);

{Taken from Algorithm 123 -- Single Transferable Vote by Meek's Method
            I. D. Hill, B. A. Wichmann and D. R. Woodall
            The Computer Journal (UK), Vol 30, No 3, 1987, pp 277-81
   c.f. meekm.pdf}

   {Note Authors' election of method from Paragraph 1 of Section 3.3, where;
           "If [the voter] [provides an incomplete list of candidates] and 
            the use of their vote 'runs off the end' we allow it to do so, 
            but adjust the Quota to allow for the fact that there are now 
            fewer remaining usable votes."
       The authors go on to note that this is in dispute with the Electoral
       Reform Society's interpretation at the time of publication.}

   {Note the election of Applied Statistics algorithm AS 183[3] which ensures 
       any randomness required to break a tie, having been seeded with data 
       from the election itself, consistently provides reproducable results.}

   {wrowe 2005 May 28 added one billionth to the resulting quota,
       further decreasing the unlikely possibility of a tie, 
       per the rules of implementation adopted by New Zealand}

   {wrowe 28 May 2005 added command line .blt filename argument}

   {Must add the rule from Paragraph 2 of Section 4 which states;
           "There is at least one ballot paper that contains the name
            of a 'hopeful' candidate in its list of preferences."
       As published in 1987, the program did not check this.  The absense
       of this test is noted in the 1999 Appendix to the LEX document.}

{This program counts the votes in a Single Transferable Vote election,
    using Meek's method, and reports the results}

{If there are more than 40 candidates an increase in the size of
    MaxCandidates is the only change needed}

CONST MaxCandidates = 40;
      NameLength = 20;

TYPE Candidates = 1 .. MaxCandidates;
     CandRange = 0 .. MaxCandidates;
     name = PACKED ARRAY [1 .. NameLength] OF char;

VAR  NumCandidates, NumSeats: Candidates;
     candidate, NumElected, NumExcluded,
     multiplier, ignored: CandRange;
     Droop, excess, quota, total: real;
     faulty, SomeoneElected, RandomUsed: Boolean;
     FracDigits: 1 .. 4;
     table, seed1, seed2, seed3: integer;
     datafile: text;
     title: name;
     votes, weight: ARRAY [Candidates] OF real;
     status: ARRAY [Candidates] OF (Hopeful, Elected, NewlyElected,
                   Almost, Excluded, ToBeExcluded, NotUsed, Used);
     names: ARRAY [Candidates] OF name;

FUNCTION InInteger: integer;

{Reads the next integer from datafile and returns its value}

   VAR i: integer;
   BEGIN
   read(datafile, i);
   InInteger := i
   END; {InInteger}

PROCEDURE PrintOut;

{Updates the table number and prints out the current results}

   VAR arg: real;
      cand: Candidates;
   BEGIN
   table := table + 1;
   writeln;
   writeln(' ': 20, title);
   writeln;
   write('Table: ', table: 1);
   writeln(' Quota: ', quota: 1: FracDigits);
   writeln;

   {The numbers of blanks following Candidate, Retain and
       Transfer are 12, 3 and 3 respectively}

   writeln('Candidate Retain Transfer Votes');
   writeln;
   FOR cand := 1 TO NumCandidates DO
      BEGIN
      write(names[cand]);
      IF status[cand] = ToBeExcluded THEN
         arg := 100.0 ELSE arg := 100.0 * weight[cand];
      write(arg: 6: 1, '%');
      write(100.0 - arg: 8: 1, '%');

      {If it is valid to do so, print quota instead of votes[cand]
         because the latter might have a small rounding error that
         would confuse unsophisticated users}

      IF status[cand] = Elected THEN arg := votes[cand] / quota
         ELSE arg := 0.0;
      IF (arg >= 0.99999) AND (arg <= 1.00001) THEN arg := quota
         ELSE arg := votes[cand];
      write(arg: 10: FracDigits, ' ');
      IF status[cand] = Excluded THEN write('Excluded')
      ELSE IF status[cand] = Elected THEN write('Elected')
      ELSE IF status[cand] = NewlyElected THEN write('Newly Elected')
      ELSE IF status[cand] = ToBeExcluded THEN
         BEGIN
         write('To be Excluded');
         status[cand] := Excluded
         END;
      writeln;
      IF (NumCandidates > 9) AND (cand MOD 5 = 0) AND
         (cand <> NumCandidates) THEN writeln
      END;

   writeln;
   writeln('Excess', excess: 40: FracDigits);
   writeln;
   writeln('Total ', total: 40: FracDigits);
   writeln;
   writeln
   END; {PrintOut}

PROCEDURE elect(cand: Candidates);
   BEGIN
   status[cand] := NewlyElected;
   NumElected := NumElected + 1
   END; {elect}

PROCEDURE exclude(cand: Candidates);
   BEGIN
   status[cand] := ToBeExcluded;
   weight[cand] := 0.0;
   NumExcluded := NumExcluded + 1;
   IF RandomUsed THEN
      BEGIN
      writeln;
      writeln;
      writeln('Random choice used to exclude ', names[cand])
      END
   END; {exclude}

FUNCTION LowestCandidate: CandRange;
   {Returns the candidate number of the candidate who currently has the
      lowest number of votes. If two or more are equal lowest, then a
      pseudo-random choice is made between them}

      VAR cand: Candidates;
          LowCand: CandRange;

FUNCTION random: real;

{Returns a pseudo-random number rectangularly distributed
   between 0 and 1. Based on Wichmann and Hill, Algorithm
   AS 183, Appl. Statist. (1982) 31, 188 - 190}

VAR rndm: real;
   BEGIN

   { If seeds have not been set, then set them}

   IF seed1 = 0 THEN
      BEGIN
      seed1 := NumCandidates;
      seed2 := NumSeats + 10000;
      rndm := total + 20000.0;
      WHILE rndm > 30322.5 DO rndm := rndm - 30322.0;
      seed3 := round(rndm)
      END;

   seed1 := 171 * (seed1 MOD 177) - 2 * (seed1 DIV 177);
   seed2 := 172 * (seed2 MOD 176) - 35 * (seed2 DIV 176);
   seed3 := 170 * (seed3 MOD 178) - 63 * (seed3 DIV 178);
   IF seed1 < 0 THEN seed1 := seed1 + 30269;
   IF seed2 < 0 THEN seed2 := seed2 + 30307;
   IF seed3 < 0 THEN seed3 := seed3 + 30323;
   rndm := seed1 / 30269.0 + seed2 / 30307.0 + seed3 / 30323.0;
   random := rndm - trunc(rndm)
   END; {random}

FUNCTION lower(cand, lowest: CandRange): Boolean;

{Find whether cand has fewer votes than lowest, and also
   reports whether a random choice had to be made}

   VAR lowly: Boolean;
   BEGIN
   IF lowest = 0 THEN
      BEGIN
      RandomUsed := false;
      lower := true
      END
   ELSE IF votes[cand] = votes[lowest] THEN
      BEGIN
      RandomUsed := true;

      {Multiplier is used to make all equally-lowest candidates
          equally likely to be chosen, even though they are
          considered serially and not simultaneously}

      lower := (multiplier * random < 1.0)
      END
   ELSE
      BEGIN
      lowly := (votes[cand] < votes[lowest]);
      lower := lowly;
      IF lowly THEN RandomUsed := false
      END;
   IF RandomUsed THEN multiplier := multiplier + 1
      ELSE multiplier := 2
   END; {lower}

   BEGIN
   LowCand := 0;
   FOR cand := 1 TO NumCandidates DO
      IF (status[cand] = Hopeful) OR (status[cand] = Almost) THEN
         IF lower(cand, LowCand) THEN LowCand := cand;
   LowestCandidate := LowCand
   END; {LowestCandidate}

PROCEDURE compute;

{This is the heart of the program, which counts the votes, taking
    the current weights into account, and adjusts the weights and
    the quota iteratively to attain the required solution}

   {MaxIterations is the maximum number of iterations allowed in
       calculating the weights. It is unlikely that so many will
       ever be used, but its value may be increased if desired}

   CONST MaxIterations = 500;
   VAR temp, value: real;
       count, iteration: integer;
       cand: CandRange;
       converged, ended: Boolean;

   PROCEDURE Rewind;

   {Returns to the beginning of datafile, and ignores the first two
       numbers on it. These are the number of candidates and the
       number of seats, whose values are not needed again. Numbers
       indicating withdrawn candidates are also ignored}

   VAR ig, ignore: integer;

   BEGIN
   reset (datafile);
   FOR ig := -1 TO ignored DO ignore := InInteger
   END; {Rewind}

BEGIN
iteration := 1;

   REPEAT
   Rewind;
   excess := 0.0;
   FOR cand := 1 TO NumCandidates DO votes[cand] := 0.0;
   count := InInteger;

   WHILE count > 0 DO
      BEGIN
      value := count;
      cand := InInteger;
      ended := false;

      WHILE cand>0 DO
         BEGIN
         IF NOT ended AND (weight[cand] > 0.0) THEN
            BEGIN
            ended := (status[cand] = Hopeful);
            IF ended THEN
               BEGIN
               votes[cand] := votes[cand] + value;
               value := 0.0
               END
            ELSE
               BEGIN
               votes[cand] := votes[cand] + value * weight[cand];
               value := value * (1.0 - weight[cand])
               END
            END;
         cand := InInteger
         END;

      excess := excess + value;
      count := InInteger
      END;

   {wrowe 2005 May 28 added one billionth to the resulting quota,
       further decreasing the unlikely possibility of a tie, 
       per the rules of implementation adopted by New Zealand}

   quota := (total - excess) * Droop + 0.000000001;

{The next statement is unlikely ever to be used, but is a
safeguard against certain pathological test data}

IF quota < 0.0001 THEN quota := 0.0001;
converged := true;
FOR cand := 1 TO NumCandidates DO
   IF status[cand] = Elected THEN
      BEGIN
      temp := quota / votes[cand];
      IF (temp > 1.00001) OR (temp < 0.99999) THEN
         converged := false;
      temp := weight[cand] * temp;
      weight[cand] := temp;

      {The next statement is unlikely ever to be used, but is
        a safeguard against certain pathological test data}

      IF temp > 1.0 THEN weight[cand] := 1.0
      END;

iteration := iteration + 1
UNTIL (iteration = MaxIterations) OR converged;

IF NOT converged THEN
   BEGIN

   {The "Failure to converge" message is unlikely ever to appear.
     If it does, increasing MaxIterations will probably cure it}

   writeln;
   writeln;
   writeln('Failure to converge');
   writeln
   END;
count := 0;

FOR cand := 1 TO NumCandidates DO
   IF (status[cand] = Hopeful) AND (votes[cand] >= quota) THEN
      BEGIN
      status[cand] := Almost;
      count := count + 1
      END;

{Allow for the special case where there is a multi-way tie and
   too many candidates reach the quota simultaneously}

WHILE NumElected + count > NumSeats DO
   BEGIN
   PrintOut;
   RandomUsed := false;
   FOR cand := 1 TO NumCandidates DO
      IF status[cand] = Hopeful THEN exclude(cand);
   exclude(LowestCandidate);
   count := count - 1
   END;

SomeoneElected := false;
FOR cand := 1 TO NumCandidates DO
   IF status[cand] = Almost THEN
      BEGIN
      elect(cand);
      SomeoneElected := true
      END;

IF SomeoneElected THEN PrintOut;
FOR cand := 1 TO NumCandidates DO
   IF status[cand] = NewlyElected THEN
      BEGIN
      IF NumElected < NumSeats THEN
         weight[cand] := quota / votes[cand];
      status[cand] := Elected
      END
END; {compute}

PROCEDURE complete;

   {Used to elect all remaining candidates if the number
      remaining equals the number of seats remaining}

   VAR cand: Candidates;
   BEGIN
   FOR cand := 1 TO NumCandidates DO
      IF status[cand] = Hopeful THEN elect(cand)
   END; {complete}

PROCEDURE Preliminaries;

   {Checks datafile for errors and sets initial values of variables}

   VAR cand, count, LineNo: integer;

   PROCEDURE error(cand: integer; TooBig: Boolean);
      BEGIN
      writeln;
      write ('On line ' , LineNo: 1, ', Candidate ', cand: 1);
      IF TooBig THEN write (' exceeds maximum')
      ELSE write (' is repeated');
      writeln;
      faulty := true
      END; {error}

   PROCEDURE ReadName(VAR n: name);

      {Reads the name of a candidate, or reads a title, and stores
          it for later use. If the name has more than NameLength
          characters the excess ones will be disregarded. If it
          has fewer than NameLength characters blanks will be used
          to extend it}

      VAR i: integer;
          ch: char;
      BEGIN

         REPEAT
         read(datafile, ch)
         UNTIL ch = '"';

      i := 0;
      read(datafile, ch);
      WHILE ch <> '"' DO
         BEGIN
         IF i < NameLength THEN
            BEGIN
            i := i + 1;
            n[i] := ch
            END;
         read(datafile, ch)
         END;

      WHILE i < NameLength DO
         BEGIN
         i := i + 1;
         n[i] := ' '
         END
      END; {ReadName}

   BEGIN

   Droop := 1.0/(NumSeats + 1);
   LineNo := 1;
   seed1 := 0;
   total := 0.0;
   table := 0;
   NumElected := 0;
   NumExcluded := 0;
   ignored := 0;
   FOR cand := 1 TO NumCandidates DO weight[cand] := 1.0;
   count := InInteger;

   {Deal with withdrawals, if any}

   WHILE count < 0 DO
      BEGIN
      weight[-count] := 0.0;
      count := InInteger
      END;
   WHILE count > 0 DO
      BEGIN
      LineNo := LineNo + 1;
      total := total + count;
      FOR cand := 1 TO NumCandidates DO status[cand] := NotUsed;
      cand := InInteger;
      WHILE cand > 0 DO
         BEGIN
         IF cand > NumCandidates THEN error(cand, true)
            ELSE IF status[cand] = Used THEN error(cand, false)
               ELSE status[cand] := Used;
         cand := InInteger
         END;

      count := InInteger
      END;

   FOR cand := 1 TO NumCandidates DO
      BEGIN
      ReadName(names[cand]);
      status[cand] := Hopeful;
      IF weight[cand] < 0.5 THEN
         BEGIN
         status[cand] := Excluded;
         NumExcluded := NumExcluded + 1;
         ignored := ignored + 1
         END
      END;
   ReadName(title);
   IF NOT faulty THEN

      BEGIN

      {FracDigits controls the number of digits beyond the decimal
          point that will be printed in the output tables}

      FracDigits := 4;
      IF total > 999.5 THEN FracDigits := FracDigits - 1;
      IF total > 99.5 THEN FracDigits := FracDigits - 1;
      IF total > 9.5 THEN FracDigits := FracDigits - 1
      END
   END; {Preliminaries}

{Start of main program}

BEGIN

{wrowe 28 May 2005 added command line .blt filename argument}

Assign(datafile, ParamStr(1));
Reset(datafile);

{/wrowe 28 May 2005 added command line .blt filename argument}

NumCandidates := InInteger;
NumSeats := InInteger;
writeln;
writeln;
writeln('Number of Candidates = ', NumCandidates: 1);
writeln ('Number of seats = ', NumSeats: 1);
IF NumCandidates < NumSeats THEN writeln('All candidates elected') ELSE
   BEGIN
   faulty := false;
   Preliminaries;
   IF NumCandidates <= NumSeats + NumExcluded THEN
      writeln('All non-withdrawn candidates elected') ELSE
      BEGIN

      {The Preliminaries procedure will have reset faulty to true if
         the data contain errors}

      IF NOT faulty THEN
         BEGIN
            REPEAT
               {Count votes and elect candidates, transferring
                   surpluses until no more can be done or all
                   seats are filled}

               REPEAT
               compute
               UNTIL NOT SomeoneElected OR (NumElected >= NumSeats);

               {Unless the election is finished, someone must
                   now be excluded}

               IF NumElected < Numseats THEN
                  BEGIN
                  PrintOut;
                  exclude(LowestCandidate);
                  IF NumCandidates - NumExcluded = NumSeats
                     THEN complete ELSE PrintOut
                  END
               UNTIL NumElected = NumSeats;

            {Now that all seats are filled, exclude any candidates not
                 already elected, and print out the final table}

            RandomUsed := false;
            FOR candidate := 1 TO NumCandidates DO
               IF status[candidate] = Hopeful THEN exclude(candidate);
            PrintOut
            END
         END
      END
END.