Needs["DiscreteMath`Combinatorica`"]

(* sets number of agents in model*)

n = 21;

time = 100;

(* defines matrix of social attributes for agents*)

att = Table[Random[], {n}, {2}] ;

(* defines matrix of extroversion/introversion for agents*)

e = n ;

strangers = Module[{i, v, perm},

v = Table[0, {n}] ;

perm = RandomPermutation[n] ;

For[i = 1, i <= e, i++, v[[perm[[i]]]] = .4] ;

v] ;

(* defines matrix of existing acquaintance network between agents*)

d = 0.5;

inetwork = Module[{net, i, j} ,

net = Table[0, {n}, {n}] ;

For[i = 1, i <= n, i++,

For[j = i + 1, j <= n, j++,

If[Random[] < d, net[[i, j]] = 1]]] ;

net = net + Transpose[net] ;

net] ;

(* creates distance between agents based on social attributes*)

dist[i_, j_] :=

Sqrt[(att[[i, 1]] - att[[j, 1]])^2 + (att[[i, 2]] - att[[j, 2]])^2] ;

distance = Table[dist[i, j], {i, n}, {j, n}] ;

(* probability agents continue interacting based on social distance*)

proba[d_] := (1/(d + 1))^3 ;

neighbor[int_, i_] := Module[{j},

j = 1 ;

While[int[[i, j]] == 0, j++] ;

j ] ;

intstep[net_, i_, j_] := Module[{p, network},

p = proba[distance[[i, j]]] ;

network = net ;

If[Random[] < p,

network[[i, j]] = 1 ;

network[[j, i]] = 1,

network[[i, i]] = 1 ;

network[[j, j]] = 1];

network ] ;

singlestep[cnetwork_, int_, net_, i_] :=

Module[{network, j, perm, jp, test, p},

network = net ;

perm = RandomPermutation[n] ;

j = 1 ;

test = False ;

While[ Not[test] && j <= n,

jp = perm[[j]] ;

If[

int[[jp, jp]] == 1 && Sum[net[[jp, k]], {k, 1, n}] == 0 && jp != i,

If[cnetwork[[i, jp]] == 0, p = strangers[[i]],

p = proba[distance[[i, jp]]]];

If[Random[] < p, network[[i, jp]] = 1 ; network[[jp, i]] = 1 ;

test = True]] ;

j++] ;

If[! test, network[[i, i]] = 1] ;

network] ;

(* function creates pattern of interactions for upcoming round *)

nextstep[cnetwork_, int_] := Module[{i, j, net, ip, perm} ,

net = Table[0, {n}, {n}] ;

perm = RandomPermutation[n] ;

For[i = 1, i <= n, i++,

ip = perm[[i]] ;

If[Sum[net[[ip, j]], {j, 1, n}] == 0,

If[int[[ip, ip]] == 0,

j = neighbor[int, ip] ;

net = intstep[net, ip, j],

net = singlestep[cnetwork, int, net, ip]]]] ;

net] ;

process[time_] := Module[{t, cnetwork, frequency, int},

cnetwork = inetwork ;

frequency = Table[0, {n}, {n}] ;

int = IdentityMatrix[n] ;

For[t = 1, t <= time, t++,

int = nextstep[cnetwork, int] ;

cnetwork = cnetwork + int ;

frequency = frequency + int ] ;

frequency] ;

alone[f_] := Module[{i, rep},

rep = 0 ;

For[i = 1, i <= n, i++,

rep = rep + f[[i, i]]] ;

rep] ;

density[f_] := Module[{i, j, rep},

rep = 0 ;

For[i = 1, i <= n, i++,

For[j = i + 1, j <= n, j++,

If[f[[i, j]] > 0, rep = rep + 1]]] ;

rep ] ;

number

att

data1 = Table[0, {32}] ;

data2 = Table[0, {32}] ;

data3 = Table[0, {32}] ;

k = 1 ;

For[e = 0, e <= n, e = e + 5,

strangers = Module[{i, v, perm},

v = Table[0, {n}] ;

perm = RandomPermutation[n] ;

For[i = 1, i <= e, i++, v[[perm[[i]]]] = .4] ;

v] ;

Print["Number of extrovert ", e] ;

For[d = 0, d <= .5, d = d + .1,

inetwork = Module[{net, i, j} ,

net = Table[0, {n}, {n}] ;

For[i = 1, i <= n, i++,

For[j = i + 1, j <= n, j++,

If[Random[] < d, net[[i, j]] = 1]]] ;

net = net + Transpose[net] ;

net] ;

pro = process[time] ;

data1[[k]] = density[inetwork] ;

data2[[k]] = density[pro] ;

data3[[k]] = alone[pro] ;

k++]] ;

MatrixForm[data1]

MatrixForm[data2]

MatrixForm[data3]

Export["data1.dat", data1]

Export["data2.dat", data2]

Export["data3.dat", data3]