n=54;
(Subscript[g, 1])=AP[1,Cycles[{{1,18,45,28},{2,27,44,19},{3,36,43,10},{46,52,54,48},{47,49,53,51}}]];
(Subscript[g, 2])=AP[1,Cycles[{{7,16,39,30},{8,25,38,21},{9,34,37,12},{13,15,33,31},{14,24,32,22}}]];
(Subscript[g, 3])=AP[1,Cycles[{{28,31,34,48},{29,32,35,47},{30,33,36,46},{37,39,45,43},{38,42,44,40}}]];
(Subscript[g, 4])=AP[1,Cycles[{{1,3,9,7},{2,6,8,4},{10,54,16,13},{11,53,17,14},{12,52,18,15}}]];
(Subscript[g, 5])=AP[1,Cycles[{{1,13,37,46},{4,22,40,49},{7,31,43,52},{10,12,30,28},{11,21,29,19}}]];
(Subscript[g, 6])=AP[1,Cycles[{{3,48,39,15},{6,51,42,24},{9,54,45,33},{16,18,36,34},{17,27,35,25}}]];

(Subscript[g, 1])

AP /: PermutationProduct[AP[k1_,p1_],AP[k2_,p2_]] :=AP[k1+k2,PermutationProduct[p1,p2]];
AP /: PermutationSupport[AP[_,p_]] := PermutationSupport[p];
AP /: PermutationReplace[i_, AP[_, p_]] := PermutationReplace[i,p];
AP/: InversePermutation[AP[k_,p_]] := AP[k, InversePermutation[p]];

PermutationProduct[(Subscript[g, 1]),(Subscript[g, 3])]

Clear[σ];
σ_∘τ_ := PermutationProduct[τ, σ];
Feed[AP[_,Cycles[{}]]]:=Null;
Feed[τ_]:=Module[{i,j,k,l,p},
i=Min[PermutationSupport[τ]];
j=PermutationReplace[i, τ];
If[Head[σ[i,j]]===AP,
p=InversePermutation[σ[i,j]]∘τ;
If[σ[i,j][[1]]>τ[[1]],σ[i,j]=τ];
Feed[p],
(*Else*) σ[i,j]=τ;
For[k=1, k<n, ++k,
For[l=k+1, l≤n, ++l,
If[Head[σ[k,l]]===AP,
Feed[σ[i,j]∘σ[k,l]]; Feed[σ[k,l]∘σ[i,j]]]
]]
]];
$RecursionLimit=∞;

Feed[(Subscript[g, 1])]

?σ

a=1

?a

(Subscript[b, 1]) // FullForm

Table[Feed[(Subscript[g, α])];(∏_(i=1)^n)(1+Count[Range[n], j_ /; Head[σ[i,j]]==AP]), {α, 6}] // Timing

?σ

DiscretePlot3D[Table[
If[Head[σ[i,j]]===AP, σ[i,j][[1]], 0],
{j,n},{i,n}], PlotRange->All]

ListPlot3D[Table[If[Head[σ[i,j]]===AP,σ[i,j][[1]],0],{j,n},{i,n}],PlotRange->All] // Rasterize