'*****************************************************
'** "Implementation of CultureDemo in Visual Basic" **
'** Author:                                         **
'**    Implemented in Pascal by R.Axelrod           **
'**    Implemented in Visual Basic by Sandeep Kumar **
'** Title of Prog: Axelrod's Cultural Demonstration **
'** Description:   See "Cultural Demo Documentation"**
'**                for details                      **
'**                Allows only 4 neigbors           **
'**                Allows maximum of 20x20 territory**
'** Version:       Version # 1                      **
'** Date:          12/21/95                         **
'*****************************************************

'Declare Options
Option Explicit           'report error on encontering undeclared 
variable

'Control Constants
Const Version = 1         'Program Version Number
Const old_random_seed = 0 '0 means new seed, else enter an old 
seed to reuse
Const cyclemax = 200      'number of cycles(events) in each reporting 
period
                          'cycle is one active actor
Const periodmax = 10      'number of periods of cyclemax each
Const popmax = 1          'number of populations, each with 
cyclemax*periodmax active actors
Const write_cultures = True 'if true, report each individual's culture 
each period
Const write_distances = True 'if true report each cultural distance 
between adjacent sites
 
'Input Parameters
Const Xmax = 5            'Size of land, west to east
Const Ymax = 5            'Size of land, north to south
Const bitmax = 5          'Traits. Size of chromosome, i.ee. no. of bits 
in indiv's culture
Const allelemax = 10      'Number of traits per feature



'Variables
Dim Row_Index As Integer 'current row position of display
Dim Today As Date        'use to report the starting time of run
Dim Finish As Date       'to report the time at end of run
Dim random_seed As Integer 'used for generating a new seed
Dim pop As Integer         'current  population number, 1..popmax
Dim period As Integer      'current period number, 1..periodmax
Dim cycle As Integer       'current cycle, i.e active indiv, 1..cyclemax
Dim ix As Integer          'x coordinate of current active individual
Dim iy As Integer          'y coordinate of current active individual
Dim jx As Integer          'x coordinate of neigbor, 0..xmax+1
Dim jy As Integer          'y coordinate of neigbor, 0..ymax+1
Dim culture(0 To 21, 0 To 21, 1 To bitmax) As Integer 'culture of 
ix,iy,bit-an integer
    '-1 for beyond border, or 0 or 1 for indiv's culture
    'x = 0 is beyond internal left border, x = xmax+1 is beyond rt. 
border, etc
    'this allows indiv's on internal border to get automatic non-
matches with illegal neighbors
            
Dim xmove(1 To 4), ymove(1 To 4) As Integer  'jointly defines North, 
East, West, South direction
Dim bit As Integer           'the current bit of the culture
Dim neigbor As Integer       'neighbor, 1 to 4
Dim direction As Integer     '4 neighbors, north, s, e, w order
Dim event As Integer         'cumulative count  of events in this pop
Dim changes_this_period As Integer  'count of changes in this period

'*****************************************************
***********
'** generates a random integer between 1 and n inclusive       **
'*****************************************************
***********
Function random_one_to_n(n As Integer) As Integer
    random_one_to_n = Int((n * Rnd) + 1)
End Function

'*****************************************************
***********
'** generates a different initial seed using in-built timer    **
'*****************************************************
***********
Sub set_random_seed()
    If old_random_seed = 0 Then
        Randomize
    End If
End Sub

'*****************************************************
***********
'** initializes the program and display program information    **
'*****************************************************
***********
Sub Initialize_run()
    Dim x, y, bit As Integer
    
    Row_Index = 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = 
"Axelrod's Cultural Program, coded in VBasic by Sandeep Kumar. 
Version: " & Version & "."
    Today = Now
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "   This 
run begun on " & Today & "."
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "  " & 
cyclemax & " cycles in each reporting period"
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "  " & 
periodmax & " periods in each population"
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "  " & 
popmax & " population"
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "  " & 
Xmax & " width of land, east to west (number of cols.)"
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "  " & 
Ymax & " width of land, north to south (number of rows)"
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "  " & 
bitmax & " traits in culture string"
    Row_Index = Row_Index + 1
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "  " & 
allelemax & " features per trait"
    
    set_random_seed
    Row_Index = Row_Index + 2
    For x = 1 To Xmax    'initialize ind's beyond the internal borders. 
Never changes.
     For bit = 1 To bitmax
        culture(x, 0, bit) = -1      'initial culture for beyond top internal 
border
        culture(x, Ymax + 1, bit) = -1 'initial culture for beyond bottom 
