Complexity of Cooperation Web Site

Tipping.p


program Tipping2;
{ Schelling's Tipping Model                         }
{    Implemented by Robert Axelrod.         }
{     See my file "Schelling Documentation".}
{  ver 1 begun 10/5/95                          }
{  ver 2 begun 10/6/95                          }
{           initialize random seed,                     }
{           add starting time                           }
{           report only periodically                    }
{           add output of map of "colors"       }

 const                  {contants - used for input parameters}

{control constants}
  Version = 2;                              {version of this program}
  debug = false;                        {if True, report debugging info}
  old_random_seed = 0;          {if 0 generate new seed from clock, else use this seed}
  events_per_report = 200;          {Controls frequency of output}
  number_of_reports = 4;            {Controls number of reports in all}

{input parameters}
  N = 50;                                       {number of actors}
  proportion_white = 0.50;          {proportion of actors who are "white", i.e. color=0}


 var                    {variables}
  occupant: array[0..64] of integer;        {which i occupies the location; 0 is empty}
  color: array[1..N] of integer;                {color of the ith actor}
  location: array[1..N] of integer;         {location of ith actor}
  event: integer;                                       {count of events}
  i: integer;                                               {actor index}
  neighbor_loc: array[1..64, 1..8] of integer;  {8 neighboring locs of a cell, 0 if off board}
  random_seed: integer;
  initial_datetime: datetimerec;    {date, etc.}
  initial_hour: longint;
  report: integer;                      {count of reports, each with events_per_report in it}
  event_in_report: integer;         {count of events within current report}
  moves_this_period: integer;       {count of moves so far in current period}
 { ---------------------------------------------------------------  }
 procedure set_random_seed;         {called from initial_output}
 begin
  if old_random_seed = 0 then
   begin                                                {generate new seed}
    random_seed := initial_datetime.hour + initial_datetime.minute + initial_datetime.second;
    random_seed := random_seed + (initial_datetime.second * 300);
    random_seed := random_seed + (initial_datetime.minute * initial_datetime.hour);
    random_seed := random_seed + (initial_datetime.minute * initial_datetime.second);
    randseed := random_seed;                {set system's random seed}
   end
  else
   begin                                        {use old seed, which was inputed as constant}
    randseed := old_random_seed;
   end;
 end; {set_random_seed;}
{ { ---------------------------------------------------------------  }
 function random_one_to_n (n: longint): longint;        {a random integer between 1 and n inclusive}
  var
   ub, lb: integer;                             {upper and lower bounds}
   r: integer;
 begin
  ub := 32767 - (32767 mod n);
  lb := -32768 - (-32768 mod n);        {truncate distrib on 2 ends so that later mod is OK}
  repeat
   r := random;                                 {Mac system function gives # betw -32768 and 32767}
  until (r <= ub) and (r >= lb);            {make sure random genrated is in truncated (even) distrib}
  random_one_to_n := abs(r mod n) + 1;
 end;            {random function}
 { ---------------------------------------------------------------  }
 procedure initialize_actor_color;  {give each actor color of 0 or 1}
  var
   i: integer;                  {actor index}
 begin
  for i := 1 to N do                    {Set up actor vector}
   begin
    if i <= proportion_white * N then
     color[i] := 0              {first part of list is 0's}
    else
     color[i] := 1;
   end;
 end;{initialize_actor_color}
{ ---------------------------------------------------------------  }
 procedure initialize_actor_location;       {put actors on the map}
  var
   i: integer;                  {actor index}
   trial_location: integer;
 begin
  for i := 1 to N do
   begin
    repeat
     trial_location := random_one_to_n(64)      {trial location]}
    until occupant[trial_location] = 0;     {accept when empty}
    occupant[trial_location] := i;
    location[i] := trial_location;
   end;
 end;{initialize_actor_location}
{ ---------------------------------------------------------------  }
 procedure initialize_neighbor_list;        {calculate 8 neighbors of each cell of map}
{MAKE 0 IF off board}
  var
   L: integer;              {location}
 begin
  for L := 1 to 64 do           {EACH LOCATION}
   begin
    neighbor_loc[L, 1] := L - 9;            {northwest}
    neighbor_loc[L, 2] := L - 8;            {north}
    neighbor_loc[L, 3] := L - 7;
    neighbor_loc[L, 4] := L - 1;
    neighbor_loc[L, 5] := L + 1;
    neighbor_loc[L, 6] := L + 7;
    neighbor_loc[L, 7] := L + 8;
    neighbor_loc[L, 8] := L + 9;
    if L < 9 then               {CORRECT TOP ROW}
     begin
      neighbor_loc[L, 1] := 0;
      neighbor_loc[L, 2] := 0;
      neighbor_loc[L, 3] := 0;
     end;
    if L > 56 then              {CORRECT TOP ROW}
     begin
      neighbor_loc[L, 6] := 0;
      neighbor_loc[L, 7] := 0;
      neighbor_loc[L, 8] := 0;
     end;
    if L mod 8 = 0 then     {CORRECT RIGHT SIDE}
     begin
      neighbor_loc[L, 3] := 0;
      neighbor_loc[L, 5] := 0;
      neighbor_loc[L, 8] := 0;
     end;
    if (L - 1) mod 8 = 0 then       {CORRECT LEFT SIDE}
     begin
      neighbor_loc[L, 1] := 0;
      neighbor_loc[L, 4] := 0;
      neighbor_loc[L, 6] := 0;
     end;
   end;{L}
 end;   {initialize_neighbor_list}
{ ---------------------------------------------------------------  }
 function content: boolean;     {cacluate if active actor is content}
                {True is content, F is not}
  var
   neigh: integer;
   L: integer;          {location of i}
   ncell: integer;      {neighboring cell}
   same_color_count: integer;       {count of neighbors of the same color as i}
   occupied_count: integer;         {count of neighboring locs which are occupied}
 begin
  same_color_count := 0;
  occupied_count := 0;
  L := location[i];                     {look up i's location}
  for neigh := 1 to 8 do            {check each neighbor}
   begin
    ncell := neighbor_loc[L, neigh];        {neighboring cell}
    if (ncell <> 0) and (occupant[ncell] <> 0) then
{neighboring location is on map, and occupied}
     begin
      occupied_count := occupied_count + 1;
      if debug then
       begin
       write('test L, neigh, n[L, neigh], occt[neig[L, neigh]]');
       writeln(L, neigh, neighbor_loc[L, neigh], occupant[neighbor_loc[L, neigh]]);
       end;
      if color[occupant[ncell]] = color[i] then     {same color}
       same_color_count := same_color_count + 1;
     end;{if neighbor is on board}
   end;{debug}
  if 3 * same_color_count > occupied_count then
   content := true
  else
   begin
    content := false;
   end;
  if debug then
   begin
    write('test, i=', i : 3, '. same_color_count=', same_color_count : 3);
    writeln('. occupied_count= ', occupied_count : 3);
   end;{debug}
 end; {content}
{ ---------------------------------------------------------------  }
 procedure random_move;             {jump to a random empty location}
  var
   trial_location: integer;
 begin
  repeat
   trial_location := random_one_to_n(64);
  until occupant[trial_location] = 0;   {empty location found}
  occupant[location[i]] := 0;                   {empty i's old location}
  occupant[trial_location] := i;                {fill the new location}
  location[i] := trial_location;                {change i's location}
 end;{move}
{ ---------------------------------------------------------------  }
 procedure initial_output;                  {write output's header info}
 begin
  writeln(' Schelling tipping model, coded by R. Axelrod.  Version ', version : 2, '.');
  write('   This run began on ', stringof(initial_datetime.month : 2), '/');
  write(stringof(initial_datetime.day : 2), '/', stringof(initial_datetime.year : 4), ' at ');
  writeln(stringof(initial_datetime.hour : 2), ':', stringof(initial_datetime.minute : 2), '.');
  writeln('   Number of actors = ', N : 3, '.');
  writeln('   Proportion of actors who have color 0 = ', proportion_white : 4 : 2);
  if old_random_seed = 0 then
   Writeln('   New random seed ', randseed : 6, '. ')
  else
   Writeln('   Old random seed ', randseed : 6, '.');
  writeln;
 end;
{ ---------------------------------------------------------------  }
 procedure periodic_output;             {write periodic report}
  var
   line: integer;                       {line number of map}
   L: integer;                          {location}
   column: integer;                 {column in map}
 begin
  if event = 0 then
   writeln('Initial conditions.')
  else
   writeln('Event', event : 5, '. Moves this period', moves_this_period : 4, '.');
  writeln('        Agent Map                  Color Map');
  L := 0;
  for line := 1 to 8 do
   begin
    for column := 1 to 8 do     {agent map}
     begin
      L := L + 1;       {next location}
      write(occupant[L] : 3);
     end;{col}
    L := L - 8;     {restart this row}
    write('      ');        {space between maps}
    for column := 1 to 8 do     {color map}
     begin
      L := L + 1;
      if occupant[L] = 0 then
       write(' .')
      else
       write(color[occupant[L]] : 2);
     end;
    writeln;
   end;{line}
  writeln;
 end; {periodic output}
{ ---------------------------------------------------------------  }
 procedure initialize;                   {initialize a run}
 begin
  gettime(initial_datetime);                    {record starting time from system clock}
  initial_hour := initial_datetime.hour;    {to force long integer}
  set_random_seed;
  initial_output;                                   {includes setting random number seed}
  initialize_actor_color;
  initialize_actor_location;
  initialize_neighbor_list;
  periodic_output;                                  {eport initial positions}
 end;{initialize}
{ ---------------------------------------------------------------  }
{M A I N    P R O G R A M }
begin
 initialize;
 event := 0;                                            {start event count}
 i := 0;                                                    {start actor list}
 for report := 1 to number_of_reports do
  begin
   moves_this_period := 0;                  {initialize count of actual moves}
   for event_in_report := 1 to events_per_report do
    begin
     event := event + 1;
     i := i + 1;                            {activate next actor on the list}
     if i > N then
      i := 1;
     if not content then                    {if actor is not content then move it}
      begin
       moves_this_period := moves_this_period + 1;
       random_move;
      end;{if not content}
    end;{one event in this report}
   periodic_output;                             {report at end of period}
  end;{report (at end of period)}
end.{main program}

Back to Appendix B
Back to Complexity of Cooperation Home Page

University of Michigan Center for the Study of Complex Systems
Contact cscs@umich.edu.
Revised November 4, 1996.