unit crsc_g2v1_L0M0XY0_STD; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; const fname='results_g2v1_STD_A5B_n'; delta=0.025; beta=1.33; maxngb=10; mem_disc=0.02; mutrate=0.055; mxco=3; mxlu=22; mxmm=10; mxsn=10000; maxres=100; minres=10; EvoSteps=1000; a0=0.05; r0=70; rliving=0.05;{1} waitmax=10; commax=50; absmaxr=1000; success_praemium=1.5; type langunit=record c_own,c_oth:char; c_out:array[1..mxco] of char; ps:array[1..mxco] of real; end; lang=array[1..mxlu] of langunit; memu=record id:integer; pos,neg:real; end; membl=array[1..mxmm] of memu; agent_std=record resources:real; intention:real; intention_now:real; memory:membl; memlng:integer; pget,pgive,negtime:word; contact_id:integer; result:integer; sh1,sh2:integer; pzx,pzy:real; age:word; end; TForm1 = class(TForm) StartButton: TButton; Label1: TLabel; TimeLabel: TLabel; Label5: TLabel; PSLabel: TLabel; procedure StartButtonClick(Sender: TObject); procedure EvolveSoc; procedure Cycle(a,b:word); private { Private declarations } public { Public declarations } end; var Form1: TForm1; Society,NewSociety:array[1..mxsn] of agent_std; csn,popn:word; match:array[1..mxsn] of word; collabs,cheaters,baleks,nocolls:real; gcollabs,gcheaters,gbaleks,gnocolls:real; Time:LongInt; CLBitmap,CHBitmap,NCBitmap,LngBitmap:TBitmap; LCXval,LCXsval,CLbval,CHbval,NCbval,CLrval,CHrval,NCrval:array[1..500] of word; fr:TextFile; probs,probsv:array[1..4,1..12,1..3,1..7] of real; maxr,minr,avglcx,siglcx:real; RiskF,LimF:real; Vo,Vs,Ve,Mo,Ms,Me,Vor,Vsr,Ver:real; ckv:array[1..3,1..mxsn] of real; implementation {$R *.DFM} procedure GenSoc; {Generation of an agent society; Note that memlng is set to zero, which means that agents have no memories of earlier encounters with other agents} var i:word;pss:real; begin csn:=1500{trunc(0.3*mxsn)}; popn:=csn; for i:=1 to csn do with Society[i] do begin resources:=random(maxres-minres)+minres; intention:=(random(1000)+1)/1001; memlng:=0; pzx:=random(1000); pzy:=random(1000); age:=random(60)+1; end; end; procedure MatchMaking3; {Finds communication partners for agents} var i,pick1,pick2,j,k,ia,ib,nomatch,jj:integer;ds,dds:real; nbdist:array[1..maxngb] of real; nbrid:array[1..maxngb] of word; begin nomatch:=popn; for i:=1 to csn do begin match[i]:=0; if Society[i].age=0 then match[i]:=65000; end; repeat pick1:=random(csn)+1; if (match[pick1]>0) and (Society[pick1].Resources>0) then begin ia:=pick1+1; ib:=pick1-1; if ib=0 then ib:=csn; if ia=csn+1 then ia:=1; while ((ia<=csn) and (match[ia]>0) and (ib>0) and (match[ib]>0)) or ((Society[ia].Resources=0) and (Society[ib].Resources=0)) do begin ia:=ia+1; ib:=ib-1; if ib=0 then ib:=csn; if ia=csn+1 then ia:=1; end; if (match[ia]=0) and ((Society[ia].Resources>0)) then pick1:=ia else pick1:=ib; end; for i:=1 to maxngb do begin nbdist[i]:=10000; nbrid[i]:=0; end; for i:=1 to csn do if (i<>pick1) and (Society[i].age>0) and (Society[i].Resources>0) then begin ds:=sqrt(sqr(Society[pick1].pzx-Society[i].pzx)+ sqr(Society[pick1].pzy-Society[i].pzy)); dds:=0; jj:=0; for j:=1 to maxngb do begin if nbdist[j]-ds>dds then begin dds:=nbdist[j]-ds; jj:=j; end; end; if jj>0 then begin nbdist[jj]:=ds; nbrid[jj]:=i; end; end; for i:=1 to maxngb do if nbrid[i]>0 then if match[nbrid[i]]>0 then nbrid[i]:=0; i:=1;j:=maxngb; while i0 then begin pick2:=nbrid[random(j)+1]; match[pick1]:=pick2; match[pick2]:=pick1; nomatch:=nomatch-2; end else nomatch:=nomatch-1; until nomatch<=0; for i:=1 to csn do with Society[i] do if age>0 then begin pzx:=pzx+random(10)-5; pzy:=pzy+random(10)-5; end; end; procedure Communications; {The execution of the communication process between agents; Note that memlng is set to zero, so there is no effect of the memory in this simulation} var mm,i,j,k,t,jm1,jm2,negt,li,h:word;lf,goon:boolean; cu1,cu2,cuold:char;rn:array[1..mxco] of real;rt,mmfd:real; begin for i:=1 to csn do if (match[i]>0) and (Society[i].age>0) then begin jm1:=0; with Society[i] do begin intention_now:=intention; if memlng>0 then for j:=1 to memlng do if memory[j].id=match[i] then begin jm1:=j; if memory[j].pos>=memory[j].neg+0.5 then begin rt:=memory[j].pos/(0.5+memory[j].neg); intention_now:=rt*intention_now; if intention_now>1 then intention_now:=1; end; if memory[j].neg>=memory[j].pos+0.5 then begin rt:=(memory[j].pos+0.5)/memory[j].neg; intention_now:=rt*intention_now; end; end; end; jm2:=0; with Society[Match[i]] do begin intention_now:=intention; if memlng>0 then for j:=1 to memlng do if memory[j].id=i then begin jm2:=j; if memory[j].pos>=memory[j].neg+0.5 then begin rt:=memory[j].pos/(0.5+memory[j].neg); intention_now:=rt*intention_now; if intention_now>1 then intention_now:=1; end; if memory[j].neg>=memory[j].pos+0.5 then begin rt:=(memory[j].pos+0.5)/memory[j].neg; intention_now:=rt*intention_now; end; end; end; rn[1]:=random(1000)/1000; rn[2]:=random(1000)/1000; if (Society[i].intention_now>rn[1]) then cu1:='h' else cu1:='t'; if (Society[match[i]].intention_now>rn[2]) then cu2:='h' else cu2:='t'; if jm1>0 then begin if cu2='h' then Society[i].memory[jm1].pos:=Society[i].memory[jm1].pos+1 else Society[i].memory[jm1].neg:=Society[i].memory[jm1].neg+1; end else with Society[i] do begin memlng:=memlng+1; if memlng<=mxmm then mm:=memlng else begin memlng:=mxmm; mm:=1; mmfd:=memory[1].pos+memory[1].neg; for h:=2 to memlng do if mmfd>memory[h].pos+memory[h].neg then begin mm:=h; mmfd:=memory[h].pos+memory[h].neg; end; end; with memory[mm] do begin id:=match[i]; pos:=0; neg:=0; if (cu1='h') and (cu2='h') then pos:=1 else neg:=1; end; end; if jm2>0 then begin if cu1='h' then Society[match[i]].memory[jm2].pos:=Society[match[i]].memory[jm2].pos+1 else Society[match[i]].memory[jm2].neg:=Society[match[i]].memory[jm2].neg+1; end else with Society[match[i]] do begin memlng:=memlng+1; if memlng<=mxmm then mm:=memlng else begin memlng:=mxmm; mm:=1; mmfd:=memory[1].pos+memory[1].neg; for h:=2 to memlng do if mmfd>memory[h].pos+memory[h].neg then begin mm:=h; mmfd:=memory[h].pos+memory[h].neg; end; end; with memory[mm] do begin id:=i; pos:=0; neg:=0; if (cu1='h') and (cu2='h') then pos:=1 else neg:=1; end; end; with Society[i] do begin pgive:=0; pget:=0; if cu1='h' then pgive:=match[i]; if cu2='h' then pget:=match[i]; negtime:=negt; end; with Society[match[i]] do begin pgive:=0; pget:=0; if cu2='h' then pgive:=i; if cu1='h' then pget:=i; negtime:=negt; end; match[match[i]]:=0; match[i]:=0; end; end; function RandNorm(n:word):real; {Generates random values with normal distribution} var rnda:array[1..100] of word;rr:real;i:word; begin for i:=1 to 100 do rnda[i]:=Random(n)/n; rr:=0; for i:=1 to 100 do rr:=rr+rnda[i]/100; rr:=(rr-0.5)*sqrt(100); rr:=rr*n/2; RandNorm:=rr; end; procedure ResourceUpdate; {Calculation of the amounts of resources for the next turn} var i,n,j,k,h,ct:word;rn,rn1,rn2,rb,rb1,rb2,mean,sig,pss:real; u:integer;dlt,va,va1,va2,rn1o,rn2o,rn10,rn20:real;partner:boolean; c1m,c1v,c2m,c2v,c3m,c3v:real;ccc:array[1..3] of word; begin collabs:=0; cheaters:=0; baleks:=0; nocolls:=0; mean:=0; sig:=0; maxr:=0; minr:=10000; ct:=0; for i:=1 to csn do if (Society[i].age>0) and (Society[i].Resources>0) then begin if Society[i].memlng>0 then begin for j:=1 to 10 do begin Society[i].memory[j].pos:=(1-mem_disc)*Society[i].memory[j].pos; Society[i].memory[j].neg:=(1-mem_disc)*Society[i].memory[j].neg; end; for j:=1 to 10 do if Society[i].memory[j].pos+Society[i].memory[j].neg<0.001 then begin for k:=j to 9 do Society[i].memory[k]:=Society[i].memory[k+1]; Society[i].memlng:=Society[i].memlng-1; if Society[i].memlng<0 then Society[i].memlng:=0; end; end; rb1:=Society[i].Resources; if rb1>absmaxr then begin rb1:=absmaxr/10; Society[i].Resources:=rb1; end; if rb1>maxr then maxr:=rb1; if rb10) and (Society[i].Resources>0) then begin match[i]:=1; ct:=ct+1; end; Vo:=0;Mo:=0; Vs:=0;Ms:=0; Ve:=0;Me:=0; partner:=false; ccc[1]:=0; ccc[2]:=0; ccc[3]:=0; for i:=1 to csn do if (Society[i].age>0) and (Society[i].Resources>0) and (match[i]=1) then with Society[i] do begin match[i]:=0; rb1:=resources; rb2:=0; partner:=false; if pget>0 then begin rb2:=Society[pget].Resources; match[pget]:=0; partner:=true; end else if pgive>0 then begin rb2:=Society[pgive].Resources; match[pgive]:=0; partner:=true; end; rb:=rb1+rb2; if sig>0 then begin rn1:=a0*(rb1-mean-0.55*sig)/sig; rn2:=a0*(rb2-mean-0.55*sig)/sig; rn:=a0*(rb-mean-0.55*sig)/sig; end else begin rn1:=a0*(rb1-mean); rn2:=a0*(rb2-mean); rn:=a0*(rb-mean); end; if rb2=0 then rn2:=0; rn1:=1.5/(1+exp(-rn1)); rn2:=1.5/(1+exp(-rn2)); rn:=1.5/(1+exp(-rn)); rn1:=rn1*rb1; rn2:=rn2*rb2; rn:=rn*rb; { rn:=2*rn;} rn1:=rn1*beta; rn2:=rn2*beta; rn:=rn*beta; va1:=RandNorm(1000)/1000; va2:=RandNorm(1000)/1000; va:=RandNorm(1000)/1000; rn1o:=rn1*(1+va1*RiskF); rn2o:=rn2*(1+va2*RiskF); ccc[1]:=ccc[1]+1; ckv[1,ccc[1]]:=rn1o-rb1; Mo:=Mo+rn1o-rb1; Vo:=Vo+sqr(rn1o-rb1); if partner then begin Mo:=Mo+rn2o-rb2; Vo:=Vo+sqr(rn2o-rb2); ccc[1]:=ccc[1]+1; ckv[1,ccc[1]]:=rn2o-rb2; end; if va10) and (pget>0) then begin rn1:=rn1+dlt/2; rn2:=rn2+dlt/2; end; if (pgive>0) and (pget=0) then begin rn1:=rn1; rn2:=rn2+dlt; end; if (pgive=0) and (pget>0) then begin rn2:=rn2; rn1:=rn1+dlt; end; if (pgive=0) and (pget=0) then begin rn2:=rn2; rn1:=rn1; end; ccc[3]:=ccc[3]+1; ckv[3,ccc[3]]:=rn1-rb1; Me:=Me+rn1-rb1; Ve:=Ve+sqr(rn1-rb1); if partner then begin Me:=Me+rn2-rb2; Ve:=Ve+sqr(rn2-rb2); ccc[3]:=ccc[3]+1; ckv[3,ccc[3]]:=rn2-rb2; end; rn1:=rn1-rliving; rn2:=rn2-rliving; if rn1<0 then rn1:=0; if rn1>absmaxr then rn1:=absmaxr; if rn2<0 then rn2:=0; if rn2>absmaxr then rn2:=absmaxr; resources:=rn1; if pget>0 then Society[pget].Resources:=rn2 else if pgive>0 then Society[pgive].Resources:=rn2; if pgive>0 then begin if pget>0 then begin collabs:=collabs+2; gcollabs:=gcollabs+rn1+rn2; end else begin baleks:=baleks+1; cheaters:=cheaters+1; gbaleks:=gbaleks+rn1; gcheaters:=gcheaters+rn2; end; end else begin if pget>0 then begin cheaters:=cheaters+1; baleks:=baleks+1; gcheaters:=gcheaters+rn1; gbaleks:=gbaleks+rn2; end else begin nocolls:=nocolls+1; gnocolls:=gnocolls+rn1; end; end; end; if collabs=0 then collabs:=1; if cheaters=0 then cheaters:=1; if baleks=0 then baleks:=1; if nocolls=0 then nocolls:=1; if ct=0 then begin ct:=1; popn:=0; csn:=0; end; Mo:=Mo/ct; Vo:=Vo/ct; Ms:=Ms/ct; Vs:=Vs/ct; Me:=Me/ct; Ve:=Ve/ct; Vo:=Vo-sqr(Mo); Vs:=Vs-sqr(Ms); Ve:=Ve-sqr(Me); Vo:=sqrt(abs(Vo)); Vs:=sqrt(abs(Vs)); Ve:=sqrt(abs(Ve)); if Mo<>0 then Vor:=Vo/Abs(Mo) else Vor:=0; if Ms<>0 then Vsr:=Vs/Abs(Ms) else Vor:=0; if Mo<>0 then Ver:=Ve/Abs(Me) else Ver:=0; c1m:=0; c1v:=0; for i:=1 to ccc[1] do begin c1m:=c1m+ckv[1,i]; c1v:=c1v+sqr(ckv[1,i]); end; if ccc[1]=0 then ccc[1]:=1; c1m:=c1m/ccc[1]; c1v:=c1v/ccc[1]; c1v:=c1v-sqr(c1m); c2m:=0; c2v:=0; for i:=1 to ccc[2] do begin c2m:=c2m+ckv[2,i]; c2v:=c2v+sqr(ckv[2,i]); end; if ccc[2]=0 then ccc[2]:=1; c2m:=c2m/ccc[2]; c2v:=c2v/ccc[2]; c2v:=c2v-sqr(c2m); c3m:=0; c3v:=0; for i:=1 to ccc[3] do begin c3m:=c3m+ckv[3,i]; c3v:=c3v+sqr(ckv[3,i]); end; if ccc[3]=0 then ccc[3]:=1; c3m:=c3m/ccc[3]; c3v:=c3v/ccc[3]; c3v:=c3v-sqr(c3m); c1v:=sqrt(abs(c1v)); c2v:=sqrt(abs(c2v)); c3v:=sqrt(abs(c3v)); gcollabs:=gcollabs/collabs; gcheaters:=gcheaters/cheaters; gbaleks:=gbaleks/baleks; gnocolls:=gnocolls/nocolls; collabs:=collabs/ct; cheaters:=cheaters/ct; baleks:=baleks/ct; nocolls:=nocolls/ct; mean:=0; sig:=0; maxr:=0; minr:=10000; for i:=1 to csn do if (Society[i].age>0) and (Society[i].Resources>0) then begin rb1:=Society[i].Resources; if rb1>absmaxr then begin rb1:=absmaxr/10; Society[i].Resources:=rb1; end; if rb1>maxr then maxr:=rb1; if rb10) and (Society[i].Resources>0) then Society[i].age:=Society[i].age+1; for i:=1 to csn do if (Society[i].Resources=0) and (Society[i].Age>0) then begin Society[i].Age:=0; popn:=popn-1; end; for i:=1 to csn do if Society[i].age>60 then if Society[i].Resources>=0.99*mean-0.5*sig then begin n:=trunc(success_praemium*(Society[i].Resources-mean+0.5*sig)/sig)+1; if popn+n-1>mxsn then n:=mxsn-popn; k:=1; j:=1; while (j<=csn) and (k<=n-1) do begin while (j<=csn) and (Society[j].age>0) do j:=j+1; if j<=csn then begin Society[j]:=Society[i]; with Society[j] do begin Resources:=Resources/n; age:=Random(20)+1; memlng:=0; Intention:=Intention+mutrate*(random(1000)-500)/1000; if Intention>=1 then Intention:=1-mutrate*(random(1000)+1)/1000; if Intention<=0 then Intention:=mutrate*(random(1000)+1)/1000; Intention_now:=Intention; end; k:=k+1; popn:=popn+1; end; end; if k<=n-1 then for j:=k to n-1 do begin csn:=csn+1; popn:=popn+1; Society[csn]:=Society[i]; with Society[csn] do begin Resources:=Resources/n; age:=Random(20)+1; memlng:=0; Intention:=Intention+mutrate*(random(1000)-500)/1000; if Intention>=1 then Intention:=1-0.05*(random(1000)+1)/1000; if Intention<=0 then Intention:=0.05*(random(1000)+1)/1000; Intention_now:=Intention; end; end; if n>1 then begin with Society[i] do begin Resources:=Resources/n; age:=Random(20)+1; memlng:=0; Intention:=Intention+mutrate*(random(1000)-500)/1000; if Intention>=1 then Intention:=1-0.05*(random(1000)+1)/1000; if Intention<=0 then Intention:=0.05*(random(1000)+1)/1000; Intention_now:=Intention; end; end else begin Society[i].age:=0; Society[i].Resources:=0; popn:=popn-1; end; end else begin Society[i].age:=0; Society[i].Resources:=0; popn:=popn-1; end; end; procedure TForm1.EvolveSoc; {This procedure runs the social simulation for many generations} var ii:LongInt;i,j,k,h:word; begin ii:=1; while (ii<=EvoSteps) and (csn<=0.9*mxsn) and (popn>0) and (csn>0) do begin ii:=ii+1; Time:=ii; MatchMaking3; Communications; ResourceUpdate; write(fr,RiskF,';',delta,';',maxngb,';',mutrate,';',mem_disc,';'); write(fr,collabs:8:6,';',cheaters:8:6,';',nocolls:8:6,';',baleks:8:6,';',popn,';'); write(fr,gcollabs:8:6,';',gcheaters:8:6,';',gnocolls:8:6,';'); write(fr,avglcx:8:6,';',siglcx:8:6,';'); write(fr,LimF:8:6,';',Mo:8:6,';',Vo:8:6,';',Ms:8:6,';',Vs:8:6,';',Me:8:6,';',Ve:8:6,';'); write(fr,Vor:8:6,';',Vsr:8:6,';',Ver:8:6); writeln(fr); TimeLabel.Caption:=IntToStr(Time); PSLabel.Caption:=IntToStr(popn); Refresh; end; end; procedure TForm1.Cycle(a,b:word); {This procedure calls the initialisation - creation of the society, and then calls the procedure running the social simulation} var s,fl:string; begin s:=IntToStr(a); fl:=fname+'_'+s; s:=IntToStr(b); fl:=fl+'_'+s+'.txt'; Randomize; AssignFile(fr,fl); Rewrite(fr); Refresh; GenSoc; EvolveSoc; CloseFile(fr); end; procedure TForm1.StartButtonClick(Sender: TObject); {This is the main procedure running the simulations many times for each selected level of environmental harshness} var i,j,k:word; begin for j:=1 to 20 do for i:=1 to 5 do begin RiskF:=0.3; case i of 1:LimF:=0.0; {0.0} 2:LimF:=0.1; 3:LimF:=0.2; 4:LimF:=0.3; 5:LimF:=0.4; end; {G2V1A} Cycle(i,j); end; end; end.