Figures for `Some  planar isospectral domains'
Version 1.0

General Definitions

Needs["DiscreteMath`Combinatorica`"]

DrumNbr[d_,i_,s_]:=d[[s,i]];
DrumAdjacent[d_,i_,j_]:=
	DrumNbr[d,i,1]==j ||
	DrumNbr[d,i,2]==j ||
	DrumNbr[d,i,3]==j;


DrumGraph[d_]:=
	MakeGraph[Range[Length[d[[1]]]],DrumAdjacent[d,#1,#2]&];

Triangle[a_,b_,c_]:=Module[{x,y,z},
	x=Pi/2 (b+c-a)/(a+b+c);
	y=Pi/2 (a+c-b)/(a+b+c);
	z=Pi/2 (a+b-c)/(a+b+c);
	Map[N[{Cos[#],Sin[#]}]&,{-z,Pi+z,Pi/2+x-y}]
];

Flip[{a_,b_,c_}]:=Module[{x=a-c,y=b-c},
	{c+ (-1)x+2 (x.y)/(y.y)y,b,c}
];
Flip[t_,n_]:=RotateLeft[Flip[RotateLeft[t,n-1]],-(n-1)];

DrumDomain[d_,t_,start_]:=Module[
	{n=Length[d[[1]]],scanorder,regions,i,j,k,side},
	regions=Table[{},{n}];
	regions[[start]]=t;
	scanorder=BreadthFirstTraversal[DrumGraph[d],start];
	Do[
		i=scanorder[[k]];
		j=DrumNbr[d,i,side];
		If[regions[[i]]!={} && regions[[j]]=={},
			regions[[j]] = Flip[regions[[i]],side]],
		{k,1,Length[scanorder]},
		{side,1,3}
	];
	{d,regions}
];

DrumSideStyle0 = Module[
	{
	int=AbsoluteThickness[.5],
	ext=AbsoluteThickness[3],
	side1=AbsoluteDashing[{}],
	side2=AbsoluteDashing[{}],
	side3=AbsoluteDashing[{}]
	},
	{
		{{int,side1},{int,side2},{int,side3}},
		{{ext,side1},{ext,side2},{ext,side3}},
	}
];
DrumSideStyle1 = Module[
	{
	int=AbsoluteThickness[.5],
	ext=AbsoluteThickness[3],
	side1=AbsoluteDashing[{1,5}],
	side2=AbsoluteDashing[{10,10}],
	side3=AbsoluteDashing[{}]
	},
	{
		{{int,side1},{int,side2},{int,side3}},
		{{ext,side1},{ext,side2},{ext,side3}},
	}
];
DrumSideStyle=DrumSideStyle1;	
	
DrumTriangle[t_,label_,exterior_]:={
	GrayLevel[1.],Polygon[t],GrayLevel[0],
	Text[label,(t[[1]]+t[[2]]+t[[3]])/3],
	DrumSideStyle[[ If[exterior[[1]],2,1], 1 ]]~Join~
	{Line[{t[[2]],t[[3]]}]},
	DrumSideStyle[[ If[exterior[[2]],2,1], 2 ]]~Join~
	{Line[{t[[1]],t[[3]]}]},
	DrumSideStyle[[ If[exterior[[3]],2,1], 3 ]]~Join~
	{Line[{t[[1]],t[[2]]}]}
};

DrumDomainGraphics[{d_,regions_},label_]:=Module[
	{i,s},
	Graphics[
		Table[
			DrumTriangle[
				regions[[i]],
				label[i-1],
				Table[DrumNbr[d,i,s]==i,{s,3}]
			],
			{i,Length[regions]}
		],
		AspectRatio->Automatic
	]
];

StretchOut[s1_,s2_]:={s1[[1]],
	s1[[1]]+Max[s1[[2]]-s1[[1]],s2[[2]]-s2[[1]]]};
StretchRange[r1_,r2_]:=
	{StretchOut[r1[[1]],r2[[1]]],StretchOut[r1[[2]],r2[[2]]]}
ExpandRange[g1_,g2_]:=
	StretchRange[FullOptions[g1,PlotRange],
		FullOptions[g2,PlotRange]]

DrumLabel0[i_]:= "";
DrumLabel1[i_]:= i;
DrumLabel2[i_]:= If[i==0,"0",""];
DrumLabel=DrumLabel0;
DrumLabelLeft:=DrumLabel;
DrumLabelRight:=DrumLabel;

DrumPairGraphics[dd_,t_,{start1_,start2_}]:=Module[
	{g1,g2,gg,g1new,g2new,p},
	g1=DrumDomainGraphics[DrumDomain[dd[[1]],t,start1+1],
		DrumLabelLeft];	
	g2=DrumDomainGraphics[DrumDomain[dd[[2]],t,start2+1],
		DrumLabelRight];
	g1new=Show[g1,
		PlotRange->ExpandRange[g1,g2],DisplayFunction->Identity];
	g2new=Show[g2,
		PlotRange->ExpandRange[g2,g1],DisplayFunction->Identity];
	{FullOptions[g2,PlotRange],FullOptions[g2new,PlotRange]};
	GraphicsArray[{g1new,g2new}]
];

DrumPair[dd_,a_,b_,c_,start_:{0,0}]:=
	DrumPairGraphics[dd,Triangle[a,b,c],start];

ShowDrumPair[dd_,a_,b_,c_,start_]:=
	Show[DrumPair[dd,a,b,c,start]];
ShowDrumPair[dd_,a_,b_,c_]:=
	ShowDrumPair[dd,a,b,c,{0,0}];
ShowDrumPair[dd_,start_]:=
	ShowDrumPair[dd,60,60,60,start];
ShowDrumPair[dd_]:=
	ShowDrumPair[dd,60,60,60,{0,0}];

ShowLabel[g_,label_]:=Show[
	Graphics[{
		Rectangle[{0,0},{1,1},g],
		Text[label,{.5,-.1}],
		Text["",{.5,-.2}]
	}]
];

FromCyclesNum[cyc_List,n_Integer] := 
	Module[{p=Range[n], pos},
		Scan[
			(pos = Last[#];
			 Scan[ Function[c, pos = p[[pos]] = c], #])&,
			cyc
		];
		p
	];

ConjugatePermutation[p_?PermutationQ,q_?PermutationQ]:=
	Permute[q,Permute[p,q]];
Conj=ConjugatePermutation;

ConjugatePermutation2[p_,q_]:=Thread[ConjugatePermutation[p,q]];
Conj2=ConjugatePermutation2;

C2[a_,b_]:=ConjugatePermutation2[a,b];
C2[a_,b_,c_]:=C2[a,C2[b,c]];
C2[a_,b_,c_,d_]:=C2[a,C2[b,c,d]];
C2[a_,b_,c_,d_,e_]:=C2[a,C2[b,c,d,e]];

LeftBraid[{a_,b_,c_}]:={ConjugatePermutation[b,a],a,c};
RightBraid[{a_,b_,c_}]:={a,c,ConjugatePermutation[b,c]};
UnLeftBraid[{a_,b_,c_}]:={b,ConjugatePermutation[a,b],c};
UnRightBraid[{a_,b_,c_}]:={a,ConjugatePermutation[c,b],b};

DrumLeft[d_]:=Map[LeftBraid,d];
DrumRight[d_]:=Map[RightBraid,d];
DrumUnLeft[d_]:=Map[UnLeftBraid,d];
DrumUnRight[d_]:=Map[UnRightBraid,d];

Prep[l_,n_]:=FromCyclesNum[l+1,n];

Drum2[a_,b_,c_]:=Transpose[{a,b,c}];

PermutationMatrix[p_?PermutationQ]:=
	Permute[IdentityMatrix[Length[p]],p];
DrumAdjacencyMatrix[d_List]:=
	a PermutationMatrix[d[[1]]] +
	b PermutationMatrix[d[[2]]] +
	c PermutationMatrix[d[[3]]];
NeumannMatrix[d_List]:= 
	(a+b+c) IdentityMatrix[Length[ d[[1]] ]] - 
		DrumAdjacencyMatrix[d];
DirichletMatrix[d_List]:= 
	(a+b+c) IdentityMatrix[Length[ d[[1]] ]] + 
		NegateOffDiagonal[DrumAdjacencyMatrix[d]];
OffDiagonal[m_]:= (1 - IdentityMatrix[Length[m]]) m;
NegateOffDiagonal[m_]:= m - 2 OffDiagonal[m];
NeumannPolynomial[d_List]:=
	CharacteristicPolynomial[NeumannMatrix[d],x];
DirichletPolynomial[d_List]:=
	CharacteristicPolynomial[DirichletMatrix[d],x];
DrumPairTest[p_]:=
	{NeumannPolynomial[p[[1]]] === 
		NeumannPolynomial[p[[2]]],
	 DirichletPolynomial[p[[1]]] ===
	 	DirichletPolynomial[p[[2]]]};

Preliminary Definitions

Module[{a1,a2,b1,b2,c1,c2,d1,d2,e1,e2,f1,f2,g1,g2,
	h1,h2,i1,i2,j1,j2,k1,k2,l1,l2,p1,p2,q1,q2,r1,r2,
	a,b,c,d,e,f,g,h,i,j,k,l,p,q,r,
	aa,bb,cc,dd,ee,ff,gg,hh,ii,jj,kk,ll,pp,qq,rr,
	eee},

a1=Prep[{{0,1},{2,5}},7];
a2=Prep[{{0,4},{2,3}},7];

b1=Prep[{{0,2},{4,3}},7];
b2=Prep[{{0,1},{4,6}},7];

c1=Prep[{{0,4},{1,6}},7];
c2=Prep[{{0,2},{1,5}},7];

a={a1,a2};
b={b1,b2};
c={c1,c2};
aa=Conj2[a,c];
bb=Conj2[b,a];


d1=Prep[{{0,12},{1,10},{3,5},{6,7}},13];
d2=Prep[{{0,4},{2,3},{6,8},{9,10}},13];

e1=Prep[{{0,10},{3,4},{9,2},{5,8}},13];
e2=Prep[{{0,12},{6,9},{5,11},{1,4}},13];

f1=Prep[{{0,4},{9,12},{1,6},{2,11}},13];
f2=Prep[{{0,10},{5,1},{2,7},{3,12}},13];

d={d1,d2};
e={e1,e2};
f={f1,f2};
ee=Conj2[e,d];
dd=Conj2[d,f];
ff=Conj2[f,ee];
eee=Conj2[ee,dd];


g1=Prep[{{0,2},{1,7},{3,6},{5,10}},13];
g2=Prep[{{0,7},{3,11},{6,8},{9,12}},13];

h1=Prep[{{0,6},{3,8},{9,5},{2,4}},13];
h2=Prep[{{0,8},{9,7},{5,11},{1,10}},13];

i1=Prep[{{0,5},{9,11},{1,2},{6,12}},13];
i2=Prep[{{0,11},{1,8},{2,7},{3,4}},13];

g={g1,g2};
h={h1,h2};
i={i1,i2};
hh=Conj2[h,g];
gg=Conj2[g,i];
ii=Conj2[i,gg];


j1=Prep[{{0,14},{4,5},{9,10},{1,12},{7,11},{2,6}},15];
j2=Prep[{{0,11},{1,5},{3,4},{6,10},{8,9},{13,14}},15];

k1=Prep[{{4,6},{1,13},{8,9},{2,7}},15];
k2=Prep[{{0,10},{1,2},{6,9},{12,14}},15];

l1=Prep[{{14,1},{3,4},{12,2},{8,11}},15];
l2=Prep[{{0,5},{2,4},{6,7},{11,14}},15];

j={j1,j2};
k={k1,k2};
l={l1,l2};
ll=Conj2[l,j];
jj=Conj2[j,k];
kk=Conj2[k,ll];


p1=Prep[{{2,7},{3,11},{5,12},{8,18},{13,14},{15,17},{16,20}},21];
p2=Prep[{{0,1},{4,17},{7,12},{9,16},{10,20},{11,13},{15,19}},21];

q1=Prep[{{0,17},{3,8},{4,12},{6,13},{9,19},{14,15},{16,18}},21];
q2=Prep[{{0,20},{3,16},{6,11},{8,15},{9,19},{10,12},{14,18}},21];

r1=Prep[{{1,8},{2,16},{4,11},{5,19},{7,14},{10,17},{13,20}},21];
r2=r1;

p={p1,p2};
q={q1,q2};
r={r1,r2};

D71=Drum2[a,b,c];
D72=Drum2[a,bb,c];
D73=Drum2[aa,bb,c];

D131=Drum2[d,e,f];
D132=Drum2[d,ee,f];
D133=Drum2[dd,ee,f];
D134=Drum2[dd,ee,ff];
D135=Drum2[dd,eee,ff];

D136=Drum2[g,h,i];
D137=Drum2[g,hh,i];
D138=Drum2[gg,hh,i];
D139=Drum2[gg,hh,ii];

D151=Drum2[j,k,l];
D152=Drum2[j,k,ll];
D153=Drum2[jj,k,ll];
D154=Drum2[jj,kk,ll];

D211=Drum2[p,q,r];
]

Clear[ShowFig0,ShowFig];

Fig0[d_,a_,b_,c_]:= Block[
	{DrumLabel=DrumLabel0,DrumSideStyle=DrumSideStyle0},
	DrumPair[d,a,b,c]
];
Fig0[d_]:=Fig0[d,60,60,60];
ShowFig0[d_,a_,b_,c_]:= Show[Fig0[d,a,b,c]];
ShowFig0[d_]:=Show[Fig0[d,60,60,60]];

Fig[d_,a_,b_,c_]:= Block[
	{DrumLabel=DrumLabel2,DrumSideStyle=DrumSideStyle0},
	DrumPair[d,a,b,c]
];
Fig[d_]:=Fig[d,60,60,60];

Figures

Figure homophonic

Show[Fig0[D211,90,60,30]];

Figure propeller

Show[Block[
	{DrumLabel=DrumLabel1,DrumSideStyle=DrumSideStyle1},
	DrumPair[D71,60,60,60]]];

Figure warped

Fig4Label1[i_]:=
	{"0","1","2","3","4","5","6"}[[i+1]];
Fig4Label2[i_]:=
	{"1+2+4","0+3-1","0+6-2","1-6-5","0+5-4","4-3-6","2-5-3"}[[i+1]];

Block[
	{DrumLabelLeft=Fig4Label1,DrumLabelRight=Fig4Label2,
	DrumSideStyle=DrumSideStyle1},
	Show[DrumPair[D71,60,45,75]];
];

Figure examples

Invididual diagrams.

F71=ShowLabel[Fig[D71],Subscripted[7[1]]];

F72=ShowLabel[Fig[D72],Subscripted[7[2]]];

F73=ShowLabel[Fig[D73],Subscripted[7[3]]];

F131=ShowLabel[Fig[D131],Subscripted[13[1]]];

F132=ShowLabel[Fig[D132],Subscripted[13[2]]];

F133=ShowLabel[Fig[D133],Subscripted[13[3]]];

F134=ShowLabel[Fig[D134],Subscripted[13[4]]];

F135=ShowLabel[Fig[D135],Subscripted[13[5]]];

F136=ShowLabel[Fig[D136],Subscripted[13[6]]];

F137=ShowLabel[Fig[D137],Subscripted[13[7]]];

F138=ShowLabel[Fig[D138],Subscripted[13[8]]];

F139=ShowLabel[Fig[D139],Subscripted[13[9]]];

F151=ShowLabel[Fig[D151],Subscripted[15[1]]];

F152=ShowLabel[Fig[D152],Subscripted[15[2]]];

F153=ShowLabel[Fig[D153],Subscripted[15[3]]];

F154=ShowLabel[Fig[D154],Subscripted[15[4]]];

F211=ShowLabel[Fig[D211],Subscripted[21[1]]];

The figure itself.

Show[GraphicsArray[{
		{F71,F72,F73},
		{F131,F132,F133},
		{F134,F135,F136},
		{F137,F138,F139},
		{F151,F152,F153},
		{F154,F211}
	}],
	GraphicsSpacing->0];

Examples from PSL(3,2).

F7=Show[GraphicsArray[
	{F71,F72,F73}],
	GraphicsSpacing->0];

Examples from PSL(3,3).

F13=Show[GraphicsArray[
	{{F131,F132},{F133,F134},{F135,F136}}],
	GraphicsSpacing->0];

Examples from PSL(4,2).

F15=Show[GraphicsArray[
	{{F151,F152},{F153,F154}}],
	GraphicsSpacing->0];

Examples from PSL(3,4).

F21=Show[F211];

Figure special

Invididual diagrams.

S1=ShowFig0[D73,45,45,90];

S2=ShowFig0[D73,60,45,75];

S3=ShowFig0[D71,60,45,75];

S4=ShowFig0[D72,60,45,75];

S5=ShowFig0[D73,60,90,30];

S6=ShowFig0[D71,30,60,90];

S7=ShowFig0[D138,60,30,90];

S8=ShowFig0[D211,90,60,30];

S9=ShowFig0[D72,70, 30, 80];

S10=ShowFig0[D73,30, 70, 80];

S11=ShowFig0[D134,40, 90, 50];

S12=ShowFig0[D135,110, 30, 40];

S13=ShowFig0[D136,58, 66, 56];

S14=ShowFig0[D154,60, 50, 70];

S15=ShowFig0[D73,40,30,110];

The figure itself.

Show[GraphicsArray[
	{{S1,S2,S3},{S4,S5,S6},{S7,S8,S9},
	{S10,S11,S12},{S13,S14,S15}}],
	GraphicsSpacing->0];