internal
     Next bit
    Next x
    
    For y = 1 To Ymax   'initialize indiv's beyond the internal borders. 
Never changes.
     For bit = 1 To bitmax
        culture(0, y, bit) = -1         'initial culture for beyond left 
internal border
        culture(Xmax + 1, y, bit) = -1  'initial for beyond right internal 
border
     Next bit
    Next y
    
    xmove(1) = 0                    'define North, in seeking neighbors
    ymove(1) = -1
    xmove(2) = 1                    'define East
    ymove(2) = 0
    xmove(3) = -1                   'define West
    ymove(3) = 0
    xmove(4) = 0                    'define South
    ymove(4) = 1

End Sub

'*****************************************************
*****************
'** subroutine: causes two actors to interact culturally if possible 
**
'*****************************************************
*****************
Sub interact()                          'i converges one bit to j if possible
    Dim try_another_bit As Boolean      'control on whether still 
searching for another bit that differs
    Dim bit_count As Integer            'count so as to give up when all 
bit tried, ie x=y
    Dim bit_try As Integer              'bit being tried looking for 
dissimilarity
    
    bit_try = random_one_to_n(bitmax)         'initial bit location tried
    try_another_bit = True
    
    bit_count = 1
    
    Do
     If culture(ix, iy, bit_try) <> culture(jx, jy, bit_try) Then
        culture(ix, iy, bit_try) = culture(jx, jy, bit_try) 'i converges 
since unequal on current bit
        changes_this_period = changes_this_period + 1       'a change 
took place
        try_another_bit = False                             ' done with search
     Else
        bit_count = bit_count + 1
        bit_try = (bit_try + 1) Mod bitmax + 1
        If bit_count > bitmax Then                          'give up because just 
tried all bits
            try_another_bit = False
            
        End If
     End If
    Loop Until try_another_bit = False
End Sub

'*****************************************************
*****************
'** subroutine:                                                      **
'*****************************************************
*****************
Sub Report_Cultures()                       'from output_period procedure
    Dim xtemp, ytemp, bit_temp As Integer
    Dim Column_Index As Integer             'current column of display
    
    For ytemp = 1 To Ymax
     Column_Index = 5
     Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "y=" & 
ytemp & ".  Culture := "
        For xtemp = 1 To Xmax
            For bit_temp = 1 To bitmax
                Worksheets("Culture_Output").Cells(Row_Index, 
Column_Index).Value = "" & culture(xtemp, ytemp, bit_temp)
                Column_Index = Column_Index + 1
            Next bit_temp
        Column_Index = Column_Index + 1     'space between individuals
        Next xtemp
        Row_Index = Row_Index + 1
    Next ytemp
End Sub

'*****************************************************
*****************
'** subroutine:calculates and displays the distance between actors   
**
'*****************************************************
*****************
Sub Calc_and_Report_Distance()              'cultural distances with 
output
    Dim xtemp, ytemp, ytemp1 As Integer             'geo location
    Dim itemp As Integer                    'bit position
    Dim X_distance(1 To Xmax) As Integer    'cultural distance 
between (x,y) to (x+1,y), ie to right
    Dim Y_distance(1 To Xmax) As Integer    'cultural distance 
between (x,y) to (x,y+1), ie down
    Dim Column_Index As Integer
    
    Column_Index = 6
    

    For ytemp = 1 To Ymax
        
        For xtemp = 1 To Xmax
            X_distance(xtemp) = 0            'calcs will be for one row at a 
time
            Y_distance(xtemp) = 0
                    
            For itemp = 1 To bitmax          'increment distance on x axis, 
then y axis
             If xtemp < Xmax Then            'to avoid going off right side
               If culture(xtemp, ytemp, itemp) <> culture(xtemp + 1, 
ytemp, itemp) Then
                X_distance(xtemp) = X_distance(xtemp) + 1
               End If
             End If
             If ytemp < Ymax Then          'only do down calcs if not last 
row
                If culture(xtemp, ytemp, itemp) <> culture(xtemp, ytemp + 
1, itemp) Then
                    Y_distance(xtemp) = Y_distance(xtemp) + 1
                End If                      'if not last row
             End If
            Next itemp                        'itemp loop for culture bits
                
        Next xtemp                            'xtemp loop for calc distance
    
        If write_distances = True Then
            Column_Index = 7
            Worksheets("Culture_Output").Cells(Row_Index, 1).Value = 
