(* :Title: Graph basics *)

(* :Context: "GrafPack`Basics`" *)

(* :Authors:
	D. Andrén, P.H. Lundow (editor), K. Markström
	Department of Theoretical Physics
	KTH
	SE-106 91 Stockholm
	Sweden
	Bug reports to <phl@kth.se>
*)
(* :Summary:
	This package defines the Graph object and contains some standard 
	functions of a graph theoretic  nature.
*)
(* :History:
	001128 Component slightly improved.
	010302 ShortestPath improved.
	010409 Simple bug fixed in Component.
	090202 Bug fixed in GreedyColouring.
        110205 Added special case for Automorphisms.
*)
(* :Mathematica Version: 3.0 *)
(* :Keywords:    *) 
(* :Limitations: *) 
(* :Discussion:  *)

BeginPackage["GrafPack`Basics`", {"GrafPack`Combinatorics`"}]

AddEdge::usage =
	"AddEdge[g, e] returns the graph g with the edge, or list of edges, e 
	added."

AddVertex::usage =
	"AddVertex[g] returns the graph g with one more vertex. AddVertex[g, k] 
	returns the graph g with k vertices added."

Automorphisms::usage =
	"Automorphisms[g] returns the automorphisms of the graph g."

Barycenter::usage =
	"Barycenter[g] returns the list of vertices having minimum row-sum in
	the distance matrix."

BipartiteQ::usage =
	"BipartiteQ[g] returns True if g is a bipartite graph and False otherwise."

Bipartition::usage =
	"Bipartition[g] returns a bipartition of the vertices of the graph g if
	it is bipartite and an empty list otherwise."

BreadthFirstSearch::usage =
	"BreadthFirstSearch[g, v] performs a breadth-first search starting at
	vertex v. The result is a list of edges in the order they are seen.
	BreadthFirstSearch[g, v, w] returns when vertex w has been found.
	If w is found and v != w then {_, w} is the last edge."

Center::usage =
	"Center[g] returns the vertices of minimum eccentricity in graph g."

ChangeEmbedding::usage =
	"ChangeEmbedding[g, emb] returns the graph g with new embedding emb."

CircularEmbedding::usage =
	"CircularEmbedding[n] returns a list of n points in the plane equally 
	spaced on a circle with radius 1 and center at the origin.
	CircularEmbedding[g] returns the graph g with an embedding on the circle.
	CircularEmbedding[n1, n2,.., nk] gives a partitioned circular embedding
	suitable for n-partite graphs."

CliqueNumber::usage =
	"CliqueNumber[g] returns the size of the largest clique in graph g."

CliqueQ::usage =
	"CliqueQ[g, v] returns True if the vertices in list v induce a complete
	subgraph of g."

Closure::usage =
	"Closure[g] returns the Hamiltonian closure of the graph g. This is the
	supergraph of g obtained by iteratively adding edges between pairs of
	non-adjacent vertices whose degree sum is at least Order[g], until no
	such pair remain."

CodeToTree::usage =
	"CodeToTree[list] returns the labelled tree corresponding to the Prufer
	code given by list."

(* Complement::usage *)
If[!StringMatchQ[Complement::usage, "*GrafPack*"],
	Complement::usage = Complement::usage <>
	"\n Complement is also an option for some GrafPack functions."
]

CompleteQ::usage =
	"CompleteQ[g] returns True if g is a complete graph and False otherwise."

Component::usage =
	"Component[g, v] returns the component that vertex v belongs to.
	Component[g, All] returns the list of components in graph g."

ConnectedQ::usage =
	"ConnectedQ[g] returns True if g is a connected graph and False otherwise."

Corona::usage =
	"Corona is an option for the GraphProduct function in GrafPack."

Cyclic::usage =
	"Cyclic is an option for some GrafPack functions."

(* Degree::usage *)
If[!StringMatchQ[Degree::usage, "*Degree[g, v]*"],
	Degree::usage = Degree::usage <>
	"\n Degree[g, v] returns the degree (degrees) of vertex (list of vertices)
	v in the graph g."
]

DegreeSequence::usage =
	"DegreeSequence[g] returns the list of degrees of the vertices in
	the graph g. DegreeSequence[g, Sort] returns the sorted degrees."

DeleteEdge::usage =
	"DeleteEdge[g, e] returns the graph g with the edge, or list of edges,
	e deleted."

DeleteVertex::usage =
	"DeleteVertex[g, v] returns the graph g with vertex, or list of vertices, 
	v deleted."

DepthFirstSearch::usage =
	"DepthFirstSearch[g, v] performs a depth-first search starting at
	vertex v. The result is a list of edges in the order they are seen."

Diameter::usage =
	"Diameter[g] returns the diameter of graph g."

Distance::usage =
	"Distance[g, v, w] returns the distance between vertex v and w in graph g.
	Distance[g, v, All] returns the distance from vertex v to all vertices,
	i.e. the v:th row in the DistanceMatrix."

DistanceMatrix::usage =
	"DistanceMatrix[g] returns the matrix of distances between all pairs of
	vertices in graph g."

Eccentricity::usage =
	"Eccentricity[g, v] returns the eccentricity of vertex v in graph g.
	Eccentricity[g, All] returns the eccentricities of all vertices."

Edge::usage =
	"Edge is an option for some GrafPack functions."

EdgeCut::usage =
	"EdgeCut[g, v, w] returns the edges with one endpoint in set v and the
	other in set w. EdgeCut[g, v] returns the edges with one end in v and the
	other in the complement of v."

EdgeDegree::usage =
	"EdgeDegree[g, e] returns the degree (degrees) of the edge (list of
	edges) e in the graph g. The degree of an edge {u, v} is the number of
	edges incident to the vertices u and v, i.e. deg(u)+deg(v)-1."

EdgeQ::usage =
	"EdgeQ[g, {u, v}] gives True if {u, v} is an edge of the graph g and
	False otherwise."

Embedding::usage =
	"Embedding[g] returns the embedding of the graph g."

EmptyQ::usage =
	"EmptyQ[g] returns True if the graph g has no edges and False otherwise."

FindEdge::usage =
	"FindEdge[g] returns the first edge found in the graph g, or an empty
	list if g has no edges. FindEdge[g, Complement] returns a non-edge,
	i.e. an edge in the complement, or an empty list if g is complete."

FindNeighbour::usage =
	"FindNeighbour[g, v] returns the first found neighbour of vertex v in the
	graph g, or 0 if v has no neighbours. FindNeighbour[g, v, Complement]
	returns the first found non-neighbour of vertex v, i.e. a neighbour in
	the complement, or 0 if v is adjacent to every other vertex."

FromAdjacencyLists::usage =
	"FromAdjacencyLists[adj] returns the simple graph having adjacency lists
	adj. FromAdjacencyLists[adj, emb] gives the graph embedding emb."

FromAdjacencyMatrix::usage =
	"FromAdjacencyMatrix[adj] returns the simple graph with adjacency 
	matrix adj and with a circular embedding. Note that adj must be a
	symmetric 01-matrix with zeros on the diagonal. 
	FromAdjacencyMatrix[adj, emb] gives the graph embedding emb."

