program Tribute40;
{Ver0.1 begun 10/21/92, Ver 2.0 begun 12/21/92, Ver 3.0 begun 1/13/93}
{Documemtion in Act 66}
{v3.0 Loyalty}
{v3.1 Contiguous alliances, eliminate range of tribute}
{ Event_Output for report_person }
{v3.2 bombs}
{v3.3 Loyalty periodic output, built on v3.1old}
{ 2/11 after run 23: move calc_alliance from conduct_fight to make_response to correct w_def}
{v3.4 bombs}
{v3.5 add B5, toughness, }
{ 2/12 fix div 0 bug in A2 and A3}
{v3.6 add contiguity=false option to avoid requiring contiguity of alliances}
{v3.7 add loyalty_option for who may increase loyalty: 0=all, 1=either rare, 2=neither rare }
{v3.8 add A4 rule: demand of random other (for checking loyalty only variant)}
{ add zero_init_loyalty: T=Loy(ij)=0 initally as before, F=random initial loyalties}
{ add B6 pay or fight at random}
{v4.0 add tribute counts in final_output and trib_output}
{ add more initial loyalty options }
const
Version = 4.0; {Program Version Number}
test = false; {if test=true, no run_number is read or written.}
{Run # is set to 0 for test=true runs}
Common_rule_A = 2; {rare rule occurs once, common rule elsewhere: A is demander}
{ A1=att weakest alliance, A2=max value*vulnerabilty, A3 is mod A2}
{ A4 demand of random (reachable) other}
Common_rule_B = 4; {B is defender's response}
{ B1=never pay, B2=always pay, B3=pay if cheaper for self, B4, fight if cheaper for self}
{ B5= pay if fight_cost > toughness*payment}
Rare_rule_A = 2; {Rare rules used only for non-adaptive pops}
Rare_rule_B = 4;
Year_max = 100; {number of years in a run, often 100 or 1000}
pop_max = 10; {number of populations in a run, usually 50 when adapt=false}
Report_Person = 5; {Usually 5. Report events when person=i,j,aider or helper; no report if = 0}
old_random_seed = 0; {0 means new seed, else enter an old seed to reuse}
periodic_report_freq = 25; {0 means never, 1 means each year, 10 means every 10th yr, etc.}
contiguity = true; {T=contiguity required of alliances, F= contiguity not required}
loyalty_option = 0; {who may increase loyalty: 0=all, 1=either rare, 2=neither rare}
init_loyalty = 3; {0:loyalty_pc(i,j)=0 initially as before, 1:random; for i<>j}
{ 2: 0 but L (4,5) = 10%, 3: 0 but L(3,5)=10%}
{Rarely changed constants: }
triangle_initial_wealth = false; {T=old method, F= W_base + or - 100}
Common_rule_C = 1; {C not used: retained for later expansion}
Common_rule_D = 1; {D not used: retained for later expansion}
Rare_rule_C = 1; {C not used: retained for later expansion}
Rare_rule_D = 1; {D not used: retained for later expansion}
rare_indiv = 5; {placement of rare indiv in the pop, eg at i=5. }
adapt = false; {T=each pop adapts from prev pop, F= pops stay same}
Run_Number_File_Name = 'Run Number File';
Imax = 10; {number of actors/pop; 10 for experiment}
Demand_phase_max = 3; {number of possible demands / year; usually 3 when imax=10}
W_base = 400.0; {basic initial wealth, often 400.0}
Standard_Demand = 250.0; {demand, often 250.0}
Destructiveness = 0.25; {% other's wealth lost in a fight, often 0.25}
Allele_Max = 6; {no. of possible rules(alleles) of each type(gene)= max of max_allele}
Gene_Max = 2; {number of genes, ie A,B,gives 2}
mutatable_gene_max = 2; {0 means all, n means only first n genes can mutate: in Set_Rare_Rule}
toughness = 1.5; {used in B5. If 1.0 then B5=B3.}
loyalty_pc_increment = 10; {change in % loyalty with tribute or fight, should be divisible by 100}
report_rebellion = false; {whether to report potential rebellions in Conduct_Fight}
type
actor_type = 1..imax;
gene_type = 1..4; {4 genes: A, B, C , D - but C and D are inactive, need for chrom}
actor_array = array[actor_type] of real;
bool_actor_array = array[actor_type] of boolean;
distance_array = array[actor_type] of 0..imax;
chrom_type = array[actor_type, gene_type] of 1..Allele_Max;
offset_type = -imax..imax; {offset of target from i}
max_allele_type = array[1..9] of integer; {number of possible alleles of a given gene}
loyalty_pc_type = array[actor_type, actor_type] of 0..100; {Loyalty of i to j in percentag}
integer_maxtrix_type = array[actor_type, actor_type] of integer; {for tribute counts}
var
initial_datetime, end_datetime: datetimerec; {date, etc.}
run_number: integer;
datafile: text; {input data}
i, j: actor_type; {index of actors}
Productivity: actor_array; {actors' productiivty}
W: actor_array; {actor's Wealth, current}
W_initial: actor_array; { initial wealth}
W_if_isolated: actor_array; { wealth if isolated, current, ie only productivity changes}
Demand: real; {demand being made by i on j}
demand_phase: integer; {current demand phase}
year: integer; {current year}
income: real; {income from production}
decide_to_demand: boolean; {False=no demand, True=i Demands from j}
Agree_To_Pay: boolean; {False=no pay, True= j will pay i}
tribute: real; {Tribute paid by j to i}
final_wealth: text; {Output of final wealth file, for Excel}
periodic_wealth: text; {Output of periodic wealth file, for Excel}
periodic_loyalty: text; {Output of periodic loyalty file, for Excel}
adapt_wealth: text; {Output of adaptation wealth file, for Excel, if adapt=true}
invaders_wealth: text; {Output of invaders' wealth file, for Excel, if adapt=true}
event_wealth: text; {Output of events involving the report_person}
periodic_trib: text; {Output of count of per. tribute count matrix}
random_seed: integer;
Chrom: chrom_type; {e.g. chrom[i,1]=3 means i uses A3}
rare: bool_actor_array; {T=actor is rare type, F=actor is common type}
offset_target: offset_type; {location of target relative to i}
pop: integer; {current pop number}
w_att: real; {wealth available for an attack}
w_def: real; {Wealth available for a defense}
pop_wealth: real; {total current wealth of the population}
fights_since_last_report: integer; {num fights since the last periodic report}
years_since_last_report: integer; {num years since last periodic report}
max_allele: max_allele_type; {number of alleles of a given gene}
common_rule_label, rare_rule_label: integer; {for output}
common_indiv: actor_type; {loc of a common indiv, set to be rare_indiv+1}
start_time, end_time, duration: longint; {for calc of run's duration}
initial_hour, end_hour: longint;
invaders_so_far: integer; {numer of invaders so far,when adapt=true}
duration_since_invasion: integer; {number of pops since last invasion}
loyalty_pc: loyalty_pc_type; {loyalty of i to j, percentage between 0 and 100}
aid_att: bool_actor_array; {T if k aids attacker}
help_def: bool_actor_array; {T if k helps defender}
j_temp_reachable: boolean; {T if this j_temp would be reachable from i}
trib_count: integer_maxtrix_type; {# payments from row to col }
trib_periodic_count: integer_maxtrix_type; {# payments from row to col in current period}
{ --------------------------------------------------------------- }
function min (x, y: real): real;
begin
if x < y then
min := x
else
min := y;
end;
{ --------------------------------------------------------------- }
function min_integer (x, y: integer): integer;
begin
if x < y then
min_integer := x
else
min_integer := y;
end;
{ --------------------------------------------------------------- }
function random_one_to_n (n: longint): longint;
{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 Report_Periodic_Output;
var
i, j: actor_type;
begin
pop_wealth := 0;
for i := 1 to imax do
pop_wealth := pop_wealth + W[i];
write(periodic_wealth, pop : 3, ' ', year : 3, ' ', fights_since_last_report : 5, ' ', pop_wealth : 6 : 1, ' ');
write(periodic_wealth, w[1] : 6 : 1, ' ', w[2] : 6 : 1, ' ', w[3] : 6 : 1, ' ', w[4] : 6 : 1, ' ', w[5] : 6 : 1, ' ', w[6] : 6 : 1, ' ');
writeln(periodic_wealth, w[7] : 6 : 1, ' ', w[8] : 6 : 1, ' ', w[9] : 6 : 1, ' ', w[10] : 6 : 1);
for i := 1 to imax do {Loyalty matrix first}
begin{do row as outer loop}
write(periodic_loyalty, pop : 4, ' ', year : 4, ' ', w[i] : 6 : 1, ' ', i : 4, ' ');
for j := 1 to imax do
begin
write(periodic_loyalty, loyalty_pc[i, j] : 4, ' ');
if j = imax then
writeln(periodic_loyalty);
end;{j}
if i = imax then
writeln(periodic_loyalty);
end;{i}
fights_since_last_report := 0; {reset for interval to next periodic report}
years_since_last_report := 0; {ditto}
if year > 0 then {Triubte maxtix next}
begin
for i := 1 to imax do {do row as outer loop}
begin
write(periodic_trib, pop : 4, ' ', year : 4, ' ', w[i] : 6 : 1, ' ', i : 4, ' ');
for j := 1 to imax do
begin
write(periodic_trib, trib_periodic_count[i, j] : 4, ' '); {i,j is ok here}
trib_periodic_count[i, j] := 0; {immeidate re-initialize}
if j = imax then
writeln(periodic_trib);
end;{j}
if i = imax then
writeln(periodic_trib);
end;{i}
end;{year>0}
end;
{ --------------------------------------------------------------- }
procedure make_person_report;
{Report whenever Report_person indiv is role A, B, aider of attacker, helper of defender}
{From Make_Payment and Conduct_Fight}
type
report_string_type = packed array[1..imax] of char;
var
report_string: report_string_type;
k: actor_type;
begin
if Agree_to_Pay then
begin {if tribute was paid}
for k := 1 to imax do
begin
report_string[k] := '-'; {set to . if nothing applies}
if k = i then
report_string[k] := 'R'; {R for receiver of tribute}
if k = j then
report_string[k] := 'P'; {P for payor of tribute}
end;
end{if tribute was paid}
else
begin
for k := 1 to imax do {if fight}
begin
report_string[k] := '-'; {set to . if nothing applies}
if aid_att[k] then
report_string[k] := 'a'; {a for aid attacker}
if help_def[k] then
report_string[k] := 'd'; {d for help defender}
if k = i then
report_string[k] := 'A'; {A for attacker}
if k = j then
report_string[k] := 'D'; {D for defender}
end;{fight}
end;{if Agree_to_Pay}
write(event_wealth, pop : 3, ' ', year : 3, ' ', i : 3, ' ', j : 3, ' ', report_string : 12, ' ');
write(event_wealth, w[1] : 6 : 1, ' ', w[2] : 6 : 1, ' ', w[3] : 6 : 1, ' ', w[4] : 6 : 1, ' ', w[5] : 6 : 1, ' ', w[6] : 6 : 1, ' ');
writeln(event_wealth, w[7] : 6 : 1, ' ', w[8] : 6 : 1, ' ', w[9] : 6 : 1, ' ', w[10] : 6 : 1);
end;
{ --------------------------------------------------------------- }
procedure Write_Adapt_and_Invaders_Headers;
begin
Write(adapt_wealth, ' Run ', Run_number : 4, '. Ver ', Version : 4 : 2, ' of ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Writeln(adapt_wealth, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, ' ');
Writeln(adapt_wealth, common_rule_label : 5, ' Initial common rule: A, B, C, D');
Writeln(adapt_wealth, toughness : 7 : 2, ' toughness');
Writeln(adapt_wealth, pop_max : 3, ' pops');
Writeln(adapt_wealth, year_max : 3, ' years / pop ');
Writeln(adapt_wealth, imax : 3, ' indivs / pop ');
Writeln(adapt_wealth, demand_phase_max : 3, ' demands/year');
Writeln(adapt_wealth, W_base : 7 : 2, ' initial wealth');
Writeln(adapt_wealth, standard_demand : 7 : 2, ' standard demand');
Writeln(adapt_wealth, destructiveness : 7 : 2, ' destructiveness');
Writeln(adapt_wealth, loyalty_pc_increment : 7, ' loyalty % increment');
if mutatable_gene_max > 0 then
writeln(adapt_wealth, mutatable_gene_max : 3, ' initial genes eligible for mutation')
else
writeln(adapt_wealth, ' All genes eligible for mutation');
writeln(adapt_wealth);
Writeln(adapt_wealth, 'Col A: Population number.');
Writeln(adapt_wealth, 'Col B-E , Common Rule ');
Writeln(adapt_wealth, 'Col F-I: Rare Rule.');
Writeln(adapt_wealth, 'Col J, K: Ave Common Wealth, Rare'' s Wealth ');
Writeln(adapt_wealth, 'Col L: 1 if rare invades, 0 if not');
Writeln(adapt_wealth, 'Col M, N : Ave Common Range , Rare'' s Range');
Writeln(adapt_wealth, 'Col O, P: % Common that did better than if isolated, same for rare.');
writeln(adapt_wealth);
Writeln(adapt_wealth, 'pop cA cB cC cD rA rB rC rD AvComW RareW Inv? C(L+R) R(L+R) C%>isoW R>isoW');
Write(invaders_wealth, ' Run ', Run_number : 4, '. Ver ', Version : 4 : 2, ' of ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Writeln(invaders_wealth, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, ' ');
Writeln(invaders_wealth, common_rule_label : 5, ' Initial common rule: A, B, C, D');
Writeln(invaders_wealth, toughness : 7 : 2, ' toughness');
Writeln(invaders_wealth, pop_max : 3, ' pops');
Writeln(invaders_wealth, year_max : 3, ' years / pop ');
Writeln(invaders_wealth, imax : 3, ' indivs / pop ');
Writeln(invaders_wealth, demand_phase_max : 3, ' demands/year');
Writeln(invaders_wealth, W_base : 7 : 2, ' initial wealth');
Writeln(invaders_wealth, standard_demand : 7 : 2, ' standard demand');
Writeln(invaders_wealth, destructiveness : 7 : 2, ' destructiveness');
Writeln(invaders_wealth, loyalty_pc_increment : 7, ' loyalty % increment');
if mutatable_gene_max > 0 then
writeln(invaders_wealth, mutatable_gene_max : 3, ' initial genes eligible for mutation')
else
writeln(invaders_wealth, ' All genes eligible for mutation');
writeln(invaders_wealth);
writeln(invaders_wealth, 'Col A: Invaders so far.');
writeln(invaders_wealth, 'Col B: Duration, i.e. pops since last invasion.');
Writeln(invaders_wealth, 'Col C: Population number.');
Writeln(invaders_wealth, 'Col D-G , Common Rule ');
Writeln(invaders_wealth, 'Col H-K: Rare Rule.');
Writeln(invaders_wealth, 'Col L, M: Ave Common Wealth, Rare'' s Wealth ');
Writeln(invaders_wealth, 'Col N, O: Ave Common Range , Rare'' s Range');
Writeln(invaders_wealth, 'Col P, Q: % Common that did better than if isolated, same for rare.');
writeln(invaders_wealth);
Writeln(invaders_wealth, 'inv dur pop cA cB cC cD rA rB rC rD AvComW RareW C(L+R) R(L+R) C%>isoW R>isoW');
end;{Write_Adapt_and_Invaders_Headers}
{ --------------------------------------------------------------- }
procedure Initialize_run;
var
i: actor_type;
begin
max_allele[1] := 3; {number of possible alleles of gene 1, ie A}
max_allele[2] := 5; {number of possible alleles of gene 2, ie B}
max_allele[3] := 1; {number of possible alleles of gene 3, ie C}
max_allele[4] := 1; {number of possible alleles of gene 4, ie D}
if rare_indiv >= imax then
begin
writeln('Warning. Fatal error: rare_indiv may not be last indiv, ie imax');
halt;
end;
common_indiv := rare_indiv + 1; {the location of a common indiv, for copying its chrom}
rewrite(final_wealth, 'Final_Output'); {open output of final wealth file for writing to Excel}
rewrite(periodic_wealth, 'Periodic_Output'); {open output of periodic wealth file for writing to Excel}
rewrite(periodic_loyalty, 'Loyalty_Output'); {open output of periodic loyalty file for writing to Excel}
rewrite(periodic_trib, 'Tribute_Output'); {open output of periodic tribute file for writing to Excel}
if adapt = true then
begin
invaders_so_far := 0;
duration_since_invasion := 0;
rewrite(adapt_wealth, 'Adapt_Output'); {open output of adapt wealth file for writing to Excel}
rewrite(invaders_wealth, 'Invader_Output'); {open output of invaders wealth file for writing to Excel}
end;
if report_person <> 0 then
begin
rewrite(event_wealth, 'Event_Output'); {open output of event wealth for file for writing to Excel}
{XXXX write header here?}
end;{report_person<>0}
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('Output of Axelrod''s Tribute Program, Version ', Version : 5 : 2);
Write(' This run begun on ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Write('/', initial_datetime.year : 4, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, '.');
if old_random_seed = 0 then
begin {generate new seed}
random_seed := initial_datetime.hour + initial_datetime.minute + initial_datetime.second + (initial_datetime.second * 300) + (initial_datetime.minute * initial_datetime.hour) + (initial_datetime.minute * initial_datetime.second);
randseed := random_seed;
Writeln(' New random seed ', randseed : 6, '.');
Writeln(final_wealth, 'Tribute Program. Final Output.', ' New random seed', randseed : 8, '.');
if periodic_report_freq <> 0 then
begin
Writeln(periodic_wealth, 'Tribute Program, Periodic Output. ', ' New random seed', randseed : 8, '.');
Writeln(periodic_loyalty, 'Tribute Program, Loyalty Output. ', ' New random seed', randseed : 8, '.');
Writeln(periodic_trib, 'Tribute Program, Tribute Count Output. ', ' New random seed', randseed : 8, '.');
end;
if report_person <> 0 then
Writeln(event_wealth, 'Tribute Program, Event Output. ', ' New random seed', randseed : 8, '.');
if adapt then
begin
Writeln(adapt_wealth, 'Tribute Program, Adapt Output. ', ' New random seed', randseed : 8, '.');
Writeln(invaders_wealth, 'Tribute Program, Invaders Output. ', ' New random seed', randseed : 8, '.');
end;
end
else
begin {use old seed, which was inputed as constant}
randseed := old_random_seed;
Writeln(' Old random seed ', randseed : 6, '.');
Writeln(final_wealth, 'Tribute Program. Final Output.', ' Old random seed', randseed : 8, '.');
if periodic_report_freq <> 0 then
begin
Writeln(periodic_wealth, 'Tribute Program, Periodic Output. ', ' Old random seed', randseed : 8, '.');
Writeln(periodic_loyalty, 'Tribute Program, Loyalty Output. ', ' Old random seed', randseed : 8, '.');
Writeln(periodic_trib, 'Tribute Program, Tribute Count Output. ', ' Old random seed', randseed : 8, '.');
end;
if report_person <> 0 then
Writeln(event_wealth, 'Tribute Program, Event Output. ', ' Old random seed', randseed : 8, '.');
if adapt then
begin
Writeln(adapt_wealth, 'Tribute Program, Adapt Output. ', ' Old random seed', randseed : 8, '.');
Writeln(invaders_wealth, 'Tribute Program, Invaders Output. ', ' Old random seed', randseed : 8, '.');
end;
end;
if test then {run number}
run_number := 0
else
begin {not a test; read run #}
reset(datafile, Run_Number_File_Name);
case (ioresult) of
-43, 17, 19, 21, 24:
begin
writeln('File error opening the run_number file. ');
writeln('This is a fatal error. Check file name and path in input file and try again ');
halt;
end;
otherwise
begin
writeln('Run number file opened OK.');
end;
end; {case}
readln(datafile, run_number);
run_number := run_number + 1;
close(datafile);
rewrite(datafile, Run_Number_File_Name);
writeln(datafile, run_number);
writeln('Run number', run_number : 4, '.');
close(datafile);
end; {if for run number }
Common_rule_label := 1000 * common_rule_A + 100 * common_rule_B + 10 * common_rule_C + Common_rule_D;
Rare_rule_label := 1000 * rare_rule_A + 100 * rare_rule_B + 10 * rare_rule_C + rare_rule_D;
Write(final_wealth, ' Run ', Run_number : 4, ': Ver ', Version : 4 : 2, ' of ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Writeln(final_wealth, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, ' ');
Write(event_wealth, ' Run ', Run_number : 4, ': Ver ', Version : 4 : 2, ' of ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Writeln(event_wealth, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, ' ');
Writeln(event_wealth, ' Key to roles: R=receiver, P=payer of tribute. A=attacker, a=aider of attacker. D=defender, d=helper of def');
Writeln(final_wealth, common_rule_label : 5, ' Initial common rule: A, B, C, D');
if adapt then
Writeln(final_wealth, ' Adaptation run, so no initial rare rule.')
else
Writeln(final_wealth, rare_rule_label : 5, ' rare rule: A, B, C, D');
Writeln(final_wealth, toughness : 7 : 2, ' toughness');
Writeln(final_wealth, pop_max : 3, ' pops');
Writeln(final_wealth, year_max : 3, ' years / pop ');
Writeln(final_wealth, imax : 3, ' indivs / pop ');
Writeln(final_wealth, demand_phase_max : 3, ' demands/year');
Writeln(final_wealth, W_base : 7 : 2, ' initial wealth');
Writeln(final_wealth, standard_demand : 7 : 2, ' standard demand');
Writeln(final_wealth, destructiveness : 7 : 2, ' destructiveness');
Writeln(final_wealth, loyalty_pc_increment : 7, ' loyalty % increment');
writeln(final_wealth, contiguity : 7, ' Contiguity of alliances required: T/F');
writeln(final_wealth, loyalty_option : 3, ' Loyalty dynamics: 0=all, 1=either rare, 2=neither rare');
writeln(final_wealth, init_loyalty : 3, ' init_loyalty. 0 is init L(i,j)=0. 1 is random; for i<>j. 2 is 0 but L(4,5)=10%. 3 is 0 but L(3,5)=10%.');
{ No blank lines left for future growth}
writeln(final_wealth, ' pop rare i Final Wealth W if Isolated');
writeln(event_wealth, 'pop year A B roles W1 W2 W3 W4 W5 W6 W7 W8 W9 W10');
if report_rebellion then
writeln('Cases with loyalty(i,j)= 100 BEFORE fight, and Wi 0 then
begin
Write(periodic_wealth, ' Run ', Run_number : 4, ': Ver ', Version : 4 : 2, ' of ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Writeln(periodic_wealth, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, ' ');
writeln(periodic_wealth, 'pop year fights Wpop W1 W2 W3 W4 W5 W6 W7 W8 W9 W10');
Write(periodic_loyalty, ' Run ', Run_number : 4, ': Ver ', Version : 4 : 2, ' of ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Writeln(periodic_loyalty, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, ' ');
writeln(periodic_loyalty, 'Loyalty, in percent. From row to col.');
writeln(periodic_loyalty, 'pop year W row 1 2 3 4 5 6 7 8 9 10');
Write(periodic_trib, ' Run ', Run_number : 4, ': Ver ', Version : 4 : 2, ' of ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
Writeln(periodic_trib, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, ' ');
writeln(periodic_trib, 'Tribute Count: No. Times Row Paid Tribute to Col. in Each Period.');
writeln(periodic_trib, 'pop year W row 1 2 3 4 5 6 7 8 9 10');
end;
for i := 1 to imax do {initialize chormosome}
begin
if (i = rare_indiv) and (adapt = false) then
begin {one rare rule at i=rare_indiv, only if not adapt}
chrom[i, 1] := rare_rule_A;
chrom[i, 2] := rare_rule_B;
chrom[i, 3] := rare_rule_C;
chrom[i, 4] := rare_rule_D;
rare[i] := True;
end
else {others are the common rule}
begin
chrom[i, 1] := common_rule_A;
chrom[i, 2] := common_rule_B;
chrom[i, 3] := common_rule_C;
chrom[i, 4] := common_rule_D;
rare[i] := False;
end;{if i=rare_indiv, ie rare}
end;{i loop}
rare[rare_indiv] := true; {set i=rare_indiv rare, even if adapt, since it will be later}
if adapt = true then
Write_Adapt_and_Invaders_Headers;
end; {initialize run procedure}
{ --------------------------------------------------------------- }
procedure Set_Rare_Rule; {from initialize_pop for adaptive runs}
var { does mutation.}
gene_temp: gene_type; { Note: selection is in Conduct_and_Report_Adaptation}
mutated_gene: gene_type;
mutated_allele: integer;
eligible_gene: gene_type; {number of genes eligible for mutation}
begin
for gene_temp := 1 to gene_max do
begin
chrom[rare_indiv, gene_temp] := chrom[common_indiv, gene_temp]; {rare rule starts like a common rule}
end;{gene_temp}
if mutatable_gene_max > 0 then {control variable, if 0 all genes are eligible}
eligible_gene := mutatable_gene_max
else
eligible_gene := gene_max;
mutated_gene := random_one_to_n(eligible_gene);
mutated_allele := random_one_to_n(max_allele[mutated_gene] - 1); {-1 to avoid no change}
if (mutated_allele >= chrom[rare_indiv, mutated_gene]) then {adjust what's being mutated}
mutated_allele := mutated_allele + 1; { to avoid no change}
chrom[rare_indiv, mutated_gene] := mutated_allele;
{writeln('Test Set_Rare_Rule, pop, mutated gene, mutated allele', pop : 4, mutated_gene : 4, mutated_allele);}
end;
{ --------------------------------------------------------------- }
procedure Initialize_pop;
var
i, j: actor_type;
begin
fights_since_last_report := 0; {for periodic output under fights column, counted in conduct_fight}
years_since_last_report := 0;
pop_wealth := 0;
for i := 1 to imax do
begin
Productivity[i] := 20.0; {equal producitivities (gain/artor/year) }
if triangle_initial_wealth then {control constant}
W[i] := 100 * i {triangular initial wealth distribution}
else
W[i] := W_base + random / 327.67; {flat initial wealth distribution + or - uniform 100}
W_initial[i] := W[i]; {Save initial wealths}
W_if_isolated[i] := W[i]; {Start calc of wealth if isolated}
pop_wealth := pop_wealth + W[i]; {cumulate pop wealth}
if (i = rare_indiv) and adapt then
Set_Rare_Rule; {new rare rule set if adaptive run, ie mutation}
for j := 1 to imax do
begin {initialize loyalties}
if i = j then
loyalty_pc[i, j] := 100 {loyal to self}
else {i<>J}
begin
if init_loyalty = 0 then {if init_loyalty = 0 then loyal to no one else}
loyalty_pc[i, j] := 0;
if init_loyalty = 1 then {if init_loyalty = 1 then random, eg 0, 10,20..100% }
begin
loyalty_pc[i, j] := loyalty_pc_increment * (random_one_to_n(1 + 100 div loyalty_pc_increment) - 1);
end; {init_loyalty = 1}
if init_loyalty = 2 then {if init_loyalty=2 then 0 except L(4,5)=10%) }
begin
if ((i = 4) and (j = 5)) or ((i = 5) and (j = 4)) then
loyalty_pc[i, j] := 10
else
loyalty_pc[i, j] := 0;
end; {initi loyalty = 2}
if init_loyalty = 3 then {if init_loyalty=3 then 0 except L(3,5)=10%) }
begin
if ((i = 3) and (j = 5)) or ((i = 5) and (j = 3)) then
loyalty_pc[i, j] := 10
else
loyalty_pc[i, j] := 0;
end; {initi loyalty = 3}
end;{i<>j}
end; {j}
end; {i loop}
for i := 1 to imax do
begin
for j := 1 to imax do
begin {initialize tribute count}
trib_count[i, j] := 0;
trib_periodic_count[i, j] := 0;
end; {j}
end; {i loop}
if periodic_report_freq <> 0 then
begin
year := 0;
Report_Periodic_Output;
end;
end; {initialize_pop procedure}
{ --------------------------------------------------------------- }
procedure Select_Active_Actor;
begin
i := random_one_to_n(imax);
end; {procedure}
{ --------------------------------------------------------------- }
procedure Calc_Alliance (var attacker, defender: actor_type; offset: integer);
label
2, 3; {offset is from attacker to defender, -is left, + is right}
var
other: actor_type; {potential alliance member}
att_al_cand_dis: actor_type; {distance from i}
def_cand_dis: actor_type;
other_offset: offset_type;
dir_at_all: -1..1; {direction for expanding attacking alliance, -1=L, 1=R}
att_al_cand_offset: integer; {from i to attacker alliance candidate}
dir_to_target: integer; {-1 is left, 1 is right}
begin
w_att := w[attacker]; {start with own strength}
w_def := w[defender];
for other := 1 to imax do {initialize to no help or aid}
begin
aid_att[other] := False;
help_def[other] := False;
end;
aid_att[attacker] := True; {attacker is part of attack}
help_def[defender] := True; {defender is part of def}
if contiguity = true then
begin {old method: require contiguity of alliances}
j_temp_reachable := True; {assume j_temp is reachable until proven otherwise}
if offset < 0 then
dir_to_target := -1 {def is left of att}
else
dir_to_target := 1;
{Example: ,i = 7, Stage = 1( look left ) , cand_distance = 4 }
{so j_temp = 7 - 4 = 3.}
{if year = 49 then writeln(' Calc_Alliance test: defender=', defender : 3, '. offset=', offset : 3);}
{XXX test}
if abs(offset) > 1 then {there is some space between attacker and j_temp, ie defender}
begin
for att_al_cand_dis := 1 to abs(offset) - 1 do {check 6,5,4 in att}
begin
att_al_cand_offset := dir_to_target * att_al_cand_dis;
other := (attacker + att_al_cand_offset + imax - 1) mod imax + 1;
if loyalty_pc[other, attacker] > loyalty_pc[other, defender] then
begin {contribute to attcker}
w_att := w_att + loyalty_pc[other, attacker] * w[other] / 100;
aid_att[other] := True; {other aids attacker in this alliance situtation}
{if year = 49 then writeln ( ' Calc_Alliance test: add ' , other : 3 , ' to attacker alliance on near side.' );}
{XXX}
end
else {this other won't join attacker, so need go no further in this direction}
begin
j_temp_reachable := false;
goto 3;
{reject this "other" since att all isn 't contig to it}
{but would still need to check other j_temps further out in this direction}
end;{else}
end;{for att_al_cand_dis}
end; {abs ({offset)>1, ie some space between attacker and defender}
for def_cand_dis := 1 to imax - 1 do {check 2,1...in def}
begin
other_offset := dir_to_target * def_cand_dis;
other := (defender + other_offset + imax - 1) mod imax + 1;
if loyalty_pc[other, attacker] < loyalty_pc[other, defender] then
begin {contribute to defender}
w_def := w_def + loyalty_pc[other, defender] * w[other] / 100;
help_def[other] := True; {other does help defender}
{if year = 49 then writeln(' Calc_Alliance test: add ', other : 3, ' to def alliance.');}
{XXX}
end
else
goto 2; { stop search for def }
end;{def_cand_dis}
2:
dir_at_all := -dir_to_target; {check 8,9... in att}
for att_al_cand_dis := 1 to imax - 1 do
begin
att_al_cand_offset := dir_at_all * att_al_cand_dis;
other := (attacker + att_al_cand_offset + imax - 1) mod imax + 1;
if loyalty_pc[other, attacker] > loyalty_pc[other, defender] then
begin
w_att := w_att + loyalty_pc[other, attacker] * w[other] / 100;
aid_att[other] := True; {other aids attacker in this alliance situtation}
{if year = 49 then writeln(' Calc_Alliance test: add ', other : 3, 'to attacker alliance on far side.');}
{XXX}
end
else
goto 3; { stop search in this dir for att }
end;{ for att_al_cand_dis}
3:
;
end {if contiguity = true}
else
begin { contiguity = false}
for other := 1 to imax do
begin {already initialized F, except att aids self , def helps self}
if (other <> attacker) and (other <> defender) then
begin {other isn't attacker or defender}
if loyalty_pc[other, attacker] > loyalty_pc[other, defender] then
begin
w_att := w_att + loyalty_pc[other, attacker] * w[other] / 100;
aid_att[other] := True;
end; {add attacker}
if loyalty_pc[other, defender] > loyalty_pc[other, attacker] then
begin
w_def := w_def + loyalty_pc[other, defender] * w[other] / 100;
help_def[other] := True;
end; {help def}
end; {other isn't attakcker or defender}
end; {other loop}
end; {contiguity = false}
end;{Calc_Alliance}
{-----------------------------------------------------------}
procedure Calc_Demand_Value (j_temp: actor_type; var value: real);
{called by Make_Demand}
var
expect_to_pay: 0..1; {0 if not, 1 if so. Used in A3}
vulnerability: real;
payment: real;
targets_upper_cost: real; {what target would suffer it rich enough}
targets_cost_if_fight: real; {what target will actually suffer if there's a fight}
begin
case chrom[i, 1] of {Rules just determine what counts as "value" of a j_temp}
1: {RULE A1: select weakest alliance in range, ie max difference of W's}
begin
value := W_att - W_def; {value is difference of strength of alliances}
{writeln(' A1: value = ', value : 7 : 2);}
{XXX}
end;{case A1}
2: {RULE A2: max payment*vulnerablity}
begin
payment := min(standard_demand, W[j_temp]); {expected payment}
if W_att = 0 then {prevent div 0}
vulnerability := -1.0 {neg vul leads to neg value, so not chosen}
else
vulnerability := (W_att - W_def) / W_att; {relative strength}
value := payment * vulnerability;
end;{case A2}
3: {RULE A3: max value*vulnerability, subject to other's}
{ having it cheaper to pay than fight }
begin
payment := min(standard_demand, W[j_temp]); {expected payment}
if W_att = 0 then {prevent div 0}
vulnerability := -1.0 {neg vul leads to neg value, so not chosen}
else
vulnerability := (W_att - W_def) / W_att; {relative strength}
if w_def = 0 then
targets_upper_cost := 0 {to avoid div by 0}
else
targets_upper_cost := destructiveness * W_att * (W[j_temp] / W_def);
targets_cost_if_fight := min(targets_upper_cost, W[j_temp]);
if payment < targets_cost_if_fight then {if cheaper to pay}
expect_to_pay := 1
else
expect_to_pay := 0;
value := payment * vulnerability * expect_to_pay;
{if (year = 39) and (i = 5) and (j_temp = 4) then}
{begin}
{writeln(' A3: j_temp=', j_temp : 3, 'payment=', payment : 7 : 2, '. vuln = ', vulnerability : 7 : 2, ' . value = ', value : 7 : 2);}
{writeln(' Wjtemp=', W[j_temp] : 7 : 2, 'W_def = ', W_def : 7 : 2);}
{writeln(' targets_upper_cost', targets_upper_cost : 7 : 2);}
{end;}
{XXX}
end; {case A3}
4: {RULE A4: Random demand: Give each (reachable) other a positive random value. }
begin { The one with highest value will be target.There will always be a target.}
value := random + 32768 {gives number from 0 to 64k}
end;{case of A4}
end;{case of Make_Demand_Rule}
end;{Calc_Demand_Value}
{ --------------------------------------------------------------- }
procedure Make_Demand;
label
1;
var
max_value: real;
value: real;
j_temp: actor_type; {candidate (temp) target}
j_temp_offset: integer; {- is to left, + is to right of attack}
targets_upper_cost: real; {what target would suffer it rich enough}
targets_cost_if_fight: real; {what target will actually suffer if there's a fight}
stage: integer; {1= look left, 2=look right}
cand_distance: 1..imax; {abs distance i to j_temp}
direction_to_target: integer; {-1 is left, 1 is right}
begin
decide_to_demand := False; {no demand if nothing good found}
max_value := 0; {dont demand if no attractive target}
if contiguity = true then
begin
for stage := 1 to 2 do {1=left, 2=right}
begin
j_temp_offset := 0;
direction_to_target := 2 * stage - 3; {1 gives -1, 2 gives +1}
for cand_distance := 1 to imax - 1 do {can go all the way around the circle}
begin
j_temp_offset := j_temp_offset + direction_to_target; {go one further away from i}
j_temp := (i + j_temp_offset + imax - 1) mod imax + 1;
{if year = 49 then writeln('Make_Demand: j_temp_offset:', j_temp_offset : 3, '. j_temp', j_temp : 3);}
{XXX}
calc_alliance(i, j_temp, j_temp_offset); {get reachability, aid,help given this i, j_temp, direction_to_target, cand_offset}
{if year = 49 then writeln(' Make_Demand: reachable:', j_temp_reachable);}
{XXX}
if j_temp_reachable then
begin
Calc_Demand_Value(j_temp, value);
if (value > max_value) then {current j_temp is best so far}
begin
max_value := value; {reset best seen}
j := j_temp;
offset_target := j_temp_offset;
decide_to_demand := True; {decide to demand since value>0}
{if year = 49 then write(' Make_Demand , best value so far : ', value : 6 : 2);}
{XXX}
{if year = 49 then writeln('W_att,W_def', W_att : 7 : 2, ' ', W_def : 7 : 2);}
{XXX}
end; {if value>max value}
end;{if j_temp_reachable}
if loyalty_pc[j_temp, i] = 0 then
goto 1 {search no further in this direction}
end;{for cand_distance}
1:
;
end;{stage}
end {contiguity = true}
else
begin {contiguity = false}
for j_temp := 1 to imax do
begin
if j_temp <> i then
begin
j_temp_offset := 0; {not used at all here since contiguity = false}
calc_alliance(i, j_temp, j_temp_offset);
Calc_Demand_Value(j_temp, value);
if (value > max_value) then {current j_temp is best so far}
begin
max_value := value; {reset best seen}
j := j_temp;
offset_target := j_temp_offset;
decide_to_demand := True; {decide to demand since value>0}
end; {if value>max value}
end; {j_temp <> i}
end; {j_temp}
end;{contiguity = false}
end; {Make_Demand}
{ --------------------------------------------------------------- }
procedure Make_Response_Decision;
var
payment: real; {expected payment, used in B3, B4}
targets_upper_cost: real; {cost to j if j rich enough, used in B3, B4}
targets_cost_if_fight: real; {expected damage to j, used in B3, B4}
begin
Calc_alliance(i, j, offset_target); {determine W_att,W_def, aid_att, help_def. Also used in Conduct_Fight}
case chrom[j, 2] of {j's B rule for response}
1:
agree_to_pay := false; {B1 never pay}
2:
agree_to_pay := true; {B2 always pay}
3: {B3 pay if cheaper for self than fighting}
begin
payment := min(standard_demand, W[j]); {expected payment}
if w_def = 0 then
targets_upper_cost := 0 {to avoid div by 0}
else
targets_upper_cost := destructiveness * W_att * (W[j] / W_def);
targets_cost_if_fight := min(targets_upper_cost, W[j]);
if targets_cost_if_fight > payment then {considers only damage to j, not helpers}
Agree_To_Pay := True {pay if cheaper than fighting - for self (j)}
else
Agree_To_Pay := False;
{ if (year = 39) and (i = 5) and (j = 4) then}
{ begin}
{ writeln(' B3. payment=', payment : 5, 'targets_upper_cost= ', targets_upper_cost : 6 : 2);}
{ writeln(' targets_cost_if_fight= ', targets_cost_if_fight : 6 : 2, ' Wj=', W[j] : 6 : 2, ' Wdef=', W_def : 6 : 2);}
{end;}
{XXX }
end;{case B3}
4: {B4 fight if cheaper for self than paying}
begin
payment := min(standard_demand, W[j]); {expected payment}
if w_def = 0 then
targets_upper_cost := 0 {to avoid div by 0}
else
targets_upper_cost := destructiveness * W_att * (W[j] / W_def);
targets_cost_if_fight := min(targets_upper_cost, W[j]);
if targets_cost_if_fight >= payment then {considers only damage to j, not helpers}
Agree_To_Pay := True {fight if cheaper than paying - for self (j)}
else
Agree_To_Pay := False;
end;{case B4}
5: {B5 pay if fight_cost > toughness*payment}
begin
payment := min(standard_demand, W[j]); {expected payment}
if w_def = 0 then
targets_upper_cost := 0 {to avoid div by 0}
else
targets_upper_cost := destructiveness * W_att * (W[j] / W_def);
targets_cost_if_fight := min(targets_upper_cost, W[j]);
if targets_cost_if_fight > toughness * payment then {considers only damage to j, not helpers}
Agree_To_Pay := True {pay if fight_cost > toughness*payment - for self (j)}
else
Agree_To_Pay := False;
end;{case B5}
6: {B6 pay or fight at random}
begin
if random < 0 then
Agree_To_Pay := True
else
Agree_To_Pay := False;
end;{case B6}
end;{case of chrom, ie j's B rule}
end;{procedure Make_Response_Decision}
{ --------------------------------------------------------------- }
procedure Increase_Loyalty (from_person, to_person: actor_type);
var
temp_loyalty_pc: integer; {temporary loyalty in percentage}
loyalty_to_be_increased: boolean; {who may increase loyalty: 0=all, 1=rare, 2=common}
{ dont need to worry about decreasing since it's say 0 if never increased}
begin
loyalty_to_be_increased := False; {assume conditions won't be met}
case loyalty_option of
0: {everyone increases }
loyalty_to_be_increased := True;
1: {increase only if either from or to person is rare}
if rare[from_person] or rare[to_person] then
loyalty_to_be_increased := True;
2: {increase only if neither from or to person is rare}
if not rare[from_person] and not rare[to_person] then
loyalty_to_be_increased := True;
end; {case}
if loyalty_to_be_increased then {increase in normal way}
begin
temp_loyalty_pc := loyalty_pc[from_person, to_person] + loyalty_pc_increment;
if temp_loyalty_pc > 100 then
Loyalty_pc[from_person, to_person] := 100 {max allowable}
else
Loyalty_pc[from_person, to_person] := temp_loyalty_pc;
{test XXX}
{ writeln('IncLoy: newL, from,to ', loyalty_pc[from_person, to_person] : 7, from_person, to_person);}
end; {loyalty option}
end;{Increase_Loyalty}
{ --------------------------------------------------------------- }
procedure Decrease_Loyalty (from_person, to_person: actor_type);
var
temp_loyalty_pc: integer; {temporary loyalty in percentage}
begin
temp_loyalty_pc := loyalty_pc[from_person, to_person] - loyalty_pc_increment;
if temp_loyalty_pc < 0 then
loyalty_pc[from_person, to_person] := 0 {min allowable}
else
Loyalty_pc[from_person, to_person] := temp_loyalty_pc;
{test XXX}
{writeln('DecLoy: newL, from,to ', loyalty_pc[from_person, to_person] : 7, from_person, to_person);}
end;{Decrease_Loyalty}
{ --------------------------------------------------------------- }
procedure Make_Payment;
begin
if W[j] < Standard_Demand then {payment doesn't exceed wealth of payor}
Tribute := W[j]
else
Tribute := Standard_Demand;
W[i] := W[i] + Tribute; {j automatically pays}
W[j] := W[j] - Tribute;
{writeln('XXX increase loyalty due to tribute', i, j);}
Increase_Loyalty(i, j); {receiver of tribute becomes more loyal to payer}
Increase_Loyalty(j, i); {payer of tribute becomes more loyal to receiver}
trib_count[j, i] := trib_count[j, i] + 1; {update total count from row to col, ie j to i}
trib_periodic_count[j, i] := trib_periodic_count[j, i] + 1; {update per. count from row to col, ie j to i}
if (report_person = i) or (report_person = j) then
begin
Agree_to_Pay := true; {tribute paid}
Make_Person_Report;
end;{if}
{write('XXX Pay: Year=', year : 3, ' to i=', i : 3, ' from j=', j : 3);}
{writeln(' W[i]=', W[i] : 7 : 1, ' W[j]=', W[j] : 7 : 1);}
end;
{ --------------------------------------------------------------- }
procedure Conduct_FIght;
type
report_string_type = packed array[1..imax] of char;
var
Damage_by_Attacker: real; {damage done by attacking alliance}
Damage_by_Defender: real;
k, L: actor_type; {generic actors}
rebellion: boolean; {whether there is a potential rebellion}
report_string: report_string_type; {to report events with potential rebellion}
begin
{writeln('Fight: Attacker= ', i : 2, ' Defender= ', j : 2);}
{writeln(' Wealth'' s of a, d before = ', W[i] : 6 : 2, ' ', W[j] : 6 : 2);}
rebellion := false; {assume its not a potential rebellion}
if report_rebellion and (loyalty_pc[i, j] = 100) and (w[j] > w[i]) then
begin {xxx- report a potential rebellion}
rebellion := true; {to get a report after the fight}
writeln('XXX fight: pop= ', pop : 3, ' year = ', year : 4, '. fight i , j ', i : 5, ' ', j : 5, ' %loy ( i , j ) = ', loyalty_pc[i, j] : 6);
writeln(' attack of bigger target: Wi= ', W[i] : 6 : 1, ' Wj= ', W[j] : 6 : 1, ' W_def= ', W_def : 6 : 1, 'W_att = ', W_att : 6 : 1);
write('W before fight:', w[1] : 6 : 1, ' ', w[2] : 6 : 1, ' ', w[3] : 6 : 1, ' ', w[4] : 6 : 1, ' ', w[5] : 6 : 1, ' ', w[6] : 6 : 1, ' ');
writeln(w[7] : 6 : 1, ' ', w[8] : 6 : 1, ' ', w[9] : 6 : 1, ' ', w[10] : 6 : 1);
for k := 1 to imax do {do row as outer loop}
begin
write(pop : 4, ' ', year : 4, ' ', k : 4, ' ');
for L := 1 to imax do
begin
write(loyalty_pc[k, L] : 4, ' ');
if L = imax then
writeln;
end;{L}
end;{k}
end;{report rebellion}
Damage_by_Attacker := min(destructiveness * W_att, W_def); {Can't do more than W_def}
Damage_by_Defender := min(destructiveness * W_def, W_att); {Can't do more than W_att}
for k := 1 to imax do {calc everyone's new wealth and loyalty}
begin
if aid_att[k] then {k is part of attack}
begin
if W_att > 0.0 then
W[k] := W[k] - Damage_by_Defender * loyalty_pc[k, i] * (W[k] / W_att) / 100;
for L := 1 to imax do
begin
if aid_att[L] then {k, L on same side of fight}
begin
increase_loyalty(k, L);
end;
if help_def[L] then {k, L on different sides of fight}
decrease_loyalty(k, L);
end;{L}
end;{k is in attack}
if help_def[k] then {k is part of defense}
begin
if W_def > 0.0 then
begin
W[k] := W[k] - Damage_by_Attacker * loyalty_pc[k, j] * (W[k] / W_def) / 100;
{write('damage_by_attacker, loyalty%, k, j, Wk new,W_def');}
{XXX test}
{writeln(Damage_by_Attacker : 6 : 1, loyalty_pc[k, j] : 6, k : 3, j : 3, W[k] : 6 : 1, W_def : 6 : 1); }
{XXX test}
end;
for L := 1 to imax do
begin
if help_def[L] then {k, L on same side of fight}
begin
{writeln('XXX from conduct fight: on same side,both def:', k, l);}
increase_loyalty(k, L);
end;
if aid_att[L] then {k, L on different sides of fight}
decrease_loyalty(k, L);
end;{L}
end;{K is in defense}
end;{k}
if (aid_att[report_person] or help_def[report_person]) then
make_person_report;
fights_since_last_report := fights_since_last_report + 1; {count number of fights since periodic report}
if rebellion then {report string}
begin
for k := 1 to imax do
begin
report_string[k] := '-'; {set to . if nothing applies}
if aid_att[k] then
report_string[k] := 'a'; {a for aid attacker}
if help_def[k] then
report_string[k] := 'd'; {d for help defender}
if k = i then
report_string[k] := 'A'; {A for attacker}
if k = j then
report_string[k] := 'D'; {D for defender}
end;{k}
writeln(' Previous event= ', report_string : 12);
end;{rebellion}
end;{conduct fight}
{ --------------------------------------------------------------- }
procedure Produce_Wealth;
var
i: integer;
begin
for i := 1 to imax do
begin
Income := Productivity[i];
W[i] := W[i] + Income;
W_if_isolated[i] := W_if_isolated[i] + Income;
{Writeln('Year=', year : 3, ' i=', i : 3, ' Income=', Income : 7 : 1, ' Wealth=', W[i] : 7 : 1);}
end;{production cycle}
end;
{ --------------------------------------------------------------- }
procedure Report_Final_Output;
var
i, j: actor_type;
begin
for i := 1 to imax do
begin
writeln(final_wealth, pop : 3, ' ', rare[i] : 3, ' ', i : 3, ' ', W[i] : 9 : 1, ' ', W_if_isolated[i] : 9 : 1);
end;
writeln(final_wealth, 'Loyalty, in percent. From row to col.');
writeln(final_wealth, 'pop row Final W 1 2 3 4 5 6 7 8 9 10');
for i := 1 to imax do {do row as outer loop}
begin
write(final_wealth, pop : 4, ' ', i : 4, ' ', W[i] : 9 : 1, ' ');
for j := 1 to imax do
begin
write(final_wealth, loyalty_pc[i, j] : 4, ' ');
if j = imax then
writeln(final_wealth);
end;{j}
end;{i}
writeln(final_wealth, 'Count of times trib paid by row to col.');
writeln(final_wealth, 'pop row Final W 1 2 3 4 5 6 7 8 9 10');
for i := 1 to imax do {do row as outer loop}
begin
write(final_wealth, pop : 4, ' ', i : 4, ' ', W[i] : 9 : 1, ' ');
for j := 1 to imax do
begin
write(final_wealth, trib_count[i, j] : 4, ' ');
if j = imax then
writeln(final_wealth);
end;{j}
end;{i}
end;
{ --------------------------------------------------------------- }
procedure Conduct_and_Report_Adaptation; {This is "selection" procedure}
var {NOTE: mutation of rare rule is in initialize_pop}
i_temp: actor_type;
invade: integer; {1 if invasion criterion met, 0 if not}
gene_temp: gene_type;
ave_common_wealth: real;
ave_common_LR: real; {Left+Right range}
rare_LR: integer;
ave_common_successes: real; {number Wealth > Wealth if Iso}
rare_success: integer;
begin
ave_common_wealth := 0;
ave_common_LR := 0;
ave_common_successes := 0;
for i_temp := 1 to imax do
begin
if i_temp <> rare_indiv then {cumulate stats for common indivs}
begin
ave_common_wealth := ave_common_wealth + w[i_temp];
{ave_common_LR := ave_common_LR + left_d[i_temp] + right_d[i_temp];}
{obsolete}
if W[i_temp] > W_if_isolated[i_temp] then
ave_common_successes := ave_common_successes + 1;
end; {if}
end;{i_temp}
ave_common_wealth := ave_common_wealth / (imax - 1); {there are imax-1 common indivs}
ave_common_LR := ave_common_LR / (imax - 1);
ave_common_successes := ave_common_successes / (imax - 1);
{rare_LR := left_d[rare_indiv] + right_d[rare_indiv];}
{obsolete}
if W[rare_indiv] > W_if_isolated[rare_indiv] then
rare_success := 1
else
rare_success := 0;
invade := 0; {assume unless following test works}
duration_since_invasion := duration_since_invasion + 1; {tally since last invasion}
if W[rare_indiv] > ave_common_wealth then
begin
invade := 1; {invade criterion; write line of invaders}
invaders_so_far := invaders_so_far + 1; {tally of how many times there has been an invasion}
write(invaders_wealth, invaders_so_far : 4, ' ', duration_since_invasion : 4, ' ', pop : 4);
write(invaders_wealth, ' ', chrom[common_indiv, 1] : 3, ' ', chrom[common_indiv, 2] : 2);
write(invaders_wealth, ' ', chrom[common_indiv, 3] : 2, ' ', chrom[common_indiv, 4] : 2);
write(invaders_wealth, ' ', chrom[rare_indiv, 1] : 3, ' ', chrom[rare_indiv, 2] : 2);
write(invaders_wealth, ' ', chrom[rare_indiv, 3] : 2, ' ', chrom[rare_indiv, 4] : 2);
write(invaders_wealth, ' ', ave_common_wealth : 8 : 2, ' ', w[rare_indiv] : 8 : 2);
write(invaders_wealth, ' ', ave_common_LR : 7 : 2, ' ', rare_LR : 4);
writeln(invaders_wealth, ' ', ave_common_successes : 7 : 2, ' ', rare_success : 4);
duration_since_invasion := 0; {restart count of pops since last invasion}
end;
{ write line of adapt file whether or not invade }
write(adapt_wealth, pop : 4, ' ', chrom[common_indiv, 1] : 3, ' ', chrom[common_indiv, 2] : 2);
write(adapt_wealth, ' ', chrom[common_indiv, 3] : 2, ' ', chrom[common_indiv, 4] : 2);
write(adapt_wealth, ' ', chrom[rare_indiv, 1] : 3, ' ', chrom[rare_indiv, 2] : 2);
write(adapt_wealth, ' ', chrom[rare_indiv, 3] : 2, ' ', chrom[rare_indiv, 4] : 2);
write(adapt_wealth, ' ', ave_common_wealth : 8 : 2, ' ', w[rare_indiv] : 8 : 2, ' ', invade : 2);
write(adapt_wealth, ' ', ave_common_LR : 7 : 2, ' ', rare_LR : 4);
writeln(adapt_wealth, ' ', ave_common_successes : 7 : 2, ' ', rare_success : 4);
if invade = 1 then {make new common rules the old rare rule}
begin
for i_temp := 1 to imax do
begin
if i_temp <> rare_indiv then
begin
for gene_temp := 1 to gene_max do
begin
chrom[i_temp, gene_temp] := chrom[rare_indiv, gene_temp];
end;{gene_temp}
end;{if i_temp<>rare_indiv}
end;{i_temp}
end;{if invade}
end;{Conduct_and_Report_Adaptation}
{ --------------------------------------------------------------- }
{ --------------------------------------------------------------- }
{M A I N P R O G R A M }
begin
initialize_run; {initialize whole run}
for pop := 1 to pop_max do {POPULATION CYCLE}
begin
Initialize_pop; {INITIALIZE current population}
for year := 1 to year_max do {YEARLY CYCLE}
begin
for demand_phase := 1 to demand_phase_max do {DEMAND CYCLE}
begin
Select_Active_Actor;
Make_Demand;
if Decide_To_Demand then {demand was made of j}
begin
Make_Response_Decision;
if Agree_To_Pay then
Make_Payment
else
Conduct_Fight;
end;{decide to demand}
end; {demand cycle}
Produce_Wealth; {PRODUCTION}
years_since_last_report := years_since_last_report + 1;
if years_since_last_report = periodic_report_freq then {time to give periodic_output line}
Report_Periodic_Output;
end; {yearly cycle}
Report_Final_Output; {of a pop for a line of final_output}
if adapt then
Conduct_and_Report_Adaptation; {of a pop for a line of adapt_output}
end;{pop cycle}
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.');
Writeln(final_wealth, 'Duration of this run is ', duration : 5, ' seconds.');
end.{main program}
University of Michigan Center for the Study of Complex Systems
Contact cscs@umich.edu.
Revised November 4, 1996.