"y= " & ytemp & ". Dis across: "
            For xtemp = 1 To Xmax - 1         'write row for across 
distances
             Worksheets("Culture_Output").Cells(Row_Index, 
Column_Index).Value = "" & X_distance(xtemp)
             Column_Index = Column_Index + 2
            Next xtemp                        'xtemp for writing row for across 
distances
            Row_Index = Row_Index + 1
            Column_Index = 6
            If (ytemp < Ymax) Then
            Worksheets("Culture_Output").Cells(Row_Index, 1).Value = 
"y= " & ytemp & ". Dis down:"
            End If
            If (ytemp < Ymax) Then
                For xtemp = 1 To Xmax                 'write row for distances 
down, only if not last row
                Worksheets("Culture_Output").Cells(Row_Index, 
Column_Index).Value = "" & Y_distance(xtemp)
                Column_Index = Column_Index + 2
                Next xtemp                            'xtemp for writing row for  
distances down
                Row_Index = Row_Index + 1
            End If                                 'if not last row
                
       End If
     Next ytemp

    Row_Index = Row_Index + 1
End Sub


'*****************************************************
*****************
'** subroutine:                                                      **
'*****************************************************
*****************
Sub Periodic_Output()
    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "Event      
" & event & ".   Changes this period         " & changes_this_period & "."
    Row_Index = Row_Index + 1
    If write_cultures = True Then
        Report_Cultures               'first output of a period
        Row_Index = Row_Index + 1
    End If
    Calc_and_Report_Distance          'second output of a period
End Sub

'*****************************************************
*****************
'** subroutine:                                                      **
'*****************************************************
*****************
Sub Initialize_pop()
    Dim x, y  As Integer     'local variable for coord of an individual
    Dim bit As Integer       'local variable for number of gene on the 
cultural chormosome

    Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "Pop    " 
& pop & ":"
    Row_Index = Row_Index + 1
    
    For x = 1 To Xmax
        For y = 1 To Ymax
          For bit = 1 To bitmax
            culture(x, y, bit) = random_one_to_n(allelemax) - 1 'initial 
culture for internal places
          Next bit
        Next y
    Next x
    
    changes_this_period = 0  'Needed here for pop >1
    Periodic_Output

End Sub

'*****************************************************
*****************
'** subroutine:                                                      **
'*****************************************************
*****************
Sub Output_Run()             'Output for run - last thing written
 Dim duration As Date
 Dim Seconds
 
 Finish = Now
 duration = Finish - Today
 Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "The 
program ended at: " & Finish
 Row_Index = Row_Index + 1
 Worksheets("Culture_Output").Cells(Row_Index, 1).Value = "Duration 
of this run is " & duration
 Row_Index = Row_Index + 1
 Seconds = Second(duration)
 'Worksheets("Culture_Output").Cells(Row_Index, 1).Value = 
"Duration of this run is " & Seconds & " secs. "
 'Row_Index = Row_Index + 1
End Sub

'*****************************************************
*****************
'**              M A I  N         P R O G R A M                      **
'*****************************************************
*****************
Sub main()

    Worksheets("Culture_Output").Activate
    Range(Cells(1, 1), Cells(300, 40)).ClearContents
    Range(Cells(1, 1), Cells(100, 40)).ColumnWidth = 2
    Initialize_run                 'initialize whole run

    For pop = 1 To popmax
      event = 0                     'count of events in this pop
      Initialize_pop                'INITIALIZE current population
        For period = 1 To periodmax 'REPORTING PERIOD
         changes_this_period = 0    'count of changes in this period
            For cycle = 1 To cyclemax       'CYCLE of one active actor
                event = event + 1           'every cycle is an event
                ix = random_one_to_n(Xmax)  'select X coord of active 
actor
                iy = random_one_to_n(Ymax)  'select Y coord of active 
actor
                bit = random_one_to_n(bitmax)     'first bit to be checked 
for match
                Do                                             'get an internal direction
                    direction = random_one_to_n(4)             'select one of 
four directions for interaction
                    jx = ix + xmove(direction)                  'calc coords of 
selected neighbor
                    jy = iy + ymove(direction)
                        
                Loop Until culture(jx, jy, bit) <> -1          'check not gotten 
a neighbor outside of region
                If (culture(ix, iy, bit) = culture(jx, jy, bit)) Then  'match on 
selected bit
                    interact                                          'including count if a 
change occured
                End If
            Next cycle
                
         Periodic_Output
        Next period
            
    Next pop
   Output_Run                     'output of the run

End Sub