FromBiadjacencyMatrix::usage =
	"FromBiadjacencyMatrix[adj] returns the bipartite graph having matrix
	adj as its biadjacency matrix and the embedding of a CompleteGraph[m, n].
	FromBiadjacencyMatrix[adj, emb] gives the graph embedding emb."

FromEdges::usage =
	"FromEdges[e] returns a graph on the least possible number of vertices
	having edges e and a circular embedding. FromEdges[e, n] returns a
	graph on n vertices. FromEdges[e, emb] returns a graph on Length[emb]
	vertices with embedding emb. We may also append an extra keyword All
	to denote that e is all the positions of the adjacency matrix to
	contain 1. We then write FromEdges[e, All], FromEdges[g, n, All] or
	FromEdges[e, emb, All]."

FromIncidenceMatrix::usage =
	"FromIncidenceMatrix[inc] returns the simple graph having incidence
	matrix inc. FromIncidenceMatrix[inc, emb] gives the graph the
	embedding emb."

Graph::usage =
	"Graph is the head used for graph objects. Graph[adj, emb] is a
	simple graph with adjacency matrix adj and embedding emb."

GraphComplement::usage =
	"GraphComplement[g] returns the complement of graph g. 
	GraphComplement[g, v] returns the complement taken in the subgraph
	induced by the vertices in list v."

GraphIntersection::usage =
	"GraphIntersection[g, h] returns the intersection of graphs g and h,
	where g and h have the same order. The graph returned has an edge
	{u, v} iff it is an edge of both g and h. For simple graphs this is
	just the element-wise product of their adjacency matrices."

GraphJoin::usage =
	"GraphJoin[g, h] returns the join of graphs g and h. This is the
	disjoint union of g and h plus every edge between them."

GraphProduct::usage =
	"GraphProduct[g1, g2,.., gk] returns the cartesian product of graphs 
	g1, g2,.., gk.
	GraphProduct[g1, g2,.., gk, Weak] returns the weak graph product.
	GraphProduct[g1, g2,.., gk, Strong] returns the strong graph product.
	GraphProduct[g1, g2,.., gk, Wreath] returns the wreath product.
	GraphProduct[g1, g2,.., gk, Corona] returns the corona product."

GraphSum::usage =
	"GraphSum[g, h] returns the sum of graphs g and h, where g and h have 
	the same order. The graph returned has an edge {u, v} iff it is an edge 
	of g or h. For simple graphs this is just the element-wise sum of their
	adjacency matrices, where 2's are replaced with 1's."

GraphUnion::usage =
	"GraphUnion[g, h] returns the disjoint union of the graph g and h.
	GraphUnion[g, k] returns k copies of the graph g. 
	GraphUnion[g1, g2, g3,...] returns the union of all the graphs gi."

GreedyColouring::usage =
	"GreedyColouring[g] returns a proper colouring of the graph g obtained
	by the greedy algorithm. GreedyColouring[g, p] colours the vertices in
	the order prescribed by the permutation p."

HighDegreeEdge::usage =
	"HighDegreeEdge[g] returns an edge of high, but not necessarily maximum,
	degree. If d is the degree sequence of g then HighDegreeEdge[g, d] is
	slightly faster. If g has no edges then an empty list is returned."

IdentifyVertices::usage =
	"IdentifyVertices[g, v] gives the graph g with the vertices in list v
	identified into a single vertex."

IndependenceNumber::usage =
	"IndependenceNumber[g] returns the size of the largest independent set
	in graph g."

IndependentSetQ::usage =
	"IndependentSetQ[g, v] returns True if the vertices in list v induce
	an empty graph and False otherwise."

InduceSubgraph::usage =
	"InduceSubgraph[g, v] returns the graph g induced by the vertices in
	list v."

LinearEmbedding::usage =
	"LinearEmbedding[n] returns a list of n points equally distributed on
	a line from the origin to (1, 0). LinearEmbedding[g] returns the graph
	g embedded on the line."

LineGraph::usage =
	"LineGraph[g] returns the line graph of graph g. The line graph has the
	edges of g as vertices and two edges are adjacent if they share a vertex
	of g."

MaxDegree::usage =
	"MaxDegree[g] returns the maximum degree of the graph g.
	MaxDegree[g, Vertex] returns the pair {d, v} where d is the maximum
	degree and v is a vertex having this degree."

MaximumClique::usage =
	"MaximumClique[g] returns a maximum clique in graph g."

MaximumIndependentSet::usage =
	"MaximumIndependentSet[g] returns a maximum independent set in graph g."

MeanDegree::usage =
	"MeanDegree[g] returns the mean degree of the graph g."

MinDegree::usage =
	"MinDegree[g] returns the minimum degree of the graph g.
	MinDegree[g, Vertex] returns the pair {d, v} where d is the minimum
	degree and v is a vertex having this degree."

Neighbours::usage = 
	"Neighbours[g, v] returns the list of neighbours of vertex v.  If v is 
	a list of vertices then the union of their neighbours is returned.\n 
	Neighbours[g, v, k] returns the vertices on distance at most k from 
	v.\n Neighbours[g, v, {k}] returns the vertices on distance exactly k 
	from v.\n Neighbours[g, v, {k, l}] returns the vertices on distance k 
	through l."

NormalizeEmbedding::usage =
	"NormalizeEmbedding[emb] returns the embedding emb re-scaled so that
	it fits into the unit square."

NumberOfSpanningTrees::usage =
	"NumberOfSpanningTrees[g] returns the number of spanning trees in the
	graph g."

(* Order::usage *)
If[!StringMatchQ[Order::usage, "*Order[g]*"],
	Order::usage = Order::usage <>
	"\n Order[g] returns the number of vertices in a graph g."
]

PermuteGraph::usage =
	"PermuteGraph[g, p] permutes the graph g according to the permutation p."

PolyGraph::usage =
	"PolyGraph[g, r, k] returns the polygraph consisting of k copies of the
	graph g connected with the binary relation r. PolyGraph[g, r, k, Cyclic]
	connects the k:th copy of g with the first copy, i.e. we obtain a cyclic
	polygraph."

ProductEmbedding::usage =
	"ProductEmbedding[emb1, emb2,.., embk] returns the product of the 
	embeddings emb1, emb2,.., embk. ProductEmbedding[n1, n2,.., nk] returns
	the embedding of an n1xn2x..xnk grid graph. 
	ProductEmbedding[g, n1, n2,.., nk] returns the graph g with the embedding
	of an n1xn2x..xnk grid graph."

Radius::usage =
	"Radius[g] returns the radius of graph g."

RandomNeighbour::usage =
	"RandomNeighbour[g, v] returns a random neighbour of the non-isolated
	vertex v in graph g."

RegularQ::usage =
	"RegularQ[g] returns True if g is a regular graph and False otherwise."

ShortestPath::usage =
	"ShortestPath[g, v, w] returns a list of vertices beginning with v and
	ending with w, that gives a shortest path between vertex v and w in the
	graph g. One or both of v and w may be lists of vertices and then a
	path beginning in list v and ending in list w is returned."

