program CultureDemo1; {Axelrod's Cultural Demonstration Program} { begun 10/17/95 for PS 794} {See "Cultural Demo Documentation" for details} {Ver1, begun 10/17/95} { Allows only 4 neigbhors} { Allows maximum of 20x20 territory} const {control constants} Version = 1; {Program Version Number} old_random_seed = 0; {0 means new seed, else enter an old seed to reuse} cyclemax = 200; {number of cycles[events] in each reporting period. Cylce is one active actor.} periodmax = 10; {number of periods of cyclemax each.} popmax = 1; {number of populations, each with cyclemax*periodmax active actors} write_cultures = True; {if true, report each individual's culture each period} write_distances = True; {if true, report cultureal distance between adjacent sites} {input parameters} Xmax = 5; {Size of land, west to east.} Ymax = 5; {Size of land, north to south.} bitmax = 5; {Traits. Size of chromosome, i.e. number of bits in indiv's culture. } allelemax = 10; {Number of traits per feature} type x_type = 1..xmax; {range of indiv's x coord} y_type = 1..ymax; {range of indiv's y coord} bit_type = 1..bitmax; {bit on culture} culture_array = array[0..21, 0..21, 1..bitmax] of integer; {for x, y,bit} {max actual geography is 20x20} direction_type = 1..4; {4 neighbors; north, s, e, w order} direction_array = array[1..4] of integer; {for x and y moves} var initial_datetime, end_datetime: datetimerec; {date, etc.} initial_hour, end_hour: longint; start_time, end_time, duration: longint; {for calc of run's duration} random_seed: integer; pop: integer; {current population number, 1...popmax} period: integer; {current period number, 1..periodmax} cycle: integer; {current cycle (ie active indiv), 1..cyclemax} ix: x_type; {x coordinate of current active individual} iy: y_type; {y coordinate of current active individual} jx: integer; {x coord of a neighbor, 0..xmax+1} jy: integer; {y coord of a neighbor, 0..ymax+1} culture: culture_array; {culture of ix,iy,bit - an integer variable} {-1 for beyond bord, or 0 or 1 for internal indiv's culture} {x=0 is beyond internal left border, x=xmax+1 is beyond right border, etc.} {This allows indivs on internal border to get automatic non-matches with illegal neighbors} xmove, ymove: direction_array; {jointly defines North, East, West, South direction} bit: bit_type; {the current bit of the culture} neighbor: direction_type; {neighbor, 1 to 4} direction: direction_type; {4 neighbors; north, s, e, w order} event: integer; {cumulative count of events in this pop} changes_this_period: integer; {count of changes in this period} { --------------------------------------------------------------- } function random_one_to_n (n: longint): longint; {Same as in Tipping4 Program} {proc returns a random number between 1 and n; modified from Bennett's random_range} var ub, lb: integer; r: integer; begin {random gives # betw -32768 and 32767} ub := 32767 - (32767 mod n); lb := -32768 - (-32768 mod n); {truncate distrib on 2 ends so that later mod is OK} repeat r := random; 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 set_random_seed; {Same as in Tipping4 Program} 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;} { --------------------------------------------------------------- } procedure Initialize_run; var x, y, bit: integer; begin gettime(initial_datetime); initial_hour := initial_datetime.hour; {to force long int} start_time := 60 * 60 * initial_hour + 60 * initial_datetime.minute + initial_datetime.second; Writeln('Axelrod''s Cultural Demo Program, Version ', Version : 4); Write(' This run begun on ', initial_datetime.month : 2, '/', initial_datetime.day : 2); Writeln('/', initial_datetime.year : 4, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, '.'); Writeln(cyclemax : 5, ' cycles in each reporting period'); Writeln(periodmax : 5, ' periods in each population'); Writeln(popmax : 5, ' population'); Writeln(xmax : 5, ' width of land, east to west (number of cols.)'); Writeln(ymax : 5, ' width of land, north to south (number of rows)'); Writeln(bitmax : 5, ' traits in culture string'); Writeln(allelemax : 5, ' features per trait'); set_random_seed; writeln; for x := 1 to xmax do {initialize ind's beyond the internal borders. Never changes.} begin for bit := 1 to bitmax do begin culture[x, 0, bit] := -1; {initial culture for beyond top internal border} culture[x, ymax + 1, bit] := -1; {initial culture for beyond bottom internal } end; end; {x} for y := 1 to ymax do {initialize indiv's beyond the internal borders. Never changes.} begin for bit := 1 to bitmax do begin culture[0, y, bit] := -1; {initial culture for beyond left internal border} culture[Xmax + 1, y, bit] := -1; {initial for beyond right internal border} end; end;{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; {initialize run procedure} { --------------------------------------------------------------- } procedure interact; {i converges one bit to j if possible} var try_another_bit: boolean; {control on whether still searching for another bit that differs} bit_count: integer; {count so as to give up when all bit tried, ie x=y} bit_try: integer; {bit being tried looking for dissimilarity} begin bit_try := random_one_to_n(bitmax); {initial bit location tried} try_another_bit := true; bit_count := 1; repeat if culture[ix, iy, bit_try] <> culture[jx, jy, bit_try] then begin 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 } end else begin 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; until try_another_bit = false; end;{interact procedure} { --------------------------------------------------------------- } procedure Report_Cultures; {from output_period procedure} var {reports first five bits of culture} xtemp, ytemp: integer; bit_temp: integer; begin for ytemp := 1 to ymax do begin write(' y=', ytemp : 3, '. Culture = '); for xtemp := 1 to xmax do begin for bit_temp := 1 to bitmax do begin write(culture[xtemp, ytemp, bit_temp] : 1); end;{bit_temp} write(' '); {space between individuals} end;{ixtemp} writeln; end; {iytemp} end; { --------------------------------------------------------------- } procedure Calc_and_Report_Distance; {cultural distances with output} type row_array = array[1..xmax] of integer; {for output of distances} var xtemp, ytemp: integer; {geo loc} itemp: integer; {bit position} X_distance: row_array; {cultural distance between (x,y) to (x+1,y), ie to right } Y_distance: row_array; {cultural distance between (x,y) to (x,y+1), ie down } begin for ytemp := 1 to ymax do begin for xtemp := 1 to xmax do begin X_distance[xtemp] := 0; {calcs will be for one row at a time} Y_distance[xtemp] := 0; for itemp := 1 to bitmax do begin {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; if (ytemp < ymax) then {only do down calcs if not last row} begin if (culture[xtemp, ytemp, itemp] <> culture[xtemp, ytemp + 1, itemp]) then Y_distance[xtemp] := Y_distance[xtemp] + 1 end; {if not last row} end; {itemp loop for culture bits} end; {xtemp loop for calc distances} if write_distances then begin write('y= ', ytemp : 3, '. Dis across: '); for xtemp := 1 to xmax - 1 do begin {write row for across distances} write(' ', X_distance[xtemp] : 3); end; {xtemp for writing row for across distances} writeln; if (ytemp < ymax) then write('y= ', ytemp : 3, '. Dis down: '); if (ytemp < ymax) then begin for xtemp := 1 to xmax do begin {write row for distances down, only if not last row} write(' ', Y_distance[xtemp] : 3); end; {xtemp for writing row for distances down} writeln; end; {if not last row} end;{if write_distances} end;{ytemp} writeln; end; { --------------------------------------------------------------- } procedure Periodic_Output; begin writeln('Event', event : 5, '. Changes this period', changes_this_period : 5, '.'); if write_cultures then Report_Cultures; {first output of a period} Calc_and_Report_Distance; {second output of a period} end; { --------------------------------------------------------------- } procedure Initialize_pop; var x, y: integer; {local variable for coord of an individual} bit: integer; {local variable for number of gene on the cultrual chormosome} begin writeln('Pop ', pop : 3, ':'); for x := 1 to xmax do begin for y := 1 to ymax do begin for bit := 1 to bitmax do begin culture[x, y, bit] := Random_One_to_N(allelemax) - 1; {initial culture for internal places} end; end; end; {x loop} changes_this_period := 0; {Needed here for pop >1} Periodic_Output; end; {initialize_pop procedure} { --------------------------------------------------------------- } procedure Output_Run; {Output for run - last thing written} begin gettime(end_datetime); end_hour := end_datetime.hour; {to force long interger} end_time := 60 * 60 * end_hour + 60 * end_datetime.minute + end_datetime.second; duration := end_time - start_time; Writeln('Duration of this run is ', duration : 5, ' seconds.'); end; { --------------------------------------------------------------- } {- - - - - - - - - - - - - - - - - ----------------- - - - - - - - - - - - - - - - - } { --------------------------------------------------------------- } {M A I N P R O G R A M } begin initialize_run; {initialize whole run} for pop := 1 to popmax do begin event := 0; {count of events in this pop} Initialize_pop; {INITIALIZE current population} for period := 1 to periodmax do {REPORTING PERIOD } begin changes_this_period := 0; {count of changes in this period} for cycle := 1 to cyclemax do {CYCLE of one active actor} begin 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} repeat {get an internal direction} direction := random_one_to_n(4); {select one of four directions for interaction} jx := ix + xmove[direction]; {cacl coords of selected neighbor} jy := iy + ymove[direction] 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; { cycle of one active } Periodic_Output; end;{pop cycle} end; {run} Output_Run; {output of the run} end.{main program}
University of Michigan Center for the Study of Complex Systems
Contact cscs@umich.edu.
Revised November 4, 1996.