home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB16.ZIP / VOTER.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-02-06  |  9.4 KB  |  295 lines
  1. {$R-}
  2. {$C-}
  3. {$K-}
  4. Program Voter;
  5.  
  6. Procedure Document;
  7. {For those of you who do not like machine specific code, I apologize.}
  8. {But for programs like this, I like speed.}
  9. Begin
  10. WriteLn;
  11. WriteLn(' This program runs the voting simulation described in the Computer');
  12. WriteLn(' Recreations column of Scientific American of April 1985.');
  13. WriteLn('');
  14. WriteLn(' First parameter selects the rule used to determine a cell''s vote:');
  15. WriteLn('    0) The rule described in the above mentioned article:');
  16. WriteLn('       Select a neighbor at random and AGREE with it. (DEFAULT)');
  17. WriteLn('    1) Ornery cuss rule: Select a neighbor at random; DISAGREE.');
  18. WriteLn('    2) Poll the neighbors. Always go along with the majority.');
  19. WriteLn('    3) Poll the neighbors. Go along with majority 99% of the time.');
  20. WriteLn('');
  21. WriteLn('The second selects the startup pattern:');
  22. WriteLn('    0) Random (DEFAULT)');
  23. WriteLn('    1) Checkerboard.');
  24. WriteLn('    2) All off.');
  25. WriteLn('    3) Use third parameter (between 0.0 and 1.0) to determine');
  26. WriteLn('       what percentage of the cells begin ON.');
  27. WriteLn('');
  28. WriteLn(' No error messages. Leaving out both parameters, gets you this message.');
  29. WriteLn(' To stop, press control-C TWICE. First time displays number of votes');
  30. WriteLn(' polled so  far; second one aborts the program.');
  31. WriteLn('                                       Richard Fritzson');
  32. {WriteLn('                                      PO Box 4033');}
  33. WriteLn('                                       Madison, WI  53711');
  34. End;
  35.  
  36.  
  37. Const
  38.      X = 80;  XDim = 79; {Screen Dimensions}
  39.      Y = 23;  YDim = 22;
  40.      RuleCnt = 4;        {How many rules are there}
  41. Var
  42.    Count:    Real;       {Keep count of ballots vote}
  43.    ScrSeg :  Integer;    {Where is the display screen}
  44.    Rule:     Integer;    {Which rule to use}
  45.  
  46. {Return current monitor mode  (7 = mono)}
  47. Function Crtmode : Integer;
  48. Type
  49.     Register = Record
  50.                   Ax,Bx,Cx,Dx,Bp,Si,Ds,Es,Flags : Integer;
  51.                End;
  52. Var
  53.    Intrregs    :  Register;
  54. Begin
  55.       With Intrregs Do Begin
  56.            Ax := $0F00;
  57.            Intr($10,Intrregs);
  58.            Crtmode := Lo(Ax);
  59.       End;
  60. End;
  61.  
  62. Procedure Cast(X: Integer; Y:Integer; T:Char);
  63. {Store vote T in cell X,Y}
  64. Begin
  65.       Memw[ScrSeg:(160*Y+2*X)] := $0F00+ord(T);
  66. End;
  67.  
  68. Function Vote(X,Y:Integer): Char;
  69. {How does cell X,Y vote?}
  70. Begin
  71.      Vote := chr(Mem[ScrSeg:(160*Y+2*X)]);
  72. End;
  73.  
  74.  
  75. Procedure Initialize; {Setup the universe and the display screen}
  76.  
  77.   Function Ranvote(Start:Integer;P:Real;X,y:Integer): Char;
  78.   {Using rule Start, produce an initial vote for cell X,Y}
  79.    Begin
  80.      Case Start of
  81.           0: {Random Assignment}
  82.              If Random >= 0.50     Then Ranvote := ' '
  83.              Else                       Ranvote := #254;
  84.           1: {Checkerboard pattern}
  85.              If (X mod  2) = (Y mod 2) Then Ranvote := #254
  86.              Else                           Ranvote := ' ';
  87.           2: {All blank}
  88.              Ranvote := ' ';
  89.           3: {P% on}
  90.              If Random >= P     Then Ranvote := ' '
  91.              Else                    Ranvote := #254;
  92.      End;
  93.    End;
  94.  
  95. Var IX, JY: Integer;
  96.     Start:  Integer;  {Initial pattern rule}
  97.     Pcnt:   Real;
  98. Begin
  99.      {Interpret command line}
  100.      If ParamCount = 0 Then Begin
  101.         Document;
  102.         Halt;
  103.      End;
  104.  
  105.      Val(Paramstr(1),Rule,IX);  {Select a rule from the command line}
  106.      If IX <> 0 Then Rule := 0; {Use 0 by default}
  107.      Rule := Rule mod (RuleCnt + 1);
  108.  
  109.      Val(Paramstr(2),Start,IX); {Select a startup pattern}
  110.      If IX <> 0 Then Start := 0;
  111.      Start := Start mod 4;
  112.  
  113.      If Start = 3 Then Begin    {Get user specified decimal fraction}
  114.         Val(Paramstr(3),Pcnt,IX); {Use user's percentage}
  115.         If IX <> 0 Then Pcnt := 0.50;
  116.      End;
  117.      {Initialize screen}
  118.      ClrScr;
  119.      If CrtMode = 7 Then ScrSeg := $B000 Else ScrSeg := $B800;
  120.      Randomize;
  121.      Count := 0.0;
  122.      For IX := 0 To X-1 Do For JY := 0 To Y-1 Do Begin
  123.          Cast(IX,JY,Ranvote(Start,Pcnt,IX,JY));
  124.      End;
  125.      GoToXY(40,24);
  126.      Case Rule of
  127.           0: Write('Random Neighbor Rule');
  128.           1: Write('Ornery Cuss Rule');
  129.           2: Write('Majority Rules');
  130.           3: Write('99% Majority Rule');
  131.      End;
  132.      GoToXY(63,24);
  133.      Case Start of
  134.           0: Write('Random Start');
  135.           1: Write('Checkerboard Start');
  136.           2: Write('Blank start');
  137.           3: Write(Pcnt:4:2,'% on start');
  138.      End;
  139. End;
  140.  
  141. Procedure ChangeVote0;
  142. Var I, J: Integer;
  143. {This implements the standard voting algorithm:
  144.       Select a cell at random.
  145.       Select a neighbor at random.
  146.       Made the cell's new Vote the same as the neighbor's.}
  147.  
  148. Begin
  149.      Count := Count + 1;
  150.      I := Random(X);
  151.      J := Random(Y);
  152.      Case Random(8) of
  153.           0: Cast(I,J,Vote((I+X-1 ) mod X ,(J+Y-1 ) mod Y));
  154.           1: Cast(I,J,Vote((I+X   ) mod X ,(J+Y-1 ) mod Y));
  155.           2: Cast(I,J,Vote((I+X+1 ) mod X ,(J+Y-1 ) mod Y));
  156.           3: Cast(I,J,Vote((I+X-1 ) mod X ,(J+Y   ) mod Y));
  157.           4: Cast(I,J,Vote((I+X+1 ) mod X ,(J+Y   ) mod Y));
  158.           5: Cast(I,J,Vote((I+X-1 ) mod X ,(J+Y+1 ) mod Y));
  159.           6: Cast(I,J,Vote((I+X   ) mod X ,(J+Y+1 ) mod Y));
  160.           7: Cast(I,J,Vote((I+X+1 ) mod X ,(J+Y+1 ) mod Y));
  161.      End;
  162. End;
  163.  
  164. Procedure ChangeVote1;
  165. Var I, J: Integer;
  166. {This implements the ornery cuss rule:
  167.       Select a cell at random.
  168.       Select a neighbor at random.
  169.       Made the cell's new Vote the opposite of the neighbor's.}
  170.  
  171. Function Disagree(X:Char):Char;
  172. Begin
  173.    If X = ' ' Then Disagree := #254
  174.    Else            Disagree := ' ';
  175. End;
  176.  
  177. Begin
  178.      Count := Count + 1;
  179.      I := Random(X);
  180.      J := Random(Y);
  181.      Case Random(8) of
  182.           0: Cast(I,J,Disagree(Vote((I+X-1 ) mod X ,(J+Y-1 ) mod Y)));
  183.           1: Cast(I,J,Disagree(Vote((I+X   ) mod X ,(J+Y-1 ) mod Y)));
  184.           2: Cast(I,J,Disagree(Vote((I+X+1 ) mod X ,(J+Y-1 ) mod Y)));
  185.           3: Cast(I,J,Disagree(Vote((I+X-1 ) mod X ,(J+Y   ) mod Y)));
  186.           4: Cast(I,J,Disagree(Vote((I+X+1 ) mod X ,(J+Y   ) mod Y)));
  187.           5: Cast(I,J,Disagree(Vote((I+X-1 ) mod X ,(J+Y+1 ) mod Y)));
  188.           6: Cast(I,J,Disagree(Vote((I+X   ) mod X ,(J+Y+1 ) mod Y)));
  189.           7: Cast(I,J,Disagree(Vote((I+X+1 ) mod X ,(J+Y+1 ) mod Y)));
  190.      End;
  191. End;
  192.  
  193. Procedure ChangeVote2;
  194. { This rule implements the "majority rules" rule. When polled,
  195.   each cell ALWAYS adopts the opinion of the majority of his
  196.   neighbors. }
  197.  
  198. Var I, J: Integer;
  199.  
  200.    Function Survey(I,J:Integer): Char;
  201.    Var K:Integer;
  202.    Begin
  203.         K := 0;
  204.         If Vote((I+X-1 ) mod X ,(J+Y-1 ) mod Y) <> ' ' Then K := K + 1;
  205.         If Vote((I+X   ) mod X ,(J+Y-1 ) mod Y) <> ' ' Then K := K + 1;
  206.         If Vote((I+X+1 ) mod X ,(J+Y-1 ) mod Y) <> ' ' Then K := K + 1;
  207.         If Vote((I+X-1 ) mod X ,(J+Y   ) mod Y) <> ' ' Then K := K + 1;
  208.         If Vote((I+X+1 ) mod X ,(J+Y   ) mod Y) <> ' ' Then K := K + 1;
  209.         If Vote((I+X-1 ) mod X ,(J+Y+1 ) mod Y) <> ' ' Then K := K + 1;
  210.         If Vote((I+X   ) mod X ,(J+Y+1 ) mod Y) <> ' ' Then K := K + 1;
  211.         IF Vote((I+X+1 ) mod X ,(J+Y+1 ) mod Y) <> ' ' Then K := K + 1;
  212.         If K > 4      Then Survey := #254
  213.         Else If K < 4 Then Survey := ' '
  214.         Else               Survey := Vote(I,J);
  215.    End;
  216.  
  217. Begin
  218.      Count := Count + 1;
  219.      I := Random(X);
  220.      J := Random(Y);
  221.      Cast(I,J,Survey(I,J));
  222. End;
  223.  
  224.  
  225. Procedure ChangeVote3;
  226. { This rule plays with probabilities:
  227.        1) survey the neighbors.
  228.        2) Make it 99% certain the cell will go along
  229.           with the majority. This allows for dissension
  230.           even when all eight neighbors agree.}
  231.  
  232.    Function Survey(I,J:Integer): Char;
  233.    Var K:Integer; Prob : Real;
  234.    Begin
  235.         K := 0;
  236.         If Vote((I+X-1 ) mod X ,(J+Y-1 ) mod Y) <> ' ' Then K := K + 1;
  237.         If Vote((I+X   ) mod X ,(J+Y-1 ) mod Y) <> ' ' Then K := K + 1;
  238.         If Vote((I+X+1 ) mod X ,(J+Y-1 ) mod Y) <> ' ' Then K := K + 1;
  239.         If Vote((I+X-1 ) mod X ,(J+Y   ) mod Y) <> ' ' Then K := K + 1;
  240.         If Vote((I+X+1 ) mod X ,(J+Y   ) mod Y) <> ' ' Then K := K + 1;
  241.         If Vote((I+X-1 ) mod X ,(J+Y+1 ) mod Y) <> ' ' Then K := K + 1;
  242.         If Vote((I+X   ) mod X ,(J+Y+1 ) mod Y) <> ' ' Then K := K + 1;
  243.         IF Vote((I+X+1 ) mod X ,(J+Y+1 ) mod Y) <> ' ' Then K := K + 1;
  244.         If K > 4      Then Prob := 0.99
  245.         Else If K < 4 Then Prob := 0.01
  246.         Else               Prob := 0.50;
  247.         If Random < Prob Then Survey := #254 Else Survey := ' ';
  248.    End;
  249.  
  250.  
  251. Var I, J: Integer;
  252. Begin
  253.      Count := Count + 1;
  254.      I := Random(X);
  255.      J := Random(Y);
  256.      Cast(I,J,Survey(I,J));
  257. End;
  258.  
  259. Procedure ChangeVote;
  260. {Change a single vote using the current rule}
  261. Begin
  262.      Case Rule of
  263.           0: ChangeVote0;
  264.           1: ChangeVote1;
  265.           2: ChangeVote2;
  266.           3: ChangeVote3;
  267.      End;
  268. End;
  269.  
  270.  
  271. Procedure RunVoterCycle; {Change the voters minds}
  272.  
  273. Var C: Char; I,J: Integer;
  274. Begin
  275.    While True Do Begin
  276.      Repeat
  277.            Changevote;
  278.      Until KeyPressed;
  279.      Read(Kbd,C);
  280.      GoToXY(1,24);Write(Count:9:0);
  281.      Read(Kbd,C);
  282.      If C = #03 Then Begin
  283.         ClrScr;
  284.         Halt;
  285.      End;
  286.      GoToXY(1,24);Write('                  ');
  287.    End;
  288. End;
  289.  
  290. Begin
  291.      Initialize;
  292.      RunVoterCycle;
  293. End.
  294.  
  295.