Advertisement
Guest User

Mathematica code to test bipartite subgraph algorithm

a guest
Sep 9th, 2014
358
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. deleteedge[graph_] :=
  2. EdgeDelete[graph, #] & /@
  3. Commonest[
  4. Sort /@ Flatten@
  5. Table[FindCycle[graph, {m}, All], {m, 3, VertexCount[graph],
  6. 2}]];
  7. sequence[graph_] :=
  8. Module[{l = {{graph}}},
  9. While[! Or @@ (BipartiteGraphQ /@ l[[-1]]),
  10. AppendTo[l,
  11. Gather[Join @@ (deleteedge /@ l[[-1]]), IsomorphicGraphQ][[All,
  12. 1]]]]; l];
  13. With[{g =
  14. Graph[UndirectedEdge @@@ {{1, 2}, {1, 3}, {1, 6}, {1, 7}, {1,
  15. 8}, {2, 3}, {2, 4}, {2, 6}, {2, 7}, {2, 8}, {3, 5}, {3, 6}, {3,
  16. 8}, {4, 6}, {4, 7}, {4, 8}, {5, 8}, {6, 8}}]}, {EdgeCount[
  17. g], {BipartiteGraphQ[#], EdgeCount[#]} & /@ sequence[g][[-1]]}]
Advertisement
Advertisement
Advertisement
RAW Paste Data Copied
Advertisement