(* Problem 1 *)

(* on 1,-1 matrices  *)

(* The file containing the slides of my talk *)

(* is the clickable item "Montecarlo talk" *)

asu[v_]:=Subscript[a,v]

asu[{1,2}]

rollo:=1-2 Random[Integer,{0,1}]

Table [rollo,{40}]

makemath[n_]:=Table[Table[rollo,{n}],{n}]

amath[n_]:=Do[asu[{i,j}]=rollo,{i,1,n},{j,1,n}]

a[i_,j_]:=asu[{i,j}]

(*The next command constructs a matrix with entries  1,-1 *)

amath[10]

(*The next command prints out the resulting matrix *)

MatrixForm[Table[a[i,j],{i,1,10},{j,1,10}]]

(* This procedure constructs a random vector Y and *) (* computes the corresponding sum as described for Problem 1*)

mksum[n_]:=Block[{i,j,ut},
(Y=Table[rollo,{n}];
ut=0;
Do[te=Sum[a[i,j] Y[[j]],{j,1,n}];
If[te>0,ut=ut+te,ut=ut-te],{i,1,n}];
Return[ut]
)
]

(* The next command prints out 300 samples of the sum*)

boo=Table[mksum[10],{300}]

adm[V_]:=Sum[V[[i]],{i,1,Length[V]}]

(* the next procedure computes the approximate expected  value for the sum*)

(* Using the Central Limit Theorem*)

exp[n_]:=N[n Sqrt[n]Sqrt[2/Pi]]

exp[10]

(* the next procedure computes the expected  value for the sum*)

(* using the binomial distribution*)

bino[n_]:=N[Sum[n Binomial[n,i] Abs[2 i-n],{i,0,n}]/2^n]

bino[10]

(* counting the number of times the sum was above its expected value*)

tst[u_]:=If[u>bino[10],1,0]

Map[tst,boo]

adm[%]

(* ALMOST HALF THE TIME !!*)

Position[{1,2,3},2][[1]][[1]]

(* Problem 2 *)

(* sum free subsets*)

(* This procedure constructs a random set of n integers in the range  [1,M]  *)

pickraset[M_,n_]:=Block[{SS,ut},
(SS=Sort[Table[Random[Integer,{1,M}],{n}]];
Return[SS]
)
]

(* This procedure constructs all k-subsets of the set[1,n] *)

mksubs[n_,k_]:=Block[{sus,i},
(sus=Subsets[Table[i,{i,1,n}],{k}];
Return[sus]
)
]

mksubs[5,3]

(* This procedure tests  if T is sum-free *)

tstSumFree[T_]:=Block[{n,ut,s},
(n=Length[T];
ut=True;
Do[
s=T[[i]]+T[[j]]; (* Print[i,j,"  -> ",s];*) 
If[MemberQ[T,s],(*Print[i,j];*)ut=False;Return[False]],{i,1,n-1},{j,i+1,n}];
Return[ut])
]

(* This procedure prints out all the triplets a,b,c in T with a+b=c *)

PtstSumFree[T_]:=Block[{n,ut,s},
(n=Length[T];
ut=True;
Do[
s=T[[i]]+T[[j]];    
If[MemberQ[T,s], Print[i," , ",j," -> ",Position[T,s][[1]][[1]]]; ut=False],{i,1,n-1},{j,i+1,n}];
Return[ut])
]

pcksubset[T_,SS_]:=Table[SS[[T[[i]]]],{i,1,Length[T]}]

(* This procedure finds among all n/3-subsets of S the lex-first that is sum free *)

gtsumfree[SS_]:=Block[{n,ut,k,Tees,T,ST,i,j},
(n=Length[SS];
ut={};
k=Ceiling[n/3];
Tees=mksubs[n,k];Print[n," choose ",k," = ",Length[Tees]];
Do[T=Tees[[i]]; 
ST=pcksubset[T,SS];If[tstSumFree[ST],ut=ST;
Print["subset ",i,"  is sumfree "];Return[ut] ],{i,1,Length[Tees]}];
Return[ut] 
)
]

subtra[x_,S_]:=Table[S[[i]]-x,{i,1,Length[S]}]

SS=subtra[40,pickraset[150,27]]

SSS=Union[SS]

goo= {-37,-36,-35,-31,-28,-22,-19,-2,0,3,4,6,8,11,12,15,19,24,28,33,34,50,62,77,109}

Length[goo]

PtstSumFree[goo]

gtsumfree[SSS]

good ={3,7,10,12,15,23,26,34,47,49,55,62,74,81,87,88,91,102,104,114,123,124,126}

Length[good]

PtstSumFree[good]

gtsumfree[good]

SSS=Union[pickraset[150,27]]

Length[SSS]

PtstSumFree[SSS]

False

(* Problem 3 *)

(* two-colorings of the edges of  Kn *)

(*  with no monochromatic a-clique *)

(* the expected number of monochromatic a-cliques in a random 2-coloring*)

totexp[n_,a_]:=N[Binomial[n,a] 2/2^(a(a-1)/2)]

(* finding the smallest a for which this expectation is <1 *)

nPfindbesta[n_]:=Block[{E,a},
(Do[
E=totexp[n,a];
If[E<1,ut=a;Return[ut]],{a,1,n}];
Return[ut]
)
]

(* prints all the expectations for 1≤ a <= n *)

findbesta[n_]:=Block[{E,a},
(Do[
E=totexp[n,a];
If[E<1,ut=a;Print[" for n=",n,"  and   a = ",a," The expectation is ",E];Return[ut]],{a,1,n}];
Return[ut]
)
]

