'** 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