Size::usage =
	"Size[g] returns the number of edges in a graph g."

(* Sort::usage *)
If[!StringMatchQ[Sort::usage, "*GrafPack*"],
	Sort::usage = Sort::usage <>
	"\n Sort is also an option for some GrafPack functions."
]

Strong::usage =
	"Strong is an option for the GraphProduct function in GrafPack."

SubdivideEdge::usage =
	"SubdivideEdge[g, e] subdivides the edge, or list of edges, e of the
	graph g, ie, inserts a new vertex on the edge. SubdivideEdge[g, e, k]
	inserts a path on k vertices on each edge."

ToAdjacencyLists::usage =
	"ToAdjacencyLists[g] returns the list of lists of neighbours of each
	vertex."

ToAdjacencyMatrix::usage =
	"ToAdjacencyMatrix[g] returns the adjacency matrix of the graph g."

ToBiadjacencyMatrix::usage =
	"ToBiadjacencyMatrix[g] returns the biadjacency matrix of the graph g
	if it is bipartite and an empty list otherwise."

ToEdges::usage =
	"ToEdges[g] returns the set of edges in graph g. ToEdges[g, All]
	returns all the positions in the adjacency matrix that are 1."

ToIncidenceMatrix::usage =
	"ToIncidenceMatrix[g] returns the incidence matrix of graph g. If g has
	n vertices and m edges then an n x m matrix is returned having a 1 in
	position (i, j) if the i:th vertex is a member of the j:th edge and 0
	otherwise."

TransformEmbedding::usage =
	"TransformEmbedding[emb, a, r, {x, y}] transforms the embedding emb
	affinely by multiplying each coordinate by a, rotating them around the
	origin r radians and adding {x, y} to each coordinate. With the
	coordinates seen as complex numbers this corresponds to the operation
	a * exp(I*r) * emb + (x + y*I). Note that
	TransformEmbedding[emb, 1, 0, {0, 0}] returns emb.
	TransformEmbedding[g, a, r, {x, y}] transforms the embedding of the
	graph g. TransformEmbedding[emb, a, r, {x, y}, v] applies the
	transformation to the vertices in list v.
	TransformEmbedding[g, a, r, {x, y}, v] does this to the vertices in v
	of the graph g."

TreeQ::usage =
	"TreeQ[g] returns True if g is a tree and False otherwise."

TreeToCode::usage =
	"TreeToCode[g] returns the Prufer code corresponding to the tree g."

TwoColouring::usage =
	"TwoColouring[g] returns a list of colours of the vertices of the graph
	g.  If g has a two-colouring then this list contains only 1's and 2's,
	otherwise it is a list of 0's of length Order[g].\n
	FreeQ[TwoColouring[g], 0] then tests if g is bipartite."

Vertex::usage =
	"Vertex is an option for some GrafPack functions."

Vertices::usage =
	"Vertices[g] returns the set of vertices in graph g."

Weak::usage =
	"Weak is an option for the GraphProduct function in GrafPack."

Wreath::usage =
	"Wreath is an option for the GraphProduct function in GrafPack."

Begin["`Private`"]

protected = Unprotect[Degree, Order]

definitions = {AddEdge, AddVertex, Automorphisms, Barycenter, 
	BipartiteQ, Bipartition, BreadthFirstSearch, Center, ChangeEmbedding, 
	CircularEmbedding, CliqueNumber, CliqueQ, Closure, CodeToTree, 
	CompleteQ, Component, ConnectedQ, Corona, Cyclic, DegreeSequence, 
	DeleteEdge, DeleteVertex, DepthFirstSearch, Diameter, Distance, 
	DistanceMatrix, Eccentricity, Edge, EdgeCut, EdgeDegree, EdgeQ, 
	Embedding, EmptyQ, FindEdge, FindNeighbour, FromAdjacencyLists, 
	FromAdjacencyMatrix, FromBiadjacencyMatrix, FromEdges, 
	FromIncidenceMatrix, Graph, GraphComplement, GraphIntersection, 
	GraphJoin, GraphProduct, GraphSum, GraphUnion, GreedyColouring, 
	HighDegreeEdge, IdentifyVertices, IndependenceNumber, IndependentSetQ, 
	InduceSubgraph, LineGraph, LinearEmbedding, MaxDegree, MaximumClique, 
	MaximumIndependentSet, MeanDegree, MinDegree, Neighbours, 
	NormalizeEmbedding, NumberOfSpanningTrees, PermuteGraph, PolyGraph, 
	ProductEmbedding, Radius, RandomNeighbour, RegularQ, ShortestPath, 
	Size, Strong, SubdivideEdge, ToAdjacencyLists, ToAdjacencyMatrix, 
	ToBiadjacencyMatrix, ToEdges, ToIncidenceMatrix, TransformEmbedding, 
	TreeQ, TreeToCode, TwoColouring, Vertex, Vertices, Weak, Wreath
}

Scan[Unprotect, definitions]


AddEdge[Graph[adj_, emb_], {u_Integer, v_Integer}] :=
	Graph[MapAt[1&, adj, {{u, v}, {v, u}}], emb]

AddEdge[Graph[adj_, emb_], e:{___List}] :=
	Graph[MapAt[1&, adj, Join[e, Map[Reverse, e]]], emb]


AddVertex[g_Graph, k_Integer:1] :=
	GraphUnion[
		g,
		Graph[
			Table[0, {k}, {k}],
			CircularEmbedding[k]
		]
	]

Automorphisms[g_Graph] := {{1}} /; Order[g] == 1

