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