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}
University of Michigan Center for the Study of Complex Systems
Contact cscs@umich.edu.
Revised November 4, 1996.