'** Implementation of Schelling Tipping Model in Visual Basic ** '** Implemented in Pascal by R. Axelrod ** '** Implemented in Visual Basic/Excel by Sandeep Kumar, 12/95 ** 'Declare Options Option Explicit 'specify all variables to be explicitly declared 'Control Constants Const version = 1 'version of this program Const Debug_Info = False 'if true report debugging info Const old_random_seed = 0 'if 0 generate new seed from the clock else use this seed Const events_per_report = 200 'Controls the frequency of the output Const number_of_reports = 4 'Controls the number of reports in all Const agentmap_display = True 'if true display agent map 'Input Parameters Const N = 40 'Number of actors Const proportion_white = 0.5 'proportion of actors who are white 'Variables Dim Row_Index As Integer 'Index for row for output Dim Column_Index As Integer 'Index for column for output Dim Today As Date 'Date when this program is run Dim Finish As Date 'Date when this program terminated Dim random_seed As Integer 'used for generating the new seed Dim occupant(0 To 64) As Integer 'which i occupies the location; 0 is empty Dim color(1 To N) As Integer 'color of the ith actor Dim location(1 To N) As Integer 'location of the ith actor Dim i As Integer 'actor index Dim event As Integer 'Count of events Dim neighbor_loc(1 To 64, 1 To 8) '8 neighbouring locs of a cell, 0 if off board Dim report As Integer 'count of reports, each with events_per_report in it Dim event_in_report As Integer 'count of events within current report Dim moves_this_period As Integer 'count of moves so far in current period 'generates a different initial seed using in-built timer function for Rnd function Sub set_random_seed() If old_random_seed = 0 Then Randomize End If End Sub 'generates a random integer between 1 and 64 inclusive Function random_one_to_n(N As Integer) As Integer random_one_to_n = Int((N * Rnd) + 1) End Function 'give each actor color of 0(white) or 1(black) Sub Initialize_actor_color() Dim j As Integer 'actor Row_Index For j = 1 To N If j <= proportion_white * N Then color(j) = 0 Else color(j) = 1 End If Next j End Sub 'put actors on the map Sub Initialize_actor_location() Dim i As Integer 'actor index Dim j As Integer 'cell index Dim trial_location As Integer 'initialize all the locations or cells of map as available or empty For j = 1 To 64 occupant(j) = 0 Next j 'assign all the actors to empty positons or cells on the map For i = 1 To N Do trial_location = random_one_to_n(64) 'random trial location Loop Until occupant(trial_location) = 0 'accept when empty occupant(trial_location) = i 'update the occupancy list location(i) = trial_location 'set the location of ith actor Next i End Sub 'Calculate 8 neighbours of each cell of map Sub Initialize_neighbour_list() Dim L As Integer For L = 1 To 64 'Each location 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 neighbor_loc(L, 1) = 0 neighbor_loc(L, 2) = 0 neighbor_loc(L, 3) = 0 End If If L > 56 Then 'correct bottom row neighbor_loc(L, 6) = 0 neighbor_loc(L, 7) = 0 neighbor_loc(L, 8) = 0 End If If L Mod 8 = 0 Then 'correct right side neighbor_loc(L, 3) = 0 neighbor_loc(L, 5) = 0 neighbor_loc(L, 8) = 0 End If If (L - 1) Mod 8 = 0 Then 'correct left side neighbor_loc(L, 1) = 0 neighbor_loc(L, 4) = 0 neighbor_loc(L, 6) = 0 End If Next L End Sub 'find if the active actor is content Function Content() As Boolean Dim neigh As Integer Dim L As Integer 'location of i Dim ncell As Integer 'neigbhoring cell Dim same_color_count As Integer 'count of neighbors of same color as i Dim occupied_count As Integer 'count of neighboring locs which are occupied same_color_count = 0 occupied_count = 0 L = location(i) 'look up i's location For neigh = 1 To 8 'check each neighbor ncell = neighbor_loc(L, neigh) 'neighboring cell If (ncell <> 0) And (occupant(ncell) <> 0) Then 'neigboring location is on map and occupied occupied_count = occupied_count + 1 If color(occupant(ncell)) = color(i) Then same_color_count = same_color_count + 1 End If End If Next neigh If 3 * same_color_count > occupied_count Then Content = True Else Content = False End If End Function 'jump to a random location Sub Random_move() Dim trial_location As Integer Do trial_location = random_one_to_n(64) Loop Until occupant(trial_location) = 0 'empty location is 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 Sub 'Write output's header info Sub Initial_Output() Row_Index = 1 Worksheets("TippingOutput").Cells(Row_Index, 1).Value = "Schelling Tipping Model, coded by Sandeep Kumar. Version : " & version & "." Today = Now Row_Index = Row_Index + 1 Worksheets("TippingOutput").Cells(Row_Index, 1).Value = " This run began on " & Today & "." Row_Index = Row_Index + 1 Worksheets("TippingOutput").Cells(Row_Index, 1).Value = " Number of actors = " & N & "." Row_Index = Row_Index + 1 Worksheets("TippingOutput").Cells(Row_Index, 1).Value = " Proportion of actors who have color 0 = " & proportion_white Row_Index = Row_Index + 1 End Sub 'Write Periodic report Sub Periodic_Output() Dim Row_No As Integer 'line number of map Dim L As Integer 'location Dim column As Integer 'column in map Dim actor As Integer Dim Column_Index As Integer Row_Index = Row_Index + 2 If event = 0 Then Worksheets("TippingOutput").Cells(Row_Index, 3).Value = " Initial Conditions" ElseIf event <> 0 Then Worksheets("TippingOutput").Cells(Row_Index, 3).Value = "Event " & event Worksheets("TippingOutput").Cells(Row_Index, 6).Value = "Moves this period " & moves_this_period End If Row_Index = Row_Index + 1 If agentmap_display = True Then Worksheets("TippingOutput").Cells(Row_Index, 5).Value = " Agent Map " Worksheets("TippingOutput").Cells(Row_Index, 16).Value = " Color Map" Else Worksheets("TippingOutput").Cells(Row_Index, 5).Value = " Color Map" End If Row_Index = Row_Index + 1 L = 0 For Row_No = 1 To 8 If agentmap_display = True Then Column_Index = 3 For column = 1 To 8 'agent map L = L + 1 Worksheets("TippingOutput").Cells(Row_Index, Column_Index).Value = occupant(L) actor = occupant(L) Column_Index = Column_Index + 1 Next column L = L - 8 Column_Index = Column_Index + 2 Else Column_Index = 3 End If For column = 1 To 8 'color map L = L + 1 actor = occupant(L) If occupant(L) = 0 Then Worksheets("TippingOutput").Cells(Row_Index, (Column_Index)).Value = " ." Else Worksheets("TippingOutput").Cells(Row_Index, (Column_Index)).Value = color(occupant(L)) End If Column_Index = Column_Index + 1 Next column Row_Index = Row_Index + 1 Next Row_No End Sub 'initialize a run Sub Initialize() event = 0 set_random_seed Initial_Output Initialize_actor_color Initialize_actor_location Initialize_neighbour_list Periodic_Output End Sub Sub Main() Dim state As Boolean Dim count As Integer Worksheets("TippingOutput").Activate Range(Cells(1, 1), Cells(100, 24)).ClearContents Range(Cells(1, 1), Cells(100, 24)).ColumnWidth = 3 Initialize count = 0 event = 0 'start event count i = 0 'start actor list For report = 1 To number_of_reports moves_this_period = 0 'intialize count of actual moves For event_in_report = 1 To events_per_report event = event + 1 i = i + 1 'activate next actor on the list If i > N Then i = 1 End If If Content() = False Then 'if actor not content then move it moves_this_period = moves_this_period + 1 Random_move End If Next event_in_report 'one report is done Periodic_Output 'display the agent & color map at the end of one report Next report Finish = Now Worksheets("TippingOutput").Cells(5, 1).Value = "This run ended at:" & Finish End Sub
University of Michigan Center for the Study of Complex Systems
Contact cscs@umich.edu.
Revised November 4, 1996.