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}