Automorphisms[g:Graph[adj_, _]] :=
	Module[{a},
		Backtrack[
			equivalentvertices[g, 5],
			(
				a = Range[Length[#]];
				And[
					Transpose[adj[[a]]] [[a]] == Transpose[adj[[#]]] [[#]],
					FreeQ[Drop[#, -1], Last[#]]
				]
			)&,
			(adj == adj[[#, #]])&,
			All
		]
	]

equivalentvertices[Graph[adj_, _], n_Integer] :=
	Module[{eqv, i, rows, t, mat=IdentityMatrix[Length[adj]]},
		t = Table[{}, {Length[adj]}];
		Do[
			mat = mat.adj;
			rows = Map[Sort, mat];
			eqv = Map[Flatten[Position[rows, #]]&, Union[rows]];
			Do[
				AppendTo[t[[i]], Position[eqv, i, {2}, 1][[1, 1]]],
				{i, Length[adj]}
			],
			{n}
		];
		Map[Flatten[Position[t, #]]&, t]
	]


Barycenter[g_Graph] :=
	Module[{sum},
		sum = Map[Apply[Plus, #]&, DistanceMatrix[g]];
		Flatten[Position[sum, Min[sum]]]
	]


BipartiteQ[g_Graph] :=
	Module[{k, neib, col={{},{}}, n=Order[g], test=True},
		While[test && Length[col[[1]]]+Length[col[[2]]] < n,
			neib = {First[Complement[Range[n], col[[1]], col[[2]]]]};
			(* neib contains first uncoloured vertex *)
			k = 1;    (* k is current colour class *)
			col[[k]] = Join[col[[k]], neib];
			While[test && neib != {},
				k = 3 - k;    (* Flip colour class *)
				neib = Complement[Neighbours[g, neib], col[[k]]];
				test = IndependentSetQ[g, neib];
				col[[k]] = Join[col[[k]], neib];
			];
		];
		test
	]

(* OLD VERSION
BipartiteQ[g_Graph, start_:1, col2_:{}] :=
	Module[{bip, i=0, n=Order[g], col={start}, neib=Neighbours[g,start]},
		bip = IndependentSetQ[g, neib];
		While[bip && Length[col] + Length[col2] < n && i + Length[col2] <= n,
			i = i + 1;
			neib = Complement[Neighbours[g, neib], col];
			bip = IndependentSetQ[g, neib];
			col = Join[col, neib];
		];
		If[Length[col] + Length[col2] == n,
			bip,
		(*Else*)
			i = First[Complement[Range[n], col, col2]];
			bip && BipartiteQ[g, i, Join[col, col2]]
		]
	]
*)


Bipartition[g_Graph] :=
	Module[{k, neib, col={{},{}}, n=Order[g], test=True},
		While[test && Length[col[[1]]]+Length[col[[2]]] < n,
			neib = {First[Complement[Range[n], col[[1]], col[[2]]]]};
			(* neib contains first uncoloured vertex *)
			k = 1;    (* k is current colour class *)
			col[[k]] = Join[col[[k]], neib];
			While[test && neib != {},
				k = 3 - k;    (* Flip colour class *)
				neib = Complement[Neighbours[g, neib], col[[k]]];
				test = IndependentSetQ[g, neib];
				col[[k]] = Join[col[[k]], neib];
			];
		];
		If[test, Map[Union, col], {}]
	]

(* OLD VERSION
Bipartition[g_Graph] :=
	Module[{col=TwoColouring[g]},
		If[MemberQ[col, 0],
			{},
		(*Else*)
			{Flatten[Position[col, 1]], Flatten[Position[col, 2]]}
		]
	]
*)

BreadthFirstSearch[g_Graph, v_Integer?Positive] :=
	Module[{adj, unseen, u, edge={}, queue={v}},
		adj = ToAdjacencyLists[g];
		unseen = Table[True, {Order[g]}];
		unseen[[v]] = False;
		While[queue != {},
			{u, queue} = {First[queue], Rest[queue]};
			Scan[
				If[unseen[[#]],
					unseen[[#]] = False;
					AppendTo[queue, #];
					AppendTo[edge, {u, #}];
				]&,
				adj[[u]]
			]
		];
		edge
	]

BreadthFirstSearch[g_Graph, v_Integer?Positive, w_Integer?Positive] :=
	Module[{adj, unseen, u, edge={}, queue={v}},
		adj = ToAdjacencyLists[g];
		unseen = Table[True, {Order[g]}];
		unseen[[v]] = False;
		While[queue != {} && unseen[[w]],
			{u, queue} = {First[queue], Rest[queue]};
			Scan[
				If[unseen[[#]],
					unseen[[#]] = False;
					AppendTo[queue, #];
					AppendTo[edge, {u, #}];
				]&,
				adj[[u]]
			]
		];
		u = Position[edge, w];
		If[u == {},
			edge,
		(*Else*)
			Take[edge, u[[1, 1]]]
		]
	]


Center[g_Graph] :=
	Module[{ecc},
		ecc = Eccentricity[g, All];
		Flatten[Position[ecc, Min[ecc]]]
	]


ChangeEmbedding[Graph[adj_, _], emb:{___List}] :=
	Graph[adj, emb] /; Length[emb] == Length[adj]


CircularEmbedding[0] := {}

CircularEmbedding[n_Integer?Positive] :=
	Module[{i, a=N[Pi/2], b=N[2*Pi/n]},
		Chop[Table[{Cos[a+b*i], Sin[a+b*i]}, {i, 0, n-1}]]
	]

CircularEmbedding[Graph[adj_, _]] :=
	Graph[adj, CircularEmbedding[Length[adj]]]

CircularEmbedding[n__Integer?Positive] :=
	Module[{a=2*Pi/Length[{n}]},
		Apply[Join,
			MapIndexed[
				TransformEmbedding[
					partembedding[#1],
					1,
					a*(1 - #2[[1]]),
					{0, 0}
				]&,
				{n}
			]
		]
	]

partembedding[n_] := (* private function *)
	TransformEmbedding[LinearEmbedding[n], 0.5, Pi/2, {-1, -0.25}]


CliqueNumber[g_Graph] := IndependenceNumber[GraphComplement[g]]


CliqueQ[_Graph, {}] := True

CliqueQ[Graph[adj_, _], v:{__Integer}] :=
	Position[adj[[v, v]], 0, {2}, Length[v]] == Map[{#, #}&, Range[Length[v]]]


Closure[g_Graph] :=
	Module[{deg, e, edges, h=g, n=Order[g]},
		edges = ToEdges[GraphComplement[g]];
		While[True,
			deg = DegreeSequence[h];
			e = Select[edges, (Apply[Plus, deg[[#]]] >= n)&];
			If[e == {}, Break[]];
			h = AddEdge[h, e];
			edges = Complement[edges, e];
		];
		h
	]


CodeToTree[list_List] :=
	Module[{i, x, y},
		y = Range[Length[list] + 2];
		FromEdges[
			Append[
				Table[
					x = Min[Complement[y, Drop[list, i - 1]]];
					y = Complement[y,{x}];
					{x, list[[i]]},
					{i, Length[list]}
				],
				y
			]
		]
	]


CompleteQ[Graph[adj_, _]] :=
	Position[adj, 0, {2}, Length[adj]] == Map[{#, #}&, Range[Length[adj]]]


Component[g_Graph, v_Integer?Positive] :=
	Module[{new={v}, vertex={{},{v}}},
		While[new != {},
			new = Complement[
				Neighbours[g, new], 
				vertex[[-1]], 
				vertex[[-2]]
			];
			AppendTo[vertex, new];
		];
		Apply[Union, vertex]
	]

Component[g_Graph, All]:=
	Module[{comp={}, vertex=Vertices[g]},
		While[vertex != {},
			AppendTo[comp, Component[g, First[vertex]]];
			vertex = Complement[vertex, Last[comp]];
		];
		comp
	]

(* OLD VERSION 2
Component[g_Graph, v_Integer] :=
	Module[{neib={v}, comp={v}},
		While[neib != {},
			neib = Complement[Neighbours[g, neib], comp];
			comp = Join[comp, neib];
		];
		Union[comp]
	]

Component[g_Graph, All] :=
	Module[{neib, comp={}, k=0, n=Order[g]},
		While[k < n,
			neib = {First[Complement[Range[n], Apply[Sequence, comp]]]};
			(* neib contains first unseen vertex *)
			comp = Append[comp, neib];
			k = k + 1;  (* one new vertex *)
			While[neib != {},
				neib = Complement[Neighbours[g, neib], comp[[-1]]];
				comp[[-1]] = Join[comp[[-1]], neib];
				k = k + Length[neib];
			];
		];
		Map[Union, comp]
	]
*)

(*OLD VERSION 1
Component[g_Graph, v_Integer] :=
	Apply[Union, Append[BreadthFirstSearch[g, v], {v}]]

Component[g_Graph, All]:=
	Module[{comp={}, unseen=Range[Order[g]]},
		While[unseen != {},
			AppendTo[comp, Component[g, First[unseen]]];
			unseen = Complement[unseen, Last[comp]];
		];
		comp
	]
*)


ConnectedQ[Graph[{}, {}]] := True

ConnectedQ[g_Graph] :=
	Module[{adj, i=1, n=Order[g], queue={1}, unseen, v},
		adj = ToAdjacencyLists[g];
		unseen = Table[True, {n}];
		unseen[[1]] = False;
		While[(i < n) && (queue != {}),
			{v, queue} = {First[queue], Rest[queue]};
			Scan[
				If[unseen[[#]],
					unseen[[#]] = False;
					AppendTo[queue, #];
					i = i + 1
				]&,
				adj[[v]]
			]
		];
		i == n
	]


Degree[Graph[adj_, _], v_Integer] := Apply[Plus, adj[[v]]]

Degree[Graph[adj_, _], v:{___Integer}] := Map[Apply[Plus, #]&, adj[[v]]]


DegreeSequence[Graph[adj_, _]] := Map[Apply[Plus, #]&, adj]

DegreeSequence[g_Graph, Sort] := Sort[DegreeSequence[g]]


DeleteEdge[Graph[adj_, emb_], {u_Integer, v_Integer}] :=
	Graph[MapAt[0&, adj, {{u, v}, {v, u}}], emb]

DeleteEdge[Graph[adj_, emb_], e:{___List}] :=
	Graph[MapAt[0&, adj, Join[e, Map[Reverse, e]]], emb]


DeleteVertex[g_Graph, v_Integer] := DeleteVertex[g, {v}]

DeleteVertex[Graph[adj_, emb_], v_List] :=
	Module[{n=Length[adj], w},
		w = Complement[Range[n], v];
		Graph[adj[[w, w]], emb[[w]]]
	]


DepthFirstSearch[g_Graph, v_Integer] :=
	Block[{adj, unseen, edge={}},
		unseen = Table[True, {Order[g]}];
		adj = ToAdjacencyLists[g];
		dfs[v];
		edge
	]

dfs[v_] := (* private function *)
	(
		unseen[[v]] = False;
		Scan[
			If[unseen[[#]], 
				AppendTo[edge, {v, #}];
				dfs[#]
			]&,
			adj[[v]]
		]
	)


Diameter[g_Graph] := Max[DistanceMatrix[g]]


Distance[g_Graph, v_Integer, v_Integer] := 0 /; 1 <= v <= Order[g]

Distance[g_Graph, v_Integer?Positive, w_Integer?Positive] :=
	Module[{distance},
		distance = Table[0, {Order[g]}];
		Scan[
			(distance[[#[[2]]]] = 1 + distance[[#[[1]]]])&,
			BreadthFirstSearch[g, v, w]
		];
		distance[[w]] /. 0 -> Infinity
	]

Distance[g_Graph, v_Integer?Positive, All] :=
	Module[{distance},
		distance = Table[0, {Order[g]}];
		Scan[
			(distance[[#[[2]]]] = 1 + distance[[#[[1]]]])&,
			BreadthFirstSearch[g, v]
		];
		ReplacePart[distance /. 0 -> Infinity, 0, v]
	]


DistanceMatrix[Graph[adj_, _]] :=
	Module[{mat, vec, k=0},
		mat = (adj /. 0 -> Infinity);
		Do[mat[[k,k]]=0,{k,Length[mat]}];
		Nest[
			(
				k = k + 1;
				vec = #[[k]];
				Map[MapThread[Min, {#, vec + #[[k]]}]&, #]
			)&,
			mat,
			Length[mat]
		]
	]


Eccentricity[g_Graph, v_Integer] := Max[Distance[g, v, All]]

Eccentricity[g_Graph, All] := Map[Max, DistanceMatrix[g]]


EdgeCut[g_Graph, v_List] := EdgeCut[g, v, Complement[Vertices[g], v]]

EdgeCut[g_Graph, v_List, w_List] :=
	Union[
		Flatten[
			Map[
				Outer[
					Sort[{##}]&,
					Intersection[Neighbours[g, #], w],
					{#}
				]&,
				v
			],
			2
		]
	]


EdgeDegree[g_Graph, {u_Integer, v_Integer}] :=  
	Apply[Plus, Degree[g, {u, v}]] - 1

EdgeDegree[g_Graph, e:{__List}] := Map[Apply[Plus, Degree[g, #]]&, e] - 1


EdgeQ[Graph[adj_, _], {u_, v_}] := adj[[u, v]] == 1


Embedding[Graph[_, emb_]] := emb


EmptyQ[Graph[adj_, _]] := FreeQ[adj, 1, {2}]


FindEdge[Graph[adj_, _]] := Flatten[Position[adj, 1, {2}, 1]]

FindEdge[Graph[adj_, _], Complement] :=
	Flatten[
		Cases[
			Position[adj, 0, {2}, Length[adj]], 
			{i_, j_} /; i < j,
			{1},
			1
		]
	]


FindNeighbour[Graph[adj_, _], v_Integer] :=
	Flatten[Position[adj[[v]], 1, {1}, 1]] /. {} -> 0 /. {w_} -> w

FindNeighbour[Graph[adj_, _], v_Integer, Complement] :=
	Cases[
		Flatten[Position[adj[[v]], 0]],
		w_ /; w != v,
		{1},
		1
	] /. {} -> 0 /. {w_} -> w


FromAdjacencyLists[a:{___List}] :=
	Module[{b=Table[0, {Length[a]}]},
		Graph[
			Map[MapAt[1&, b, Map[List, #]]&, a],
			CircularEmbedding[Length[a]]
		]
	]

FromAdjacencyLists[a:{___List}, emb:{___List}] :=
	Module[{b=Table[0, {Length[a]}]},
		Graph[
			Map[MapAt[1&, b, Map[List, #]]&, a],
			emb
		]
	] /; Length[a] == Length[emb]


FromAdjacencyMatrix[adj_?MatrixQ] :=
	Graph[
		adj, 
		CircularEmbedding[Length[adj]]
	] /; MatchQ[Dimensions[adj], {n_, n_}]

FromAdjacencyMatrix[adj_?MatrixQ, emb:{__List}] := Graph[adj, emb] /; 
	MatchQ[Dimensions[adj], {n_, n_}] && Length[adj] == Length[emb]

FromAdjacencyMatrix[{}, {}] := Graph[{}, {}]


FromBiadjacencyMatrix[{}, ___] :=Graph[{}, {}]

FromBiadjacencyMatrix[adj_?MatrixQ] :=
	Module[{a, b},
		{a, b} = Map[Table[0, {#}]&, Dimensions[adj]];
		Graph[
			Join[
				Map[Flatten[Append[a, #]]&, adj],
				Map[Flatten[Append[#, b]]&, Transpose[adj]]
			],
			CircularEmbedding[Length[a], Length[b]]
		]
	]

FromBiadjacencyMatrix[adj_?MatrixQ, emb:{___List}] :=
	Module[{a, b},
		{a, b} = Map[Table[0, {#}]&, Dimensions[adj]];
		Graph[
			Join[
				Map[Flatten[Append[a, #]]&, adj],
				Map[Flatten[Append[#, b]]&, Transpose[adj]]
			],
			emb
		]
	] /; Length[emb] == Apply[Plus, Dimensions[adj]]


FromEdges[{}, 0, ___] := Graph[{}, {}]

FromEdges[{}, {}, ___] := Graph[{}, {}]

FromEdges[e:{___List}] := FromEdges[e, Max[Max[e], 0]]

FromEdges[e:{___List}, All] := FromEdges[e, Max[Max[e], 0], All]

FromEdges[e:{___List}, n_Integer?Positive] :=
	Module[{adj},
		adj = MapAt[1&, Table[0, {n}, {n}], e];
		Graph[adj + Transpose[adj], CircularEmbedding[n]]
	]

FromEdges[e:{___List}, n_Integer?Positive, All] :=
	Graph[
		MapAt[1&, Table[0, {n}, {n}], e],
		CircularEmbedding[n]
	]

FromEdges[e:{___List}, emb:{__List}] :=
	Module[{adj, n=Length[emb]},
		adj = MapAt[1&, Table[0, {n}, {n}], e];
		Graph[adj + Transpose[adj], emb]
	]

FromEdges[e:{___List}, emb:{___List}, All] :=
	Graph[
		MapAt[1&, Table[0, {Length[emb]}, {Length[emb]}], e],
		emb
	]


FromIncidenceMatrix[{}, ___] := Graph[{}, {}]

FromIncidenceMatrix[inc_?MatrixQ] :=
	FromEdges[
		Map[Flatten[Position[#, 1]]&, Transpose[inc]],
		Length[inc]
	]

FromIncidenceMatrix[inc_?MatrixQ, emb:{__List}] :=
	FromEdges[
		Map[Flatten[Position[#, 1]]&, Transpose[inc]],
		emb
	]


GraphComplement[Graph[adj_, emb_]] := 
	Graph[1 - IdentityMatrix[Length[adj]] - adj, emb]

GraphComplement[Graph[adj_, emb_], v_List] :=
	Module[{adj2},
		adj2 = MapAt[(1 - #)&, adj, CartesianProduct[v, v]];
		Scan[(adj2[[#, #]] = 0)&, v];
		Graph[adj2, emb]
	]


GraphIntersection[Graph[a_, emb_], Graph[b_, _]] :=
	Graph[a*b, emb] /; Length[a] == Length[b]


GraphJoin[g_Graph, h_Graph] :=
	AddEdge[
		GraphUnion[g, h],
		CartesianProduct[Range[Order[g]], Range[Order[h]] + Order[g]]
	]


GraphProduct[Graph[adjg_, embg_], Graph[adjh_, embh_]] :=
	Module[{ng=Length[adjg], nh=Length[adjh]},
		Graph[
			KroneckerProduct[IdentityMatrix[nh], adjg] +
			KroneckerProduct[adjh, IdentityMatrix[ng]],
			ProductEmbedding[embg, embh]
		]
	]

GraphProduct[g_Graph, h___Graph] := Fold[GraphProduct, g, {h}]

GraphProduct[Graph[adjg_, embg_], Graph[adjh_, embh_], Weak] :=
	Module[{ng=Length[adjg], nh=Length[adjh]},
		Graph[
			KroneckerProduct[adjh, adjg],
			ProductEmbedding[embg, embh]
		]
	]

GraphProduct[g_Graph, h___Graph, Weak] :=
	Fold[GraphProduct[##, Weak]&, g, {h}]

GraphProduct[Graph[adjg_, embg_], Graph[adjh_, embh_], Strong] :=
	Module[{ng=Length[adjg], nh=Length[adjh]},
		Graph[
			KroneckerProduct[IdentityMatrix[nh], adjg] +
			KroneckerProduct[adjh, IdentityMatrix[ng]] +
			KroneckerProduct[adjh, adjg],
			ProductEmbedding[embg, embh]
		]
	]

GraphProduct[g_Graph, h___Graph, Strong] :=
	Fold[GraphProduct[##, Strong]&, g, {h}]

GraphProduct[Graph[adjg_, embg_], Graph[adjh_, embh_], Wreath] :=
	Module[{ng=Length[adjg], nh=Length[adjh]},
		Graph[
			KroneckerProduct[adjg, Table[1, {nh}, {nh}]] +
			KroneckerProduct[IdentityMatrix[ng], adjh],
			ProductEmbedding[embg, embh]
		]
	]

GraphProduct[g_Graph, h___Graph, Wreath] :=
	Fold[GraphProduct[##, Wreath]&, g, {h}]

GraphProduct[g_Graph, h_Graph, Corona] :=
	Module[{i, j, ng=Order[g], nh=Order[h]},
		ChangeEmbedding[
			AddEdge[
				GraphUnion[g, GraphUnion[h, ng]],
				Flatten[
					Table[
						{i, j},
						{i, 1, ng},
						{j, ng+(i-1)*nh+1, ng+(i-1)*nh+nh}
					],
					1
				]
			],
			CircularEmbedding[ng*(nh + 1)]
		]
	]

GraphProduct[g_Graph, h___Graph, Corona] :=
	Fold[GraphProduct[##, Corona]&, g, {h}]


GraphSum[Graph[a_, emb_], Graph[b_, _]] :=
	Graph[Map[Min[1, #]&, a+b, {2}], emb] /; Length[a] == Length[b]


GraphUnion[g_Graph] := g

GraphUnion[g_Graph, h_Graph] := h /; Order[g] == 0

GraphUnion[g:Graph[_, embg_], h:Graph[_, embh_]] :=
	Module[{a=Max[Map[First,embg]], b=Min[Map[First,embh]]},
		FromEdges[
			Join[ToEdges[g], ToEdges[h] + Order[g]],
			Join[embg, TransformEmbedding[embh, 1, 0, {a+1-b, 0}]]
		]
	]

GraphUnion[g_Graph, h__Graph] := Fold[GraphUnion, g, {h}]

GraphUnion[g_Graph, 0] := Graph[{}, {}]

GraphUnion[g_Graph, 1] := g

GraphUnion[g_Graph, k_Integer?Positive] := GraphUnion[GraphUnion[g, k-1], g]


GreedyColouring[g_Graph] :=
	Module[{i, col=Table[0,{Order[g]}], v=Vertices[g]},
		Do[
			col[[i]] = First[Complement[v, col[[Neighbours[g, i]]]]],
			{i, Order[g]}
		];
		col
	]

GreedyColouring[g_Graph, p_List] :=
	Module[{i, j, col=Table[0,{Order[g]}], v=Vertices[g]},
		Do[
			j = p[[i]];
			col[[j]] = First[Complement[v, col[[Neighbours[g, j]]]]],
			{i, Order[g]}
		];
		col
	]


HighDegreeEdge[g_Graph, d_List] :=
	Module[{a, b, maxd=Max[d]},
		If[maxd <= 0,
			{},
		(*Else*)
			a = Position[d, maxd, {1}, 1][[1, 1]];
			b = Neighbours[g, a];
			Sort[{a, b[[Position[d[[b]], Max[d[[b]]], {1}, 1][[1, 1]]]]}]
		]
	]

HighDegreeEdge[g_Graph] := HighDegreeEdge[g, DegreeSequence[g]]


IdentifyVertices[g_Graph, v:{__Integer}] :=
	Module[{f=First[v]},
		DeleteVertex[
			AddEdge[
				g,
				Map[
					{f, #}&,
					Complement[Neighbours[g, Rest[v]], {f}]
				]
			],
			Rest[v]
		]
	]

IdentifyVertices[g_Graph, {}] := g


IndependenceNumber[g_Graph] :=
	Module[{deg, maxdeg, v},
		deg = DegreeSequence[g];
		maxdeg = Max[deg];
		If[maxdeg > 1,
			v = Position[deg, maxdeg, {1}, 1][[1, 1]];
			Max[
				IndependenceNumber[
					DeleteVertex[g, Append[Neighbours[g, v], v]]
				] + 1,
				IndependenceNumber[DeleteVertex[g, v]]
			],
		(*Else*)
			Order[g] - Apply[Plus, deg]/2
		]
	]


IndependentSetQ[_Graph, {}] := True

IndependentSetQ[Graph[adj_, _], v:{__Integer}] := 
	FreeQ[adj[[v, v]], 1, {2}]


InduceSubgraph[Graph[adj_, emb_], v:{___Integer}] :=
	Graph[adj[[v, v]], emb[[v]]]


LinearEmbedding[0] := {}

LinearEmbedding[1] := {{0, 0}}

LinearEmbedding[n_Integer?Positive] :=
	Module[{i, x=N[1/(n-1)]},
		Table[{i*x, 0}, {i, 0, n-1}]
	]

LinearEmbedding[Graph[adj_, _]] :=
	Graph[adj, LinearEmbedding[Length[adj]]]


LineGraph[g:Graph[_, emb_]] :=
	Module[{inc=ToIncidenceMatrix[g]},
		Graph[
			Dot[Transpose[inc], inc] - 2*IdentityMatrix[Size[g]],
			CircularEmbedding[Size[g]]
		]
	]


MaxDegree[g_Graph] := Max[DegreeSequence[g]]

MaxDegree[Graph[{}, {}], Vertex] := {-Infinity, 0}

MaxDegree[g_Graph, Vertex] :=
	Module[{max, pos, deg=DegreeSequence[g]},
		max = Max[deg];
		pos = Position[deg, max, {1}, 1][[1, 1]];
		{max, pos}
	]


MaximumClique[g_Graph] := MaximumIndependentSet[GraphComplement[g]]


MaximumIndependentSet[g_Graph] :=
	Block[{a, adj},
		a = IndependenceNumber[g];
		adj = ToAdjacencyLists[g];
		indset[{}, Range[Order[g]]]
	]

indset[ind_, allow_] := (* private function *)
	(* Looks for an independent set of size a *)
	Module[{r, v, set={}},
		If[Length[ind] == a,
			set = ind,
		(*Else*)
			If[allow != {} && a <= Length[ind]+Length[allow],
				{v, r} = {First[allow], Rest[allow]};
				set = indset[Append[ind, v], Complement[r, adj[[v]]]];
				If[r != {} && Length[set] != a,
					set = indset[ind, r]
				];
			]
		];
		set
	]


MeanDegree[g_Graph] := Apply[Plus, DegreeSequence[g]] / Order[g]


MinDegree[g_Graph] := Min[DegreeSequence[g]]

MinDegree[Graph[{}, {}], Vertex] := {Infinity, 0}

MinDegree[g_Graph, Vertex] :=
	Module[{min, pos, deg=DegreeSequence[g]},
		min = Min[deg];
		pos = Position[deg, min, {1}, 1][[1, 1]];
		{min, pos}
	]


Neighbours[Graph[adj_, _], v_Integer] := Flatten[Position[adj[[v]], 1]]

Neighbours[Graph[adj_, _], v:{___Integer}] :=
	Union[Flatten[Map[Position[#, 1]&, adj[[v]]]]]

Neighbours[g_Graph, v_Integer, 0] := {v} /; 1 <= v <= Order[g]

Neighbours[g_Graph, v_Integer, 1] := Union[Neighbours[g, v], {v}]

Neighbours[g_Graph, v_Integer, k_Integer] :=
	Flatten[Position[Distance[g, v, All], x_ /; x <= k]]

Neighbours[g_Graph, v_Integer, {0}] := {v} /; 1 <= v <= Order[g]

Neighbours[g_Graph, v_Integer, {1}] := Neighbours[g, v]

Neighbours[g_Graph, v_Integer, {k_Integer}] :=
	Flatten[Position[Distance[g, v, All], x_ /; x == k]]

Neighbours[g_Graph, v_Integer, {k_Integer, l_Integer}] :=
	Flatten[Position[Distance[g, v, All], x_ /; k <= x <= l]]


NormalizeEmbedding[{}] := {}

NormalizeEmbedding[emb:{__List}] :=
	Module[{x=Min[Map[First, emb]], y=Min[Map[Last, emb]], z, emb2},
		emb2 = Map[(# - {x, y})&, emb];
		z = Max[emb2];
		Chop[emb2 / If[Chop[z]==0, 1, z]]
	]

NormalizeEmbedding[Graph[adj_, emb_]] :=
	Graph[adj, NormalizeEmbedding[emb]]


NumberOfSpanningTrees[g_Graph] :=
	Module[{mat},
		mat = DiagonalMatrix[DegreeSequence[g]] - ToAdjacencyMatrix[g];
		Det[mat[[Range[Order[g] - 1], Range[Order[g] - 1]]]]
	]


Order[Graph[adj_, _]] := Length[adj]


PermuteGraph[Graph[adj_, emb_], p:{___Integer}] :=
	Graph[adj[[p, p]], emb[[p]]]


PolyGraph[g_Graph, r:{{_, _}...}, k_Integer] :=
	Module[{h, i, n=Order[g]},
		h = GraphUnion[g, k];
		Do[
			h = AddEdge[h, Map[(# + {(i - 1)*n, i*n})&, r]],
			{i, 1, k-1}
		];
		h
	]

PolyGraph[g_Graph, r:{{_, _}...}, k_Integer, Cyclic] :=
	Module[{n=Order[g]},
		AddEdge[PolyGraph[g, r, k], Map[(# + {(k - 1)*n, 0})&, r]]
	] /; k > 2


ProductEmbedding[emb:{___List}] := emb

ProductEmbedding[emb1:{___List}, emb2:{___List}] :=
	Module[{a=1/Max[Length[emb1], Length[emb2], 1]},
		Flatten[
			Map[
				TransformEmbedding[emb1, a, 0, #]&,
				TransformEmbedding[emb2, 1, Pi/2, {0, 0}]
			],
			1
		]
	]
 
ProductEmbedding[emb1:{___List}, emb2:{___List}, emb3:{___List}...] :=
	ProductEmbedding[ProductEmbedding[emb1, emb2], emb3]

ProductEmbedding[n__Integer] :=
	ProductEmbedding[Apply[Sequence, Map[LinearEmbedding, {n}]]]

ProductEmbedding[Graph[adj_, _], n__Integer] :=
	Graph[adj, ProductEmbedding[n]] /; Times[n] == Length[adj]


Radius[g_Graph] := Min[Eccentricity[g, All]]


RandomNeighbour[g_Graph, v_Integer] := RandomElement[Neighbours[g, v]]


RegularQ[Graph[{}, _]] := True

RegularQ[Graph[adj_, _]] := Apply[Equal, Apply[Plus, adj]]


ShortestPath[g_Graph, v_Integer, w_Integer] :=
	ShortestPath[g, {v}, {w}]

ShortestPath[g_Graph, v:{__Integer}, w_Integer] :=
	ShortestPath[g, v, {w}]

ShortestPath[g_Graph, v_Integer, w:{__Integer}] :=
	ShortestPath[g, {v}, w]

ShortestPath[g_Graph, v:{__Integer}, w:{__Integer}] := 
	{First[Intersection[v, w]]} /; Intersection[v, w] != {}

ShortestPath[g_Graph, v:{__Integer}, w:{__Integer}] :=
	Module[{col, new},
		new = Complement[Neighbours[g, w], w];
		col = {new, w};
		While[new != {} && Intersection[new, v] == {},
			new = Complement[Neighbours[g, new], col[[1]], col[[2]]];
			PrependTo[col, new];
		];
		FoldList[
			First[Intersection[Neighbours[g, #1], #2]]&,
			First[Intersection[new, v]],
			Rest[col]
		]
	]


(* OLD VERSION
ShortestPath[g_Graph, v_Integer, v_Integer] := {v} /; 1 <= v <= Order[g]

ShortestPath[g_Graph, v_Integer?Positive, w_Integer?Positive] :=
	Module[{parent},
		parent = Table[0, {Order[g]}];
		Scan[
			(parent[[#[[2]]]] = #[[1]])&,
			BreadthFirstSearch[g, v, w]
		];
		If[parent[[w]] == 0,
			{},
		(*Else*)
			Reverse[
				FixedPointList[parent[[#]]&, w, SameTest -> (#2 == v &)]
			]
		]
	]
*)

Size[Graph[adj_, _]] := Apply[Plus, adj, {0, 1}] / 2


SubdivideEdge[g_Graph, {x_Integer, y_Integer}, k_Integer:1] :=
	Module[{a, emb, h, i, n=Order[g]},
		h = AddEdge[
			GraphUnion[DeleteEdge[g, {x, y}], path[k]],
			{{x, n+1}, {y, n+k}}
		];
		emb = Embedding[h];
		a = N[(emb[[y]] - emb[[x]]) / (k + 1)];
		Do[emb[[n+i]] = emb[[x]] + a*i, {i, k}];
		ChangeEmbedding[h, emb]
	] /; Positive[k]

SubdivideEdge[g_Graph, e:{___List}, k_Integer:1] :=
	Module[{h=g},
		Scan[(h = SubdivideEdge[h, #, k])&, e];
		h
	] /; Positive[k]

path[n_Integer] := FromEdges[Partition[Range[n], 2, 1], LinearEmbedding[n]]


ToAdjacencyLists[Graph[adj_, _]] := Map[Flatten[Position[#, 1]]&, adj]


ToAdjacencyMatrix[Graph[adj_, _]] := adj


ToBiadjacencyMatrix[g_Graph] :=
	Module[{bip=Bipartition[g]},
		If[bip == {},
			{},
		(*Else*)
			ToAdjacencyMatrix[g][[First[bip], Last[bip]]]
		]
	]


ToEdges[Graph[adj_, _]] := Select[Position[adj, 1], OrderedQ]

ToEdges[Graph[adj_, _], All] := Position[adj, 1]


ToIncidenceMatrix[g_Graph] :=
	Module[{a=Table[0,{Order[g]}]},
		Transpose[Map[MapAt[1&, a, #]&, Map[List, ToEdges[g], {2}]]]
	]


TransformEmbedding[emb:{___List}, a_, r_, {x_, y_}] :=
	Map[
		{x + Re[#], y + Im[#]}&,
		a * N[Exp[I*r]] * Map[Complex[First[#], Last[#]]&, emb]
	]

TransformEmbedding[Graph[adj_, emb_], a_, r_, {x_, y_}] :=
	Graph[adj, TransformEmbedding[emb, a, r, {x, y}]]

TransformEmbedding[emb_, a_, r_, {x_, y_}, v:{___Integer}]:=
	Module[{z},
		MapAt[
			(z = a * N[Exp[I*r]] * Complex[First[#], Last[#]];
			{x + Re[z], y + Im[z]})&,
			emb,
			Map[List, v]
		]
	]

TransformEmbedding[Graph[adj_, emb_], a_, r_, {x_, y_}, v_] :=
	Graph[adj, TransformEmbedding[emb, a, r, {x, y}, v]]


TreeQ[Graph[{}, {}]] := True

TreeQ[g_Graph] := (Size[g] == Order[g] - 1) && ConnectedQ[g]


TreeToCode[g_Graph?TreeQ] :=
	Module[{adj, i, j},
		adj = ToAdjacencyLists[g];
		Table[
			i = Position[Map[Length, adj], 1, {1}, 1][[1, 1]];
			j = adj[[i, 1]];
			adj[[j]] = Complement[adj[[j]], {i}];
			adj[[i]] = {};
			j,
			{Order[g] - 2}
		]
	] /; Order[g] > 1


TwoColouring[g_Graph]:=
	Module[{bip},
		bip = Bipartition[g];
		If[bip == {},
			Table[0, {Order[g]}],
		(*Else*)
			MapAt[
				2&,
				MapAt[1&, Table[0, {Order[g]}], Map[List, bip[[1]]]],
				Map[List, bip[[2]]]
			]
		]
	]

(* OLD VERSION
TwoColouring[g_Graph] := 
	Module[{adj, c, v, queue, bip=True, col=Table[0,{Order[g]}]},
		adj = ToAdjacencyLists[g];
		While[bip && MemberQ[col, 0],
			queue = First[Position[col, 0]];
			col[[First[queue]]] = 1;
			While[bip && queue != {},
				{v, queue} = {First[queue], Rest[queue]};
				c = col[[v]];
				Scan[
					Switch[col[[#]],
						c,
							bip = False;
							Return[],
						0,
							col[[#]] = 3 - c;
							AppendTo[queue, #];
					]&,
					adj[[v]]
				]
			]
		];
		If [!bip, col[[1]] = 0];
		col
	]
*)

Vertices[g_Graph] := Range[Order[g]]


Protect[Evaluate[protected]]

Scan[Protect, definitions]


End[]

EndPackage[]