Mathematica code to test bipartite subgraph algorithm

deleteedge[graph_] :=
  EdgeDelete[graph, #] & /@
   Commonest[
    Sort /@ Flatten@
      Table[FindCycle[graph, {m}, All], {m, 3, VertexCount[graph],
        2}]];
sequence[graph_] :=
  Module[{l = {{graph}}},
   While[! Or @@ (BipartiteGraphQ /@ l[[-1]]),
    AppendTo[l,
     Gather[Join @@ (deleteedge /@ l[[-1]]), IsomorphicGraphQ][[All,
       1]]]]; l];
With[{g =
   Graph[UndirectedEdge @@@ {{1, 2}, {1, 3}, {1, 6}, {1, 7}, {1,
       8}, {2, 3}, {2, 4}, {2, 6}, {2, 7}, {2, 8}, {3, 5}, {3, 6}, {3,
        8}, {4, 6}, {4, 7}, {4, 8}, {5, 8}, {6, 8}}]}, {EdgeCount[
   g], {BipartiteGraphQ[#], EdgeCount[#]} & /@ sequence[g][[-1]]}]