(* table of smallest a and predicted a for 10,= n ≤ 30 *)

MatrixForm[Transpose[Table[{n,nPfindbesta[n],Round[N[2Log[2,n]] ]},{n,10,30}]]]

(* table of probabilities for the smallest   a for 10<= n ≤ 20 *)

Do[findbesta[n],{n,10,20}]

(* the expectations for n=25 *)

Table[{a,totexp[25,a]},{a,1,7}]

(*counting monochromatic a-cliques  *)

ZOrollo:=Random[Integer,{0,1}]

Csu[v_]:=Subscript[C,v]

(* Constructs a random 2-coloring of the edges of Kn  *)

colorK[n_]:=Do[Csu[{i,j}]=ZOrollo,{i,1,n-1},{j,i+1,n}]

colorK[20]

CC[i_,j_]:=Csu[{i,j}]

(* A random  2-coloring for  n=20  *)

GG20=MatrixForm[Table[CC[i,j],{i,1,19},{j,i+1,20}]]

Binomial[20,2]

(* the number of 2-colorings of K20 *)

2^Binomial[20,2]

(* procedure to depict a 2 colored clique with vertex set T *)

depict[T_]:=Print[T," -> ",MatrixForm[Table[CC[T[[i]],T[[j]]],{i,1,Length[T]-1},{j,i+1,Length[T]}]]]

(* procedure to test if a clique is monochromatic *)

tstmono[T_]:=Block[{a,S,ut,i,j},
(a=Length[T];
S=Sum[CC[T[[i]],T[[j]]],{i,1,a-1},{j,i+1,a}];
ut=(S==a(a-1)/2)||(S==0);
Return[ut]
)
]

tstmono[{1,2,3,4,5}]

(* procedure to count the number of monochromatic a-cliques *)

countmono[n_,a_]:=Block[{Tees,T,i,ut},
(Tees=mksubs[n,a];Print[Length[Tees]];
ut=0;
Do[
T=Tees[[i]];If[tstmono[T],ut=ut+1;depict[T]],{i,1,Length[Tees]}];
Return[ut]
)
]

NPcountmono[n_,a_]:=Block[{Tees,T,i,ut},
(Tees=mksubs[n,a];(* Print[Length[Tees]];*)
ut=0;
Do[
T=Tees[[i]];If[tstmono[T],ut=ut+1],{i,1,Length[Tees]}];
Return[ut]
)
]

Binomial[20,7]

Binomial[20,2]

(* Table of expected number of Monocromatic a-cliques for n=20 *)

MatrixForm[Transpose[Table[{a,totexp[20,a]},{a,2,8}]]]

(* constructs a random 2-coloting of K20  *)

colorK[20]

(* exhibits  all the nonochromatic 6-cliques for this 2-coloring *)

countmono[20,6]

colorK[20]

MatrixForm[Table[CC[i,j],{i,1,19},{j,i+1,20}]]

totexp[20,6]

totexp[15,5]

colorK[20]

countmono[20,5]

(* The Metropolis Algorithm *)

pairs[n_]:=Flatten[Table[{i,j},{i,1,n-1},{j,i+1,n}],1]

pairs[5]

rapair[n_]:=Block[{PRS,m,ut,k,i,j},
(PRS=pairs[n];
m=Length[PRS];
k=Random[Integer,{1,m}];
{i,j}=PRS[[k]];
Return[{i,j}];
)
]

pairs[10]

rapair[10]

Table[rapair [15],{30}]

change[pr_]:=Block[{i,j},
({i,j}=pr;
CC[i,j]=1-CC[i,j];
)
]

change[{5,7}]

CC[5,7]

Random[Real]

flip[p_]:=If[Random[Real]<p,1,0]

Table[flip[.925],{30}]

showit[n_]:=MatrixForm[Table[CC[i,j],{i,1,n-1},{j,i+1,n}]]

metrostep[n_,a_,olct_]:=Block[{mat,nct,i,j,s,ut,p,u,v},
( mat=Table[CC[i,j],{i,1,n-1},{j,i+1,n}];
{u,v}=rapair [n];
CC[u,v]=1-CC[u,v]; 
nct=NPcountmono[n,a];(* Print[" metro ",olct," ",nct];*)
If[nct==0,Print[MatrixForm[mat]];ut=0;Return[ut]];
If [nct>olct,
p=olct/nct;s=flip[p];
If[s==0, CC[u,v]=1-CC[u,v];
ut=olct,ut=nct  ],ut=nct  ];
  Return[ut])
]

olct

totexp[14,5]

colorK[14]

showit[14]

countmono[14,5]

colorK[14]

countmono[14,5]

m=6

ct=0

While[m>0 && ct<60,m=metrostep[14,5,m];ct=ct+1;Print[ct,"  ",m]]

totexp[15,4]

(* searching for a 2-coloring of the edges of Kn with some
monochromatic a-cliques*)

searchit[n_,a_,m_]:=Block[{ci,monos},
(ct=0;
monos=0;
While[ct<m
&&monos==0,
ct=ct+1;
colorK[n];
monos=countmono[n,a];
If[monos>0,Print[ct,"  -> ",monos],Print[ct]]];
Print["===="])
   ]

totexp[15,6]

searchit[15,5,200]

countmono[15,5]

totexp[16,5]

a=2

ct=0

While[a>0 && ct<30,a=metrostep[16,5,a];ct=ct+1;Print[" -> ",ct,"  ",a]]

countmono[15,5]

a

showit[16]