third_party/cddlib/examples-ml/Combinatorica5.m

(* Combinatorica5.m package,  Modified version of Combinatorica.m
   Modified by Komei Fukuda November 1998.
   Please look for the string "Fukuda" for modified places. 
*) 

(* :Title: Combinatorica 
*)
(* :Author:
	Steven S. Skiena 
*)
(* :Summary:

	Implementing Discrete Mathematics: Combinatorics and Graph Theory
				with Mathematica

This package contains all the programs from the book, "Implementing
Discrete Mathematics: Combinatorics and Graph Theory with Mathematica"
by Steven S. Skiena, Addison-Wesley Publishing Co., Advanced Book Program,
350 Bridge Parkway, Redwood City CA 94065.  ISBN 0-201-50943-1.
For ordering information, call 1-800-447-2226.

These programs can be obtained on Macintosh and MS-DOS disks by sending
$15.00 to Discrete Mathematics Disk, Wolfram Research Inc.,
PO Box 6059, Champaign, IL 61826-9905. (217)-398-0700.

Any comments, bug reports, or requests to get on the Combinatorica
mailing list should be forwarded to:

	Steven Skiena
	Department of Computer Science
	State University of New York
	Stony Brook, NY 11794

	skiena@sbcs.sunysb.edu

	(516)-632-9026 / 8470
*)
(* :Context: DiscreteMath`Combinatorica` 
*)
(* :Package Version: .9	(2/29/92 Beta Release)
*)
(* :Copyright: Copyright 1990, 1991, 1992 by Steven S. Skiena

This package may be copied in its entirety for nonprofit purposes only.
Sale, other than for the direct cost of the media, is prohibited.  This
copyright notice must accompany all copies.

The author, Wolfram Research, and Addison-Wesley Publishing Company,
Inc. make no representations, express or implied, with respond to this
documentation, of the software it describes and contains, including
without limitations, any implied warranties of mechantability or fitness
for a particular purpose, all of which are expressly disclaimed.  The
author, Wolfram Research, or Addison-Wesley, their licensees,
distributors and dealers shall in no event be liable for any indirect,
incidental, or consequential damages.
*)
(* :History:
	Version .8 by Steven S. Skiena, July 1991.
	Version .7 by Steven S. Skiena, January 1991. 
	Version .6 by Steven S. Skiena, June 1990.
*)
(* :Keywords:
	adjacency, automorphism, chromatic, clique, coloring,
	combination, composition, connected components, connectivity, cycle,
	de Bruijn, degree, derangement, Dijkstra, Durfee,
	embedding, equivalence, Eulerian, Ferrers,
	geodesic, graph, Gray code, group, Hamiltonian cycle, Harary, Hasse,
	heap, hypercube, interval, inversion, involution, isomorphism,
	Josephus, network,
	partition, perfect, permutation, planar graph, Polya, pseudograph,
	self-loop, sequence, signature, simple, spanning tree,
	stable marriage, star, Stirling,
	transitive closure, traveling salesman tour, tree, Turan,
	vertex cover, wheel, Young tableau
*)
(* :Source:
	Steven Skiena: "Implementing Discrete Mathematics: Combinatorics
			and Graph Theory with Mathematica", 
			Addison-Wesley Publishing Co.
*)
(* :Mathematica Version: 2.0
*)

BeginPackage["DiscreteMath`Combinatorica`"]

(* Change: unprotect all Combinatorica functions 
   by K. Fukuda 930501  *)
Unprotect[
AcyclicQ,
AddEdge,
AddVertex,
AllPairsShortestPath,
ArticulationVertices,
Automorphisms,
Backtrack,
BiconnectedComponents,
BiconnectedComponents,
BiconnectedQ,
BinarySearch,
BinarySubsets,
BipartiteMatching,
BipartiteQ,
BreadthFirstTraversal,
Bridges,
CartesianProduct,
CatalanNumber,
ChangeEdges,
ChangeVertices,
ChromaticNumber,
ChromaticPolynomial,
CirculantGraph,
CircularVertices,
CliqueQ,
CodeToLabeledTree,
Cofactor,
CompleteQ,
Compositions,
ConnectedComponents,
ConnectedQ,
ConstructTableau,
Contract,
CostOfPath,
Cycle,
DeBruijnSequence,
DegreeSequence,
DeleteCycle,
DeleteEdge,
DeleteFromTableau,
DeleteVertex,
DepthFirstTraversal,
DerangementQ,
Derangements,
Diameter,
Dijkstra,
DilateVertices,
DistinctPermutations,
Distribution,
DurfeeSquare,
Eccentricity,
EdgeChromaticNumber,
EdgeColoring,
EdgeConnectivity,
Edges,
Element,
EmptyGraph,
EmptyQ,
EncroachingListSet,
EquivalenceClasses,
EquivalenceRelationQ,
Equivalences,
EulerianCycle,
EulerianQ,
Eulerian,
ExactRandomGraph,
ExpandGraph,
ExtractCycles,
FerrersDiagram,
FindCycle,
FindSet,
FirstLexicographicTableau,
FromAdjacencyLists,
FromCycles,
FromInversionVector,
FromOrderedPairs,
FromUnorderedPairs,
FromOrderedTriples,
FromUnorderedTriples,
FunctionalGraph,
Girth,
GraphCenter,
GraphComplement,
GraphDifference,
GraphIntersection,
GraphJoin,
GraphPower,
GraphProduct,
GraphSum,
GraphUnion,
GraphicQ,
GrayCode,
GridGraph,
HamiltonianCycle,
HamiltonianQ,
Harary,
HasseDiagram,
HeapSort,
Heapify,
HideCycles,
Hypercube,
IdenticalQ,
IncidenceMatrix,
IndependentSetQ,
Index,
InduceSubgraph,
InitializeUnionFind,
InsertIntoTableau,
IntervalGraph,
InversePermutation,
Inversions,
InvolutionQ,
IsomorphicQ,
IsomorphismQ,
Isomorphism,
Josephus,
KSubsets,
K,
LabeledTreeToCode,
LastLexicographicTableau,
LexicographicPermutations,
LexicographicSubsets,
LineGraph,
LongestIncreasingSubsequence,
M,
MakeGraph,
MakeSimple,
MakeUndirected,
MaximalMatching,
MaximumAntichain,
MaximumClique,
MaximumIndependentSet,
MaximumSpanningTree,
MinimumChainPartition,
MinimumChangePermutations,
MinimumSpanningTree,
MinimumVertexCover,
MultiplicationTable,
NetworkFlowEdges,
NetworkFlow,
NextComposition,
NextKSubset,
NextPartition,
NextPermutation,
NextSubset,
NextTableau,
NormalizeVertices,
NthPair,
NthPermutation,
NthSubset,
NumberOfCompositions,
NumberOfDerangements,
NumberOfInvolutions,
NumberOfPartitions,
NumberOfPermutationsByCycles,
NumberOfSpanningTrees,
NumberOfTableaux,
OrientGraph,
PartialOrderQ,
PartitionQ,
Partitions,
PathConditionGraph,
Path,
PerfectQ,
PermutationGroupQ,
PermutationQ,
Permute,
PlanarQ,
PointsAndLines,
Polya,
PseudographQ,
RadialEmbedding,
Radius,
RandomComposition,
RandomGraph,
RandomHeap,
RandomKSubset,
RandomPartition,
RandomPermutation1,
RandomPermutation2,
RandomPermutation,
RandomSubset,
RandomTableau,
RandomTree,
RandomVertices,
RankGraph,
RankPermutation,
RankSubset,
RankedEmbedding,
ReadGraph,
RealizeDegreeSequence,
RegularGraph,
RegularQ,
RemoveSelfLoops,
RevealCycles,
RootedEmbedding,
RotateVertices,
Runs,
SamenessRelation,
SelectionSort,
SelfComplementaryQ,
ShakeGraph,
ShortestPathSpanningTree,
ShortestPath,
ShowGraph,
ShowLabeledGraph,
ShowWeightedGraph,
ShowWeightedLabeledGraph,
SignaturePermutation,
SimpleQ,
Spectrum,
SpringEmbedding,
SpringEmbeddingDirected,
StableMarriage,
Star,
StirlingFirst,
StirlingSecond,
Strings,
StronglyConnectedComponents,
Subsets,
TableauClasses,
TableauQ,
TableauxToPermutation,
Tableaux,
ToAdjacencyLists,
ToCycles,
ToInversionVector,
ToOrderedPairs,
ToUnorderedPairs,
ToOrderedTriples,
TopologicalSort,
TransitiveClosure,
TransitiveQ,
TransitiveReduction,
TranslateVertices,
TransposePartition,
TransposeTableau,
TravelingSalesmanBounds,
TravelingSalesman,
TreeQ,
TriangleInequalityQ,
Turan,
TwoColoring,
UndirectedQ,
UnionSet,
UnweightedQ,
V,
VertexColoring,
VertexConnectivity,
VertexCoverQ,
Vertices,
WeaklyConnectedComponents,
Wheel,
WriteGraph,
DilworthGraph ]
(* end Change  *)

Graph::usage = "Graph[g,v] is the header for a graph object where g is an adjacency matrix and v is a list of vertices."

Directed::usage = "Directed is an option to inform certain functions that the graph is directed."

Undirected::usage = "Undirected is an option to inform certain functions that the graph is undirected."

Edge::usage = "Edge is an option to inform certain functions to work with edges instead of vertices."

All::usage = "All is an option to inform certain functions to return all solutions, instead of just the first one."

AcyclicQ::usage = "AcyclicQ[g] returns True if graph g is acyclic. AcyclicQ[g,Directed] returns True if g is a directed acyclic graph."

AddEdge::usage = "AddEdge[g,{x,y}] returns graph g with a new undirected edge {x,y}, while AddEdge[g,{x,y},Directed] returns graph g with a new directed edge {x,y}."

AddVertex::usage = "AddVertex[g] adds a disconnected vertex to graph g."

AllPairsShortestPath::usage = "AllPairsShortestPath[g] returns a matrix, where the (i,j)th entry is the length of the shortest path in g between vertices i and j."

ArticulationVertices::usage = "ArticulationVertices[g] returns a list of all articulation vertices in graph g, vertices whose removal will disconnect the graph."

Automorphisms::usage = "Automorphisms[g] finds the automorphism group of a graph g, the set of isomorphisms of g with itself."

Backtrack::usage = "Backtrack[s,partialQ,solutionQ] performs a backtrack search of the state space s, expanding a partial solution so long as partialQ is True and returning the first complete solution, as identified by solutionQ."

BiconnectedComponents::usage = "BiconnectedComponents[g] returns a list of all the biconnected components of graph g."

BiconnectedComponents::usage = "BiconnectedComponents[g] returns a list of the biconnected components of graph g."

BiconnectedQ::usage = "BiconnectedQ[g] returns True if graph g is biconnected."

BinarySearch::usage = "BinarySearch[l,k,f] searches sorted list l for key k and returns the the position of l containing k, with f a function which extracts the key from an element of l."

BinarySubsets::usage = "BinarySubsets[l] returns all subsets of l ordered according to the binary string defining each subset."

BipartiteMatching::usage = "BipartiteMatching[g] returns the list of edges associated with a maximum matching in bipartite graph g."

BipartiteQ::usage = "BipartiteQ[g] returns True if graph g is bipartite."

BreadthFirstTraversal::usage = "BreadthFirstTraversal[g,v] performs a breadth-first traversal of graph g starting from vertex v, and returns a list of vertices in the order in which they were encountered."

Bridges::usage = "Bridges[g] returns a list of the bridges of graph g, the edges whose removal disconnects the graph."

CartesianProduct::usage = "CartesianProduct[l1,l2] returns the Cartesian product of lists l1 and l2."

CatalanNumber::usage = "CatalanNumber[n] computes the nth Catalan number, for a positive integer n."

ChangeEdges::usage = "ChangeEdges[g,e] constructs a graph with the adjacency matrix e and the embedding of graph g."

ChangeVertices::usage = "ChangeVertices[g,v] constructs a graph with the adjacency matrix of graph g and the list v as its embedding."

ChromaticNumber::usage = "ChromaticNumber[g] computes the chromatic number of the graph, the fewest number of colors necessary to color the graph."

ChromaticPolynomial::usage = "ChromaticPolynomial[g,z] returns the chromatic polynomial P(z) of graph g, which counts the number of ways to color g with exactly z colors."

CirculantGraph::usage = "CirculantGraph[n,l] constructs a circulant graph on n vertices, meaning the ith vertex is adjacent to the (i+j)th and (i-j)th vertex, for each j in list l."

CircularVertices::usage = "CircularVertices[n] constructs a list of n points equally spaced on a circle."

CliqueQ::usage = "CliqueQ[g,c] returns True if the list of vertices c defines a clique in graph g."

CodeToLabeledTree::usage = "CodeToLabeledTree[l] constructs the unique labeled tree on n vertices from the Prufer code l, which consists of a list of n-2 integers from 1 to n."

Cofactor::usage = "Cofactor[m,{i,j}] calculates the (i,j)th cofactor of matrix m."

CompleteQ::usage = "CompleteQ[g] returns True if graph g is complete."

Compositions::usage = "Compositions[n,k] returns a list of all compositions of integer n into k parts."

ConnectedComponents::usage = "ConnectedComponents[g] returns the vertices of graph g partitioned into connected components."

ConnectedQ::usage = "ConnectedQ[g] returns True if undirected graph g is connected. ConnectedQ[g,Directed] and ConnectedQ[g,Undirected] returns True if g is strongly or weakly connected, respectively."

ConstructTableau::usage = "ConstructTableau[p] performs the bumping algorithm repeatedly on each element of permutation p, resulting in a distinct Young tableau."

Contract::usage = "Contract[g,{x,y}] gives the graph resulting from contracting edge {x,y} of graph g."

CostOfPath::usage = "CostOfPath[g,p] sums up the weights of the edges in graph g defined by the path p."

Cycle::usage = "Cycle[n] constructs the cycle on n vertices, a 2-regular connected graph."

DeBruijnSequence::usage = "DeBruijnSequence[a,n] constructs a de Bruijn sequence on the alphabet described by list a, the shortest sequence such that every string of length n on a occurs as a contiguous subrange of the sequence."

DegreeSequence::usage = "DegreeSequence[g] returns the sorted degree sequence of graph g."

DeleteCycle::usage = "DeleteCycle[g,c] deletes undirected cycle c from graph g. DeleteCycle[g,c,Directed] deletes directed cycle c from graph g."

DeleteEdge::usage = "DeleteEdge[g,{x,y}] returns graph g minus undirected edge {x,y}, while DeleteEdge[g,{x,y},Directed] returns graph g minus directed edge {x,y}."

DeleteFromTableau::usage = "DeleteFromTableau[t,r] deletes the last element of row r from Young tableaux t."

DeleteVertex::usage = "DeleteVertex[g,v] deletes vertex v from graph g."

DepthFirstTraversal::usage = "DepthFirstTraversal[g,v] performs a depth-first traversal of graph g starting from vertex v, and returns a list of vertices in the order in which they were encountered."

DerangementQ::usage = "DerangementQ[p] tests whether permutation p is a derangement, a permutation without a fixed point."

Derangements::usage = "Derangements[p] constructs all derangements of permutation p."

Diameter::usage = "Diameter[g] computes the diameter of graph g, the length of the longest shortest path between two vertices of g."

Dijkstra::usage = "Dijkstra[g,v] returns the shortest path spanning tree and associated distances from vertex v of graph g."

DilateVertices::usage = "DilateVertices[v,d] multiplies each coordinate of each vertex position in list l by d, thus dilating the embedding."

DistinctPermutations::usage = "DistinctPermutations[l] returns all permutations of the multiset described by list l."

Distribution::usage = "Distribution[l,set] lists the frequency of occurrence of each element of set in list l."

DurfeeSquare::usage = "DurfeeSquare[p] computes the number of rows involved in the Durfee square of partition p, the side of the largest sized square contained within the Ferrers diagram of p."

Eccentricity::usage = "Eccentricity[g] computes the eccentricity of each vertex v of graph g, the length of the longest shortest path from v."

EdgeChromaticNumber::usage = "EdgeChromaticNumber[g] computes the fewest number of colors necessary to color each edge of graph g, so that no two edges incident on the same vertex have the same color."

EdgeColoring::usage = "EdgeColoring[g] uses Brelaz's heuristic to find a good, but not necessarily minimal, edge coloring of graph g."

EdgeConnectivity::usage = "EdgeConnectivity[g] computes the minimum number of edges whose deletion from graph g disconnects it."

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

Element::usage = "Element[a,l] returns the lth element of nested list a, where l is a list of indices"

EmptyGraph::usage = "EmptyGraph[n] generates an empty graph on n vertices."

EmptyQ::usage = "EmptyQ[g] returns True if graph g contains no edges."

EncroachingListSet::usage = "EncroachingListSet[p] constructs the encroaching list set associated with permutation p."

EquivalenceClasses::usage = "EquivalenceClasses[r] identifies the equivalence classes among the elements of matrix r."

EquivalenceRelationQ::usage = "EquivalenceRelationQ[r] returns True if the matrix r defines an equivalence relation. EquivalenceRelationQ[g] tests whether the adjacency matrix of graph g defines an equivalence relation."

Equivalences::usage = "Equivalences[g,h] lists the vertex equivalence classes between graphs g and h defined by the all-pairs shortest path heuristic."

EulerianCycle::usage = "EulerianCycle[g] finds an Eulerian circuit of undirected graph g if one exists. EulerianCycle[g,Directed] finds an Eulerian circuit of directed graph g if one exists."

EulerianQ::usage = "EulerianQ[g] returns True if graph g is Eulerian, meaning there exists a tour which includes each edge exactly once. EulerianQ[g,Directed] returns True if directed graph g is Eulerian."

Eulerian::usage = "Eulerian[n,k] computes the number of permutations of length n with k runs."

ExactRandomGraph::usage = "ExactRandomGraph[n,e] constructs a random labeled graph of exactly e edges and n vertices."

ExpandGraph::usage = "ExpandGraph[g,n] expands graph g to n vertices by adding disconnected vertices."

ExtractCycles::usage = "ExtractCycles[g] returns a list of edge disjoint cycles in graph g."

FerrersDiagram::usage = "FerrersDiagram[p] draws a Ferrers diagram of integer partition p."

FindCycle::usage = "FindCycle[g] finds a list of vertices which define an undirected cycle in graph g. FindCycle[g,Directed] finds a directed cycle in graph g."

FindSet::usage = "FindSet[n,s] returns the root of the set containing n in union-find data structure s."

FirstLexicographicTableau::usage = "FirstLexicographicTableau[p] constructs the first Young tableau with shape described by partition p."

FromAdjacencyLists::usage = "FromAdjacencyLists[l] constructs an adjacency matrix representation for a graph with adjacency lists l, using a circular embedding. FromAdjacencyLists[l,v] uses v as the embedding for the resulting graph."

FromCycles::usage = "FromCycles[c] restores a cycle structure c to the original permutation."

FromInversionVector::usage = "FromInversionVector[v] reconstructs the unique permutation with  inversion vector v."

FromOrderedPairs::usage = "FromOrderedPairs[l] constructs an adjacency matrix representation from a list of ordered pairs l, using a circular embedding. FromOrderedPairs[l,v] uses v as the embedding for the resulting graph."

FromUnorderedPairs::usage = "FromUnorderedPairs[l] constructs an adjacency matrix representation from a list of unordered pairs l, using a circular embedding. FromUnorderedPairs[l,v] uses v as the embedding for the resulting graph."

FromOrderedTriples::usage = "FromOrderedTriples[l] constructs an adjacency matrix representation from a list of ordered triples l, using a circular embedding."

FromUnorderedTriples::usage = "FromUnorderedTriples[l] constructs an adjacency matrix representation from a list of ordered triples l, using a circular embedding."

FunctionalGraph::usage = "FunctionalGraph[f,n] constructs the functional digraph on n vertices defined by integer function f."

Girth::usage = "Girth[g] computes the length of the shortest cycle in unweighted graph g."

GraphCenter::usage = "GraphCenter[g] returns a list of the vertices of graph g with minimum eccentricity."

GraphComplement::usage = "GraphComplement[g] returns the complement of graph g."

GraphDifference::usage = "GraphDifference[g,h] constructs the graph resulting from subtracting the adjacency matrix of graph g from that of graph h."

GraphIntersection::usage = "GraphIntersection[g,h] constructs the graph defined by the edges which are in both graph g and graph h."

GraphJoin::usage = "GraphJoin[g,h] constructs the join of graphs g and h."

GraphPower::usage = "GraphPower[g,k] computes the kth power of graph g, meaning there is an edge between any pair of vertices of g with a path between them of length at most k."

GraphProduct::usage = "GraphProduct[g,h] constructs the product of graphs g and h."

GraphSum::usage = "GraphSum[g,h] constructs the graph resulting from adding the adjacency matrices of graphs g and h."

GraphUnion::usage = "GraphUnion[g,h] constructs the union of graphs g and h. GraphUnion[n,g] constructs n copies of graph g, where n is an integer."

GraphicQ::usage = "GraphicQ[s] returns True if the list of integers s is graphic, and thus represents a degree sequence of some graph."

GrayCode::usage = "GrayCode[l] constructs a binary reflected Gray code on set l."

GridGraph::usage = "GridGraph[n,m] constructs an n*m grid graph, the product of paths on n and m vertices."

HamiltonianCycle::usage = "HamiltonianCycle[g] finds a Hamiltonian cycle in graph g if one exists. HamiltonianCycle[g,All] returns all Hamiltonian cycles of graph g."

HamiltonianQ::usage = "HamiltonianQ[g] returns True if there exists a Hamiltonian cycle in graph g, in other words, if there exists a cycle which visits each vertex exactly once."

Harary::usage = "Harary[k,n] constructs the minimal k-connected graph on n vertices."

HasseDiagram::usage = "HasseDiagram[g] constructs a Hasse diagram of the relation defined by directed acyclic graph g."

HeapSort::usage = "HeapSort[l] performs a heap sort on the items of list l."

Heapify::usage = "Heapify[p] builds a heap from permutation p."

HideCycles::usage = "HideCycles[c] canonically encodes the cycle structure c into a unique permutation."

Hypercube::usage = "Hypercube[n] constructs an n-dimensional hypercube."

IdenticalQ::usage = "IdenticalQ[g,h] returns True if graphs g and h have identical adjacency matrices."

IncidenceMatrix::usage = "IncidenceMatrix[g] returns the (0,1) incidence matrix of graph g, which has a row for each vertex and column for each edge and (v,e)=1 if and only if vertex v is incident upon edge e."

IndependentSetQ::usage = "IndependentSetQ[g,i] returns True if the vertices in list i define an independent set in graph g."

Index::usage = "Index[p] returns the index of permutation p, the sum of all subscripts j such that p[j] is greater than p[j+1]."

InduceSubgraph::usage = "InduceSubgraph[g,s] constructs the subgraph of graph g induced by the list of vertices s."

InitializeUnionFind::usage = "InitializeUnionFind[n] initializes a union-find data structure for n elements."

InsertIntoTableau::usage = "InsertIntoTableau[e,t] inserts integer e into Young tableau t using the bumping algorithm."

IntervalGraph::usage = "IntervalGraph[l] constructs the interval graph defined by the list of intervals l."

InversePermutation::usage = "InversePermutation[p] yields the multiplicative inverse of permutation p."

Inversions::usage = "Inversions[p] counts the number of inversions in permutation p."

InvolutionQ::usage = "InvolutionQ[p] returns True if permutation p is its own inverse."

IsomorphicQ::usage = "IsomorphicQ[g,h] returns True if graphs g and h are isomorphic."

IsomorphismQ::usage = "IsomorphismQ[g,h,p] tests if permutation p defines an isomorphism between graphs g and h."

Isomorphism::usage = "Isomorphism[g,h] returns an isomorphism between graphs g and h if one exists."

Josephus::usage = "Josephus[n,m] generates the inverse of the permutation defined by executing every mth member in a circle of n men."

KSubsets::usage = "KSubsets[l,k] returns all subsets of set l containing exactly k elements, ordered lexicographically."

K::usage = "K[n] creates a complete graph on n vertices. K[a,b,c,...,k] creates a complete k-partite graph of the prescribed shape."

LabeledTreeToCode::usage = "LabeledTreeToCode[g] reduces the tree g to its Prufer code."

LastLexicographicTableau::usage = "LastLexicographicTableau[p] constructs the last Young tableau with shape described by partition p."

LexicographicPermutations::usage = "LexicographicPermutations[l] constructs all permutations of list l in lexicographic order."

LexicographicSubsets::usage = "LexicographicSubsets[l] returns all subsets of set l in lexicographic order."

LineGraph::usage = "LineGraph[g] constructs the line graph of graph g."

LongestIncreasingSubsequence::usage = "LongestIncreasingSubsequence[p] find the longest increasing scattered subsequence of permutation p."

M::usage = "M[g] gives the number of edges in undirected graph g."

MakeGraph::usage = "MakeGraph[v,f] constructs the binary relation defined by function f on all pairs of elements of list v."

MakeSimple::usage = "MakeSimple[g] returns an undirected, unweighted graph derived from directed graph g."

MakeUndirected::usage = "MakeUndirected[g] returns a graph with an undirected edge for each directed edge of graph g."

MaximalMatching::usage = "MaximalMatching[g] returns the list of edges associated with a maximal matching of graph g."

MaximumAntichain::usage = "MaximumAntichain[g] returns a largest set of unrelated vertices in partial order g."

MaximumClique::usage = "MaximumClique[g] finds the largest clique in graph g."

MaximumIndependentSet::usage = "MaximumIndependentSet[g] finds the largest independent set of graph g."

MaximumSpanningTree::usage = "MaximumSpanningTree[g] uses Kruskal's algorithm to find a maximum spanning tree of graph g."

MinimumChainPartition::usage = "MinimumChainPartition[g] partitions partial order g into a minimum number of chains."

MinimumChangePermutations::usage = "MinimumChangePermutations[l] constructs all permutations of list l such that adjacent permutations differ by only one transposition."

MinimumSpanningTree::usage = "MinimumSpanningTree[g] uses Kruskal's algorithm to find a minimum spanning tree of graph g."

MinimumVertexCover::usage = "MinimumVertexCover[g] finds the minimum vertex cover of graph g."

MultiplicationTable::usage = "MultiplicationTable[l,f] constructs the complete transition table defined by the binary relation function f on the elements of list l."

NetworkFlowEdges::usage = "NetworkFlowEdges[g,source,sink] returns the adjacency matrix showing the distribution of the maximum flow from source to sink in graph g."

NetworkFlow::usage = "NetworkFlow[g,source,sink] finds the maximum flow through directed graph g from source to sink."

NextComposition::usage = "NextComposition[l] constructs the integer composition which follows l in a canonical order."

NextKSubset::usage = "NextKSubset[l,s] computes the k-subset of list l which appears after k-subsets s in lexicographic order."

NextPartition::usage = "NextPartition[p] returns the integer partition following p in reverse lexicographic order."

NextPermutation::usage = "NextPermutation[p] returns the permutation following p in lexicographic order"

NextSubset::usage = "NextSubset[l,s] constructs the subset of l following subset s in canonical order."

NextTableau::usage = "NextTableau[t] returns the tableau of shape t which follows t in lexicographic order."

NormalizeVertices::usage = "NormalizeVertices[v] returns a list of vertices with the same structure as v but with all coordinates of all points between 0 and 1."

NthPair::usage = "NthPair[n] returns the nth unordered pair of positive integers, when sequenced to minimize the size of the larger integer."

NthPermutation::usage = "NthPermutation[n,l] returns the nth lexicographic permutation of list l."

NthSubset::usage = "NthSubset[n,l] returns the nth subset of list l in canonical order."

NumberOfCompositions::usage = "NumberOfCompositions[n,k] counts the number of distinct compositions of  integer n into k parts."

NumberOfDerangements::usage = "NumberOfDerangements[n] counts the derangements on n elements, the permutations without any fixed points."

NumberOfInvolutions::usage = "NumberOfInvolutions[n] counts the number of involutions on n elements."

NumberOfPartitions::usage = "NumberOfPartitions[n] counts the number of distinct integer partitions of n."

NumberOfPermutationsByCycles::usage = "NumberOfPermutationsByCycles[n,m] returns the number of permutations of length n with exactly m cycles."

NumberOfSpanningTrees::usage = "NumberOfSpanningTrees[g] computes the number of distinct labeled spanning trees of graph g."

NumberOfTableaux::usage = "NumberOfTableaux[p] uses the hook length formula to count the number of Young tableaux with shape defined by partition p."

OrientGraph::usage = "OrientGraph[g] assigns a direction to each edge of a bridgeless, undirected graph g, so that the graph is strongly connected."

PartialOrderQ::usage = "PartialOrderQ[g] returns True if the binary relation defined by the adjacency matrix of graph g is a partial order, meaning it is transitive, reflexive, and anti-symmetric."

PartitionQ::usage = "PartitionQ[p] returns True if p is an integer partition."

Partitions::usage = "Partitions[n] constructs all partitions of integer n in reverse lexicographic order."

PathConditionGraph::usage = "PathConditionGraph[g] replaces each non-edge of a graph by an infinite cost, so shortest path algorithms work correctly"

Path::usage = "Path[n] constructs a tree consisting only of a path on n vertices."

PerfectQ::usage = "PerfectQ[g] returns true is g is a perfect graph, meaning that for every induced subgraph of g the size of the largest clique equals the chromatic number."

PermutationGroupQ::usage = "PermutationGroupQ[l] returns True if the list of permutations l forms a permutation group."

PermutationQ::usage = "PermutationQ[p] returns True if p represents a permutation and False otherwise."

Permute::usage = "Permute[l,p] permutes list l according to permutation p."

PlanarQ::usage = "PlanarQ[g] returns True if graph g is planar, meaning it can be drawn in the plane so no two edges cross."

PointsAndLines::usage = "PointsAndLines[g] constructs a partial graphics representation of a graph g."

Polya::usage = "Polya[g,m] returns the polynomial giving the number of colorings, with m colors, of a structure defined by the permutation group g."

PseudographQ::usage = "PseudographQ[g] returns True if graph g is a pseudograph, meaning it contains self-loops."

RadialEmbedding::usage = "RadialEmbedding[g] constructs a radial embedding of graph g, radiating from the center of the graph."

Radius::usage = "Radius[g] computes the radius of graph g, the minimum eccentricity of any vertex of g."

RandomComposition::usage = "RandomComposition[n,k] constructs a random composition of integer n into k parts."

RandomGraph::usage = "RandomGraph[n,p,{l,h}] constructs a random labeled graph on n vertices with an edge probability of p and edge weights of integers drawn uniformly at random from the range (l,h). RandomGraph[n,p,{l,h},Directed] similarly constructs a random directed graph."

RandomHeap::usage = "RandomHeap[n] constructs a random heap on n elements."

RandomKSubset::usage = "RandomKSubset[l,k] returns a random subset of set l with exactly k elements."

RandomPartition::usage = "RandomPartition[n] constructs a random partition of integer n."

RandomPermutation1::usage = "RandomPermutation1[n] sorts random numbers to generate a random permutation."

RandomPermutation2::usage = "RandomPermutation2[n] uses random transpositions to generate random permutations."

RandomPermutation::usage = "RandomPermutation[n] returns a random permutation of length n."

RandomSubset::usage = "RandomSubset[l] creates a random subset of set l."

RandomTableau::usage = "RandomTableau[p] constructs a random Young tableau of shape p."

RandomTree::usage = "RandomTree[n] constructs a random labeled tree on n vertices."

RandomVertices::usage = "RandomVertices[g] assigns a random embedding to graph g."

RankGraph::usage = "RankGraph[g,l] partitions the vertices into classes based on the shortest geodesic distance to a member of list l."

RankPermutation::usage = "RankPermutation[p] computes the rank of permutation p in lexicographic order."

RankSubset::usage = "RankSubset[l,s] computes the rank, in canonical order, of subset s of set l."

RankedEmbedding::usage = "RankedEmbedding[g,l] performs a ranked embedding of graph g, with the vertices ranked in terms of geodesic distance from a member of list l."

ReadGraph::usage = "ReadGraph[f] reads a graph represented as edge lists from file f, and returns the graph as a graph object."

RealizeDegreeSequence::usage = "RealizeDegreeSequence[s] constructs a semirandom graph with degree sequence s."

RegularGraph::usage = "RegularGraph[k,n] constructs a semirandom k-regular graph on n vertices, if such a graph exists."

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

RemoveSelfLoops::usage = "RemoveSelfLoops[g] constructs a graph g with the same edges except for any self-loops."

RevealCycles::usage = "RevealCycles[p] unveils the canonical hidden cycle structure of permutation p."

RootedEmbedding::usage = "RootedEmbedding[g,v] constructs a rooted embedding of graph g with vertex v as the root."

RotateVertices::usage = "RotateVertices[v,theta] rotates each vertex position in list v by theta radians around the origin (0,0)."

Runs::usage = "Runs[p] partitions p into contiguous increasing subsequences."

SamenessRelation::usage = "SamenessRelation[l] constructs a binary relation from a list of permutations l which is an equivalence relation if l is a permutation group."

SelectionSort::usage = "SelectionSort[l,f] sorts list l using ordering function f."

SelfComplementaryQ::usage = "SelfComplementaryQ[g] returns True if graph g is self-complementary, meaning it is isomorphic to its complement."

ShakeGraph::usage = "ShakeGraph[g,d] performs a random perturbation of the vertices of graph g, with each vertex moving at most a distance d from its original position."

ShortestPathSpanningTree::usage = "ShortestPathSpanningTree[g,v] constructs the shortest-path spanning tree originating from v, so that the shortest path in graph g from v to any other vertex is the path in the tree."

ShortestPath::usage = "ShortestPath[g,start,end] finds the shortest path between vertices start and end in graph g."

ShowGraph::usage = "ShowGraph[g] displays graph g according to its embedding. ShowGraph[g,Directed] displays directed graph g according to its embedding, with arrows illustrating the orientation of each edge."

ShowLabeledGraph::usage = "ShowLabeledGraph[g] displays graph g according to its embedding, with each vertex labeled with its vertex number. ShowLabeledGraph[g,l] uses the ith element of list l as the label for vertex i. ShowLabeledGraph[g,l,Directed] displays directed graph g according to its embedding, with arrows illustrating the orientation of each edge."

ShowWeightedGraph::usage = "ShowWeightedGraph[g] displays graph g according to its embedding. ShowWeitedGraph[g,Directed] displays directed graph g according to its embedding, with arrows illustrating the orientation of each edge."

ShowWeightedLabeledGraph::usage = "ShowWeightedLabeledGraph[g] displays graph g according to its embedding, with each vertex labeled with its vertex number. ShowWeightedLabeledGraph[g,l] uses the ith element of list l as the label for vertex i. ShowWeightedLabeledGraph[g,l,Directed] displays directed graph g according to its embedding, with arrows illustrating the orientation of each edge."

SignaturePermutation::usage = "SignaturePermutation[p] gives the signature of permutation p."

SimpleQ::usage = "SimpleQ[g] returns True if g is a simple graph, meaning it is unweighted and contains no self-loops."

Spectrum::usage = "Spectrum[g] gives the eigenvalues of graph g."

SpringEmbedding::usage = "SpringEmbedding[g] beautifies the embedding of graph g by modeling the embedding as a system of springs."

SpringEmbeddingDirected::usage = "SpringEmbeddingDirected[g] beautifies the embedding of digraph g by modeling the embedding as a system of springs."

StableMarriage::usage = "StableMarriage[mpref,fpref] finds the male optimal stable marriage defined by lists of permutations describing male and female preferences."

Star::usage = "Star[n] constructs a star on n vertices, which is a tree with one vertex of degree n-1."

StirlingFirst::usage = "StirlingFirst[n,k] computes the Stirling numbers of the first kind."

StirlingSecond::usage = "StirlingSecond[n,k] computes the Stirling numbers of the second kind."

Strings::usage = "Strings[l,n] constructs all possible strings of length n from the elements of list l."

StronglyConnectedComponents::usage = "StronglyConnectedComponents[g] returns the strongly connected components of directed graph g."

Subsets::usage = "Subsets[l] returns all subsets of set l."

TableauClasses::usage = "TableauClasses[p] partitions the elements of permutation p into classes according to their initial columns during Young tableaux construction."

TableauQ::usage = "TableauQ[t] returns True if and only if t represents a Young tableau."

TableauxToPermutation::usage = "TableauxToPermutation[t1,t2] constructs the unique permutation associated with Young tableaux t1 and t2, where both tableaux have the same shape. "

Tableaux::usage = "Tableaux[p] constructs all tableaux whose shape is given by integer partition p."

ToAdjacencyLists::usage = "ToAdjacencyLists[g] constructs an adjacency list representation for graph g."

ToCycles::usage = "ToCycles[p] returns the cycle structure of permutation p."

ToInversionVector::usage = "ToInversionVector[p] computes the inversion vector associated with permutation p."

ToOrderedPairs::usage = "ToOrderedPairs[g] constructs a list of ordered pairs representing the edges of undirected graph g."

ToUnorderedPairs::usage = "ToUnorderedPairs[g] constructs a list of vertex pairs representing graph g, with one pair per undirected edge."

ToOrderedTriples::usage = "ToOrderedTriples[g] constructs a list of ordered triples representing the edges of weighted directed graph g."

TopologicalSort::usage = "TopologicalSort[g] returns a permutation of the vertices of directed acyclic graph g such that an edge (i,j) implies vertex i appears before vertex j."

TransitiveClosure::usage = "TransitiveClosure[g] finds the transitive closure of graph g, the superset of g which contains edge {x,y} iff there is a path from x to y."

TransitiveQ::usage = "TransitiveQ[g] returns True if graph g defines a transitive relation."

TransitiveReduction::usage = "TransitiveReduction[g] finds the smallest graph which has the same transitive closure as g."

TranslateVertices::usage = "TranslateVertices[v,{x,y}] adds the vector {x,y} to each vertex in list v."

TransposePartition::usage = "TransposePartition[p] reflects a partition p of k parts along the main diagonal, creating a partition with maximum part k."

TransposeTableau::usage = "TransposeTableau[t] reflects a Young tableau t along the main diagonal, creating a different tableau."

TravelingSalesmanBounds::usage = "TravelingSalesmanBounds[g] computes upper and lower bounds on the minimum cost traveling salesman tour of graph g."

TravelingSalesman::usage = "TravelingSalesman[g] finds the optimal traveling salesman tour in graph g."

TreeQ::usage = "TreeQ[g] returns True if graph g is a tree."

TriangleInequalityQ::usage = "TriangleInequalityQ[g] returns True if the weight function defined by the adjacency matrix of graph g satisfies the triangle inequality."

Turan::usage = "Turan[n,p] constructs the Turan graph, the extremal graph on n vertices which does not contain K[p]."

TwoColoring::usage = "TwoColoring[g] finds a two-coloring of graph g if g is bipartite."

UndirectedQ::usage = "UndirectedQ[g] returns True if graph g is undirected."

UnionSet::usage = "UnionSet[a,b,s] merges the sets containing a and b in union-find data structure s."

UnweightedQ::usage = "UnweightedQ[g] returns True if all entries in the adjacency matrix of graph g are zero or one."

V::usage = "V[g] gives the order or number of vertices of graph g."

VertexColoring::usage = "VertexColoring[g] uses Brelaz's heuristic to find a good, but not necessarily minimal, vertex coloring of graph g."

VertexConnectivity::usage = "VertexConnectivity[g] computes the minimum number of vertices whose deletion from graph g disconnects it."

VertexCoverQ::usage = "VertexCoverQ[g,c] returns True if the vertices in list c define a vertex cover of graph g."

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

WeaklyConnectedComponents::usage = "WeaklyConnectedComponents[g] returns the weakly connected components of directed graph g."

Wheel::usage = "Wheel[n] constructs a wheel on n vertices, which is the join of K[1] and Cycle[n-1]."

WriteGraph::usage = "WriteGraph[g,f] writes graph g to file f using an edge list representation."

Begin["`private`"]
PermutationQ[p_List] := (Sort[p] == Range[Length[p]])
 
Permute[l_List,p_?PermutationQ] := l [[ p ]]
 
LexicographicPermutations[{l_}] := {{l}}

LexicographicPermutations[{a_,b_}] := {{a,b},{b,a}}

LexicographicPermutations[l_List] :=
	Module[{i,n=Length[l]},
		Apply[
			Join,
			Table[ 
				Map[
					(Prepend[#,l[[i]]])&,
					LexicographicPermutations[
						Complement[l,{l[[i]]}]
					]
				],
				{i,n}
			]
		]
	]
 
RankPermutation[{1}] = 0

RankPermutation[p_?PermutationQ] := (p[[1]]-1) (Length[Rest[p]]!) +
	RankPermutation[ Map[(If[#>p[[1]], #-1, #])&, Rest[p]] ]

NthPermutation[n1_Integer,l_List] :=
	Module[{k, n=n1, s=l, i},
		Table[
			n = Mod[n,(i+1)!];
			k = s [[Quotient[n,i!]+1]];
			s = Complement[s,{k}];
			k,
			{i,Length[l]-1,0,-1}
		]
	]

NextPermutation[p_?PermutationQ] :=
	NthPermutation[ RankPermutation[p]+1, Sort[p] ]
 
RandomPermutation1[n_Integer?Positive] :=
	Map[ Last, Sort[ Map[({Random[],#})&,Range[n]] ] ]

RandomPermutation2[n_Integer?Positive] :=
	Module[{p = Range[n],i,x},
		Do [
			x = Random[Integer,{1,i}];
			{p[[i]],p[[x]]} = {p[[x]],p[[i]]},
			{i,n,2,-1}
		];
		p
	]

RandomPermutation[n_Integer?Positive] := RandomPermutation1[n]
 
MinimumChangePermutations[l_List] :=
	Module[{i=1,c,p=l,n=Length[l],k},
		c = Table[1,{n}];
		Join[
			{l},
			Table[
				While [ c[[i]] >= i, c[[i]] = 1; i++];
				If[OddQ[i], k=1, k=c[[i]] ];
				{p[[i]],p[[k]]} = {p[[k]],p[[i]]};
				c[[i]]++;
				i = 2;
				p,
				{n!-1}
			]
		]
	]
 
Backtrack[space_List,partialQ_,solutionQ_,flag_:One] :=
	Module[{n=Length[space],all={},done,index,v=2,solution},
		index=Prepend[ Table[0,{n-1}],1];
		While[v > 0,
			done = False;
			While[!done && (index[[v]] < Length[space[[v]]]),
				index[[v]]++;
				done = Apply[partialQ,{Solution[space,index,v]}];
			];
			If [done, v++, index[[v--]]=0 ];
			If [v > n,
				solution = Solution[space,index,n];
				If [Apply[solutionQ,{solution}],
					If [SameQ[flag,All],
						AppendTo[all,solution],
						all = solution; v=0
					]
				];
				v--
			]
		];
		all
	]

Solution[space_List,index_List,count_Integer] :=
	Module[{i}, Table[space[[ i,index[[i]] ]], {i,count}] ]
 
DistinctPermutations[s_List] :=
	Module[{freq,alph=Union[s],n=Length[s]},
		freq = Map[ (Count[s,#])&, alph];
		Map[
			(alph[[#]])&,
			Backtrack[
				Table[Range[Length[alph]],{n}],
				(Count[#,Last[#]] <= freq[[Last[#]]])&,
				(Count[#,Last[#]] <= freq[[Last[#]]])&,
				All
			]
		]
	]
 
MinOp[l_List,f_] :=
	Module[{min=First[l]},
		Scan[ (If[ Apply[f,{#,min}], min = #])&, l];
		Return[min];
	]

SelectionSort[l_List,f_] :=
	Module[{where,item,unsorted=l},
		Table[
			item = MinOp[unsorted, f];
			{where} = First[ Position[unsorted,item] ];
			unsorted = Drop[unsorted,{where,where}];
			item,
			{Length[l]}
		]
	]
 
BinarySearch[l_List,k_Integer] := BinarySearch[l,k,1,Length[l],Identity]
BinarySearch[l_List,k_Integer,f_] := BinarySearch[l,k,1,Length[l],f]
	
BinarySearch[l_List,k_Integer,low_Integer,high_Integer,f_] :=
	Module[{mid = Floor[ (low + high)/2 ]},
		If [low > high, Return[low - 1/2]];
		If [f[ l[[mid]] ] == k, Return[mid]];
		If [f[ l[[mid]] ] > k,
			BinarySearch[l,k,1,mid-1,f],
			BinarySearch[l,k,mid+1,high,f]
		]
	]
 
MultiplicationTable[elems_List,op_] :=
	Module[{i,j,n=Length[elems],p},
		Table[
			p = Position[elems, Apply[op,{elems[[i]],elems[[j]]}]];
			If [p === {}, 0, p[[1,1]]],
			{i,n},{j,n}
		]
	]
 
InversePermutation[p_?PermutationQ] :=
	Module[{inverse=p, i},
		Do[ inverse[[ p[[i]] ]] = i, {i,Length[p]} ];
		inverse
	]
 
EquivalenceRelationQ[r_?SquareMatrixQ] :=
	ReflexiveQ[r] && SymmetricQ[r] && TransitiveQ[r]
EquivalenceRelationQ[g_Graph] := EquivalenceRelationQ[ Edges[g] ]

SquareMatrixQ[{}] = True
SquareMatrixQ[r_] := MatrixQ[r] && (Length[r] == Length[r[[1]]])

ReflexiveQ[r_?SquareMatrixQ] := 
	Module[{i}, Apply[And, Table[(r[[i,i]]!=0),{i,Length[r]}] ] ]

TransitiveQ[r_?SquareMatrixQ] := TransitiveQ[ Graph[r,RandomVertices[Length[r]]] ]
TransitiveQ[r_Graph] := IdenticalQ[r,TransitiveClosure[r]]

SymmetricQ[r_?SquareMatrixQ] := (r === Transpose[r])

EquivalenceClasses[r_List?EquivalenceRelationQ] :=
	ConnectedComponents[ Graph[r,RandomVertices[Length[r]]] ]
EquivalenceClasses[g_Graph?EquivalenceRelationQ] := ConnectedComponents[g]
 
PermutationGroupQ[perms_List] :=
	FreeQ[ MultiplicationTable[perms,Permute], 0] &&
		EquivalenceRelationQ[SamenessRelation[perms]]

SamenessRelation[perms_List] :=
	Module[{positions = Transpose[perms], i, j, n=Length[First[perms]]},
		Table[
			If[ MemberQ[positions[[i]],j], 1, 0],
			{i,n}, {j,n}
		]
	] /; perms != {}
 
ToCycles[p1_?PermutationQ] :=
	Module[{p=p1,m,n,cycle,i},
		Select[
			Table[
				m = n = p[[i]];
				cycle = {};
				While[ p[[n]] != 0,
					AppendTo[cycle,m=n];
					n = p[[n]];
					p[[m]] = 0 
				];
				cycle,
				{i,Length[p]}
			],
			(# =!= {})&
		]
	]
 
FromCycles[cyc_List] := 
	Module[{p=Table[0,{Length[Flatten[cyc]]}], pos},
		Scan[
			(pos = Last[#];
			 Scan[ Function[c, pos = p[[pos]] = c], #])&,
			cyc
		];
		p
	]
 
HideCycles[c_List] := 
	Flatten[
		Sort[
			Map[(RotateLeft[#,Position[#,Min[#]] [[1,1]] - 1])&, c],
			(#1[[1]] > #2[[1]])&
		]
	]
 
RevealCycles[p_?PermutationQ] :=
	Module[{start=end=1, cycles={}},
		While [end <= Length[p],
			If [p[[start]] > p[[end]],
				AppendTo[ cycles, Take[p,{start,end-1}] ];
				start = end,
				end++
			]
		];
		Append[cycles,Take[p,{start,end-1}]]
	]
 
NumberOfPermutationsByCycles[n_Integer,m_Integer] := (-1)^(n-m) StirlingS1[n,m]

StirlingFirst[n_Integer,m_Integer] := StirlingFirst1[n,m]

StirlingFirst1[n_Integer,0] := If [n == 0, 1, 0] 
StirlingFirst1[0,m_Integer] := If [m == 0, 1, 0]

StirlingFirst1[n_Integer,m_Integer] := StirlingFirst1[n,m] =
	(n-1) StirlingFirst1[n-1,m] + StirlingFirst1[n-1, m-1]

StirlingSecond[n_Integer,m_Integer] := StirlingSecond1[n,m]

StirlingSecond1[n_Integer,0] := If [n == 0, 1, 0]
StirlingSecond1[0,m_Integer] := If [m == 0, 1, 0]

StirlingSecond1[n_Integer,m_Integer] := StirlingSecond1[n,m] =
	m StirlingSecond1[n-1,m] + StirlingSecond1[n-1,m-1]
 
SignaturePermutation[p_?PermutationQ] := (-1) ^ (Length[p]-Length[ToCycles[p]])
 
Polya[g_List,m_] := Apply[ Plus, Map[(m^Length[ToCycles[#]])&,g] ] / Length[g]
 
ToInversionVector[p_?PermutationQ] :=
	Module[{i,inverse=InversePermutation[p]},
		Table[
			Length[ Select[Take[p,inverse[[i]]], (# > i)&] ],
			{i,Length[p]-1}
		]
	]
 
FromInversionVector[vec_List] :=
	Module[{n=Length[vec]+1,i,p},
		p={n};
		Do [
			p = Insert[p, i, vec[[i]]+1],
			{i,n-1,1,-1}
		];
		p
	]
 
Inversions[p_?PermutationQ] := Apply[Plus,ToInversionVector[p]]
 
Index[p_?PermutationQ]:=
	Module[{i},
		Sum[ If [p[[i]] > p[[i+1]], i, 0], {i,Length[p]-1} ]
	]
 
Runs[p_?PermutationQ] :=
	Map[
		(Apply[Take,{p,{#[[1]]+1,#[[2]]}}])&,
		Partition[
			Join[
				{0},
				Select[Range[Length[p]-1], (p[[#]]>p[[#+1]])&],
				{Length[p]}
			],
			2,
			1
		]
	]

Eulerian[n_Integer,k_Integer] := Eulerian1[n,k]

Eulerian1[0,k_Integer] := If [k==1, 1, 0]
Eulerian1[n_Integer,k_Integer] := Eulerian1[n,k] =
	k Eulerian1[n-1,k] + (n-k+1) Eulerian1[n-1,k-1]
 
InvolutionQ[p_?PermutationQ] := p[[p]] == Range[Length[p]]
 
NumberOfInvolutions[n_Integer] :=
	Module[{k},
		n! Sum[1/((n - 2k)! 2^k k!), {k, 0, Quotient[n, 2]}]
	]
 
DerangementQ[p_?PermutationQ] :=
	!(Apply[ Or, Map[( # == p[[#]] )&, Range[Length[p]]] ])

NumberOfDerangements[0] = 1;
NumberOfDerangements[n_] := n * NumberOfDerangements[n-1] + (-1)^n

Derangements[n_Integer] := Derangements[Range[n]]
Derangements[p_?PermutationQ] := Select[ Permutations[p], DerangementQ ]
 
Josephus[n_Integer,m_Integer] :=
	Module[{live=Range[n],next},
		InversePermutation[
			Table[
				next = RotateLeft[live,m-1];
				live = Rest[next];
				First[next],
				{n}
			]
		]
	]
 
Heapify[p_List] :=
	Module[{j,heap=p},
		Do [
			heap = Heapify[heap,j],
			{j,Quotient[Length[p],2],1,-1}
		];
		heap
	]

Heapify[p_List, k_Integer] :=
	Module[{hp=p, i=k, l, n=Length[p]},
		While[ (l = 2 i) <= n,
			If[ (l < n) && (hp[[l]] > hp[[l+1]]), l++ ];
			If[ hp[[i]] > hp[[l]],
				{hp[[i]],hp[[l]]}={hp[[l]],hp[[i]]};
				i = l,
				i = n+1
			];
		];
		hp
	]

RandomHeap[n_Integer] := Heapify[RandomPermutation[n]]
 
HeapSort[p_List] :=
	Module[{heap=Heapify[p],min},
		Append[
			Table[
				min = First[heap];
				heap[[1]] = heap[[n]];
				heap = Heapify[Drop[heap,-1],1];
				min,
				{n,Length[p],2,-1}
			],
			Max[heap]
		]
	]
 
Strings[l_List,0] := { {} }

Strings[l_List,k_Integer?Positive] :=
	Module[{oneless = Strings[l,k-1],i,n=Length[l]},
		Apply[Join, Table[ Map[(Prepend[#,l[[i]]])&, oneless], {i,n}] ]
	]
 
NthSubset[n_Integer,m_Integer] := NthSubset[n,Range[m]]
NthSubset[n_Integer,l_List] :=
	l[[ Flatten[ Position[Reverse[IntegerDigits[ Mod[n,2^Length[l]],2]],1] ] ]]

BinarySubsets[l_List] :=
	Module[{pos=Reverse[Range[Length[l]]], n=Length[l]},
		Map[(l[[ Reverse[Select[pos*#, Positive]] ]])&, Strings[{0,1},n] ]
	]

NextSubset[set_List,subset_List] := NthSubset[ RankSubset[set,subset], set  ]

RankSubset[set_List,subset_List] :=
	Module[{i,n=Length[set]},
		Sum[ 2^(i-1) * If[ MemberQ[subset,set[[i]]], 1, 0], {i,n}]
	]
 
RandomSubset[set_List] := NthSubset[Random[Integer,2^(Length[set])-1],set]
 
GrayCode[l_List] := GrayCode[l,{{}}]

GrayCode[{},prev_List] := prev

GrayCode[l_List,prev_List] :=
	GrayCode[
		Rest[l],
		Join[ prev, Map[(Append[#,First[l]])&,Reverse[prev]] ]
	]

Subsets[l_List] := GrayCode[l]
Subsets[n_Integer] := GrayCode[Range[n]]
 
LexicographicSubsets[l_List] := LexicographicSubsets[l,{{}}]

LexicographicSubsets[{},s_List] := s

LexicographicSubsets[l_List,subsets_List] :=
	LexicographicSubsets[
		Rest[l],
		Join[
			subsets,
			Map[(Prepend[#,First[l]])&,LexicographicSubsets[Rest[l],{{}}] ]
		]
	]
 
KSubsets[l_List,0] := { {} }
KSubsets[l_List,1] := Partition[l,1]
KSubsets[l_List,k_Integer?Positive] := {l} /; (k == Length[l])
KSubsets[l_List,k_Integer?Positive] := {}  /; (k > Length[l])

KSubsets[l_List,k_Integer?Positive] :=
	Join[
		Map[(Prepend[#,First[l]])&, KSubsets[Rest[l],k-1]],
		KSubsets[Rest[l],k]
	]
 
NextKSubset[set_List,subset_List] :=
	Take[set,Length[subset]] /; (Take[set,-Length[subset]] === subset)

NextKSubset[set_List,subset_List] :=
	Module[{h=1, x=1},
		While [set[[-h]] == subset[[-h]], h++];
		While [set[[x]] =!= subset[[-h]], x++];
		Join[ Drop[subset,-h], Take[set, {x+1,x+h}] ]
	]
 
RandomKSubset[n_Integer,k_Integer] := RandomKSubset[Range[n],k]

RandomKSubset[set_List,k_Integer] := 
	Module[{s=Range[Length[set]],i,n=Length[set],x},
		set [[
			Sort[
				Table[
					x=Random[Integer,{1,i}];
					{s[[i]],s[[x]]} = {s[[x]],s[[i]]};
					s[[i]],
					{i,n,n-k+1,-1}
				]
			]
		]]
	]
 
PartitionQ[p_List] := (Min[p]>0) && Apply[And, Map[IntegerQ,p]]
 
Partitions[n_Integer] := Partitions[n,n]

Partitions[n_Integer,_] := {} /; (n<0)
Partitions[0,_] := { {} }
Partitions[n_Integer,1] := { Table[1,{n}] }
Partitions[_,0] := {}

Partitions[n_Integer,maxpart_Integer] :=
	Join[
		Map[(Prepend[#,maxpart])&, Partitions[n-maxpart,maxpart]],
		Partitions[n,maxpart-1]
	]
 
NextPartition[p_List] := Join[Drop[p,-1],{Last[p]-1,1}]  /; (Last[p] > 1)

NextPartition[p_List] := {Apply[Plus,p]}  /; (Max[p] == 1)

NextPartition[p_List] :=
	Module[{index,k,m},
		{index} = First[ Position[p,1] ];
		k = p[[index-1]] - 1;
		m = Apply[Plus,Drop[p,index-1]] + k + 1;
		Join[
			Take[p,index-2],
			Table[k,{Quotient[m,k]}],
			If [Mod[m,k] == 0, {}, {Mod[m,k]}]
		]
	]
 
FerrersDiagram[p1_List] :=
	Module[{i,j,n=Length[p1],p=Sort[p1]},
		Show[
			Graphics[
				Join[
					{PointSize[ Min[0.05,1/(2 Max[p])] ]},
					Table[Point[{i,j}], {j,n}, {i,p[[j]]}]
				],
				{AspectRatio -> 1, PlotRange -> All}
			]
		]
	]
 
TransposePartition[p_List] :=
	Module[{s=Select[p,(#>0)&], i, row, r},
		row = Length[s];
		Table [
			r = row;
			While [s[[row]]<=i, row--];
			r,
			{i,First[s]}
		]
	]
 
DurfeeSquare[s_List] :=
	Module[{i,max=1},
		Do [
			If [s[[i]] >= i, max=i],
			{i,2,Min[Length[s],First[s]]}
		];
		max
	]

DurfeeSquare[{}] := 0
 
NumberOfPartitions[n_Integer] := NumberOfPartitions1[n]

NumberOfPartitions1[n_Integer] := 0  /; (n < 0)
NumberOfPartitions1[n_Integer] := 1  /; (n == 0)

NumberOfPartitions1[n_Integer] := NumberOfPartitions1[n] =
	Module[{m},
		Sum[ (-1)^(m+1) NumberOfPartitions1[n - m (3m-1)/2] +
			(-1)^(m+1) NumberOfPartitions1[n - m (3m+1)/2],
			{m, Ceiling[ (1+Sqrt[1.0 + 24n])/6 ], 1, -1}
		]
	]
 
RandomPartition[n_Integer?Positive] :=
	Module[{mult = Table[0,{n}],j,d,m = n},
		While[ m != 0,
			{j,d} = NextPartitionElement[m];
			m -= j d;
			mult[[d]] += j;
		];
		Flatten[Map[(Table[#,{mult[[#]]}])&,Reverse[Range[n]]]]
	]

NextPartitionElement[n_Integer] :=
	Module[{d=0,j,m,z=Random[] n PartitionsP[n],done=False,flag},
		While[!done,
			d++; m = n; j = 0; flag = False;
			While[ !flag,
				j++; m -=d;
				If[ m > 0, 
					z -= d PartitionsP[m];
					If[ z <= 0, flag=done=True],
					flag = True;
					If[m==0, z -=d; If[z <= 0, done = True]]
				];
			];
		];
		{j,d}
	]
 
NumberOfCompositions[n_,k_] := Binomial[ n+k-1, n ]
 
RandomComposition[n_Integer,k_Integer] :=
	Map[
		(#[[2]] - #[[1]] - 1)&,
		Partition[Join[{0},RandomKSubset[Range[n+k-1],k-1],{n+k}], 2, 1]
	]
 
Compositions[n_Integer,k_Integer] :=
	Map[
		(Map[(#[[2]]-#[[1]]-1)&, Partition[Join[{0},#,{n+k}],2,1] ])&,
		KSubsets[Range[n+k-1],k-1]
	]
 
NextComposition[l_List] := 
	Module[{c=l, h=1, t},
		While[c[[h]] == 0, h++];
		{t,c[[h]]} = {c[[h]],0};
		c[[1]] = t - 1;
		c[[h+1]]++;
		c
	]

NextComposition[l_List] :=
	Join[{Apply[Plus,l]},Table[0,{Length[l]-1}]] /; Last[l]==Apply[Plus,l]
 
TableauQ[{}] = True
TableauQ[t_List] :=
	And [
		Apply[ And, Map[(Apply[LessEqual,#])&,t] ],
		Apply[ And, Map[(Apply[LessEqual,#])&,TransposeTableau[t]] ],
		Apply[ GreaterEqual, Map[Length,t] ],
		Apply[ GreaterEqual, Map[Length,TransposeTableau[t]] ]
	]

TransposeTableau[tb_List] :=
	Module[{t=Select[tb,(Length[#]>=1)&],row},
		Table[
			row = Map[First,t];
			t = Map[ Rest, Select[t,(Length[#]>1)&] ];
			row,
			{Length[First[tb]]}
		]
	]

ShapeOfTableau[t_List] := Map[Length,t]
 
InsertIntoTableau[e_Integer,{}] := { {e} }

InsertIntoTableau[e_Integer, t1_?TableauQ] :=
	Module[{item=e,row=0,col,t=t1},
		While [row < Length[t],
			row++;
			If [Last[t[[row]]] <= item,
				AppendTo[t[[row]],item];
				Return[t]
			];
			col = Ceiling[ BinarySearch[t[[row]],item] ];
			{item, t[[row,col]]} = {t[[row,col]], item};
		];
		Append[t, {item}]
	]
 
ConstructTableau[p_List] := ConstructTableau[p,{}]

ConstructTableau[{},t_List] := t

ConstructTableau[p_List,t_List] :=
	ConstructTableau[Rest[p], InsertIntoTableau[First[p],t]]
 
DeleteFromTableau[t1_?TableauQ,r_Integer]:=
	Module [{t=t1, col, row, item=Last[t1[[r]]]},
		col = Length[t[[r]]];
		If[col == 1, t = Drop[t,-1], t[[r]] = Drop[t[[r]],-1]];
		Do [
			While [t[[row,col]]<=item && Length[t[[row]]]>col, col++];
			If [item < t[[row,col]], col--];
			{item,t[[row,col]]} = {t[[row,col]],item},
			{row,r-1,1,-1}
		];
		t
	]
 
TableauxToPermutation[p1_?TableauQ,q1_?TableauQ] :=
	Module[{p=p1, q=q1, row, firstrow},
		Reverse[
			Table[
				firstrow = First[p];
				row = Position[q, Max[q]] [[1,1]];
				p = DeleteFromTableau[p,row];
				q[[row]] = Drop[ q[[row]], -1];
				If[ p == {},
					First[firstrow],
					First[Complement[firstrow,First[p]]]
				],
				{Apply[Plus,ShapeOfTableau[p1]]}
			]
		]
	] /; ShapeOfTableau[p1] === ShapeOfTableau[q1]
 
LastLexicographicTableau[s_List] :=
	Module[{c=0},
		Map[(c+=#; Range[c-#+1,c])&, s]
	]

FirstLexicographicTableau[s_List] :=
	TransposeTableau[ LastLexicographicTableau[ TransposePartition[s] ] ]
 
NextTableau[t_?TableauQ] :=
	Module[{s,y,row,j,count=0,tj,i,n=Max[t]},
		y = TableauToYVector[t];
		For [j=2, (j<n)  && (y[[j]]>=y[[j-1]]), j++];
		If [y[[j]] >= y[[j-1]],
			Return[ FirstLexicographicTableau[ ShapeOfTableau[t] ] ]
		];
		s = ShapeOfTableau[ Table[Select[t[[i]],(#<=j)&], {i,Length[t]}] ];
		{row} = Last[ Position[ s, s[[ Position[t,j] [[1,1]] + 1 ]] ] ];
		s[[row]] --;
		tj = FirstLexicographicTableau[s];
		If[ Length[tj] < row,
			tj = Append[tj,{j}],
			tj[[row]] = Append[tj[[row]],j]
		];
		Join[
			Table[
				Join[tj[[i]],Select[t[[i]],(#>j)&]],
				{i,Length[tj]}
			],
			Table[t[[i]],{i,Length[tj]+1,Length[t]}]
		]
	]

Tableaux[s_List] :=
	Module[{t = LastLexicographicTableau[s]},
		Table[ t = NextTableau[t], {NumberOfTableaux[s]} ]
	]

Tableaux[n_Integer?Positive] := Apply[ Join, Map[ Tableaux, Partitions[n] ] ]
 
YVectorToTableau[y_List] :=
	Module[{k},
		Table[ Flatten[Position[y,k]], {k,Length[Union[y]]}]
	]

TableauToYVector[t_?TableauQ] :=
	Module[{i,y=Table[1,{Length[Flatten[t]]}]},
		Do [ Scan[ (y[[#]]=i)&, t[[i]] ], {i,2,Length[t]} ];
		y
	]
 
NumberOfTableaux[{}] := 1
NumberOfTableaux[s_List] := 
	Module[{row,col,transpose=TransposePartition[s]},
		(Apply[Plus,s])! /
		Product [
			(transpose[[col]]-row+s[[row]]-col+1),
			{row,Length[s]}, {col,s[[row]]}
		]
	]

NumberOfTableaux[n_Integer] := Apply[Plus, Map[NumberOfTableaux, Partitions[n]]]
 
CatalanNumber[n_] := Binomial[2n,n]/(n+1)	/; (n>=0)
 
RandomTableau[shape_List] :=
	Module[{i=j=n=Apply[Plus,shape],done,l,m,h=1,k,y,p=shape},
		y= Join[TransposePartition[shape],Table[0,{n - Max[shape]}]];
		Do[
			{i,j} = RandomSquare[y,p]; done = False;
			While [!done,
				h = y[[j]] + p[[i]] - i - j;
				If[ h != 0,
					If[ Random[] < 0.5,
						j = Random[Integer,{j,p[[i]]}],
						i = Random[Integer,{i,y[[j]]}]
					],
					done = True
				];
			];
			p[[i]]--; y[[j]]--;
			y[[m]] = i,
			{m,n,1,-1}
		];
		YVectorToTableau[y]
	]

RandomSquare[y_List,p_List] :=
	Module[{i=Random[Integer,{1,First[y]}], j=Random[Integer,{1,First[p]}]},
		While[(i > y[[j]]) || (j > p[[i]]), 
			i = Random[Integer,{1,First[y]}];
			j = Random[Integer,{1,First[p]}]
		];
		{i,j}
	]
 
TableauClasses[p_?PermutationQ] :=
	Module[{classes=Table[{},{Length[p]}],t={}},
		Scan [
			(t = InsertIntoTableau[#,t];
			 PrependTo[classes[[Position[First[t],#] [[1,1]] ]], #])&,
			p
		];
		Select[classes, (# != {})&]
	]
 
LongestIncreasingSubsequence[p_?PermutationQ] :=
	Module[{c,x,xlast},
		c = TableauClasses[p];
		xlast = x = First[ Last[c] ];
		Append[
			Reverse[
				Map[
					(x = First[ Intersection[#,
					       Take[p, Position[p,x][[1,1]] ] ] ])&,
					Reverse[ Drop[c,-1] ]
				]
			],
			xlast
		]
	]

LongestIncreasingSubsequence[{}] := {}
 
AddToEncroachingLists[k_Integer,{}] := {{k}}

AddToEncroachingLists[k_Integer,l_List] :=
	Append[l,{k}]  /; (k > First[Last[l]]) && (k < Last[Last[l]])

AddToEncroachingLists[k_Integer,l1_List] :=
	Module[{i,l=l1},
		If [k <= First[Last[l]],
			i = Ceiling[ BinarySearch[l,k,First] ];
			PrependTo[l[[i]],k],
			i = Ceiling[ BinarySearch[l,-k,(-Last[#])&] ];
			AppendTo[l[[i]],k]
		];
		l
	]
 
EncroachingListSet[l_List] := EncroachingListSet[l,{}]
EncroachingListSet[{},e_List] := e

EncroachingListSet[l_List,e_List] :=
	EncroachingListSet[Rest[l], AddToEncroachingLists[First[l],e] ]
 
Edges[Graph[e_,_]] := e

Vertices[Graph[_,v_]] := v

V[Graph[e_,_]] := Length[e]

M[Graph[g_,_],___] := Apply[Plus, Map[(Apply[Plus,#])&,g] ] / 2
M[Graph[g_,_],Directed] := Apply[Plus, Map[(Apply[Plus,#])&,g] ]

ChangeVertices[g_Graph,v_List] := Graph[ Edges[g], v ]

ChangeEdges[g_Graph,e_List] := Graph[ e, Vertices[g] ]
 
AddEdge[Graph[g_,v_],{x_,y_},Directed] :=
	Module[ {gnew=g},
		gnew[[x,y]] ++;
		Graph[gnew,v]
	]

AddEdge[g_Graph,{x_,y_},flag_:Undirected] :=
	AddEdge[ AddEdge[g, {x,y}, Directed], {y,x}, Directed]

DeleteEdge[Graph[g_,v_],{x_,y_},Directed] :=
	Module[ {gnew=g},
		If [ g[[x,y]] > 1, gnew[[x,y]]--, gnew[[x,y]] = 0];
		Graph[gnew,v]
	]

DeleteEdge[g_Graph,{x_,y_},flag_:Undirected] :=
	DeleteEdge[ DeleteEdge[g, {x,y}, Directed], {y,x}, Directed]
 
AddVertex[g_Graph] := GraphUnion[g, K[1]]

DeleteVertex[g_Graph,v_Integer] := InduceSubgraph[g,Complement[Range[V[g]],{v}]]
 
Spectrum[Graph[g_,_]] := Eigenvalues[g]
 
ToAdjacencyLists[Graph[g_,_]] :=
	Map[ (Flatten[ Position[ #, _?(Function[n, n!=0])] ])&, g ]

FromAdjacencyLists[e_List] :=
	Module[{blanks = Table[0,{Length[e]}] },
		Graph[
			Map [ (MapAt[ 1&,blanks,Partition[#,1]])&, e ],
			CircularVertices[Length[e]]
		]
	]

FromAdjacencyLists[e_List,v_List] := ChangeVertices[FromAdjacencyLists[e], v]
 
ToOrderedPairs[g_Graph] := Position[ Edges[g], _?(Function[n,n != 0]) ]

ToUnorderedPairs[g_Graph] := Select[ ToOrderedPairs[g], (#[[1]] < #[[2]])& ]

FromOrderedPairs[l_List] := 
	Module[{n=Max[l]},
		Graph[
			MapAt[1&, Table[0,{n},{n}],l],
			CircularVertices[n]
		]
	]
FromOrderedPairs[{}] := Graph[{},{}]
FromOrderedPairs[l_List,v_List] := 
	Graph[ MapAt[1&, Table[0,{Length[v]},{Length[v]}], l], v]

FromUnorderedPairs[l_List] := MakeUndirected[ FromOrderedPairs[l] ]
FromUnorderedPairs[l_List,v_List] := MakeUndirected[ FromOrderedPairs[l,v] ]

(* Addition: Extension of From* and ToOrderedPairs
by Fukuda 941006 *)
FromOrderedTriples[tr_List]:=
	Block[{graph,pairs,wedges},
		pairs=Transpose[Drop[Transpose[tr],-1]];
		graph=FromOrderedPairs[pairs];
		wedges=Edges[graph];
		Scan[(wedges[[#[[1]],#[[2]]]]=#[[3]])&,tr];
	graph=Graph[wedges,Vertices[graph]]
	]

FromUnorderedTriples[tr_List]:=
	Block[{graph,pairs,wedges},
		pairs=Transpose[Drop[Transpose[tr],-1]];
		graph=FromOrderedPairs[pairs];
		wedges=Edges[graph];
		Scan[(wedges[[#[[1]],#[[2]]]]=#[[3]];wedges[[#[[2]],#[[1]]]]=#[[3]])&,tr];
	graph=Graph[wedges,Vertices[graph]]
	]

ToOrderedTriples[g_Graph] := 
	Map[Append[#,Edges[g][[#[[1]],#[[2]]]]]&, Position[ Edges[g], _?(Function[n,n != 0]) ]]
(* end of Addition   *)

PseudographQ[Graph[g_,_]] :=
	Module[{i},
		Apply[Or, Table[ g[[i,i]]!=0, {i,Length[g]} ]]
	]

UnweightedQ[Graph[g_,_]] := Apply[ And, Map[(#==0 || #==1)&, Flatten[g] ] ]

SimpleQ[g_Graph] := (!PseudographQ[g]) && (UnweightedQ[g])

RemoveSelfLoops[g_Graph] :=
	Module[{i,e=Edges[g]},
		Do [ e[[i,i]]=0, {i,V[g]} ];
		Graph[e, Vertices[g]]
	]	

EmptyQ[g_Graph] := Edges[g] == Table[0, {V[g]}, {V[g]}]

CompleteQ[g_Graph] := Edges[RemoveSelfLoops[g]] == Edges[ K[V[g]] ]
 
InduceSubgraph[g_Graph,{}] := Graph[{},{}]

InduceSubgraph[Graph[g_,v_],s_List] :=
	Graph[Transpose[Transpose[g[[s]]] [[s]] ],v[[s]]] /; (Length[s]<=Length[g])
 
Contract[g_Graph,{u_Integer,v_Integer}] :=
	Module[{o,e,i,n=V[g],newg,range=Complement[Range[V[g]],{u,v}]},
		newg = InduceSubgraph[g,range];
		e = Edges[newg]; o = Edges[g];
		Graph[
			Append[
				Table[
					Append[e[[i]],
						If[o[[range[[i]],u]]>0 ||
							o[[range[[i]],v]]>0,1,0] ],
					{i,n-2}
				],
				Append[
					Map[(If[o[[u,#]]>0||o[[v,#]]>0,1,0])&,range],
					0
				]
			],
			Join[Vertices[newg], {(Vertices[g][[u]]+Vertices[g][[v]])/2}]
		]
	] /; V[g] > 2

Contract[g_Graph,_] := K[1]	/; V[g] == 2
 
GraphComplement[Graph[g_,v_]] :=
	RemoveSelfLoops[ Graph[ Map[ (Map[ (If [#==0,1,0])&, #])&, g], v ] ]
 
MakeUndirected[Graph[g_,v_]] :=
	Module[{i,j,n=Length[g]},
		Graph[ Table[If [g[[i,j]]!=0 || g[[j,i]]!=0,1,0],{i,n},{j,n}], v ]
	]

UndirectedQ[Graph[g_,_]] := (Apply[Plus,Apply[Plus,Abs[g-Transpose[g]]]] == 0)

MakeSimple[g_Graph] := MakeUndirected[RemoveSelfLoops[g]]
 
BFS[g_Graph,start_Integer] :=
	Module[{e,bfi=Table[0,{V[g]}],cnt=1,edges={},queue={start}},
		e = ToAdjacencyLists[g];
		bfi[[start]] = cnt++;
		While[ queue != {},
			{v,queue} = {First[queue],Rest[queue]};
			Scan[
				(If[ bfi[[#]] == 0,
					bfi[[#]] = cnt++;
					AppendTo[edges,{v,#}];
					AppendTo[queue,#]
				])&,
				e[[v]]
			];
		];
		{edges,bfi}
	]
				
BreadthFirstTraversal[g_Graph,s_Integer,Edge] := First[BFS[g,s]]

BreadthFirstTraversal[g_Graph,s_Integer,___] := InversePermutation[Last[BFS[g,s]]]
 
DFS[v_Integer] :=
	( dfi[[v]] = cnt++;
	  AppendTo[visit,v];
	  Scan[ (If[dfi[[#]]==0,AppendTo[edges,{v,#}];DFS[#] ])&, e[[v]] ] )

DepthFirstTraversal[g_Graph,start_Integer,flag_:Vertex] :=
	Block[{visit={},e=ToAdjacencyLists[g],edges={},dfi=Table[0,{V[g]}],cnt=1},
		DFS[start];
		If[ flag===Edge, edges, visit]
	]

ShowGraph[g1_Graph,type_:Undirected] :=
	Module[{g=NormalizeVertices[g1]},
		Show[
			Graphics[
				Join[
					PointsAndLines[g],
					If[SameQ[type,Directed],Arrows[g],{}]
				]
			], 
			{AspectRatio->1, PlotRange->FindPlotRange[Vertices[g]]}
		]
	]

(* Addtion: Weighted Graph drawing by
   Fukuda 941006  *)
ShowWeightedGraph[g1_Graph,type_:Undirected] :=
	Module[{g=NormalizeVertices[g1]},
		Show[
			Graphics[
				Join[
					If[SameQ[type,Directed],PointsAndLines[g],PointsAndProportionalLines[g]],
					If[SameQ[type,Directed],ProportionalArrows[g],{}]
				]
			], 
			{AspectRatio->1, PlotRange->FindPlotRange[Vertices[g]]}
		]
	]


MinimumEdgeLength[v_List,pairs_List] :=
	Max[ Select[
		Chop[ Map[(Sqrt[ N[(v[[#[[1]]]]-v[[#[[2]]]]) . 
			(v[[#[[1]]]]-v[[#[[2]]]])] ])&,pairs] ],
		(# > 0)&
	], 0.001 ]

(* Change:  for larger off-set by K. Fukuda 930530  *)
FindPlotRange[v_List] :=
	Module[{xmin=Min[Map[First,v]], xmax=Max[Map[First,v]],
			ymin=Min[Map[Last,v]], ymax=Max[Map[Last,v]]},
		{ {xmin - 0.18 Max[1,xmax-xmin], xmax + 0.18 Max[1,xmax-xmin]},
		  {ymin - 0.18 Max[1,ymax-ymin], ymax + 0.18 Max[1,ymax-ymin]} }
	]
(* end Change *)

(* Change:  for thiner line and smaller points by 
   K. Fukuda 960516  *)
PointsAndLines[Graph[e_List,v_List]] :=
	Module[{pairs=ToOrderedPairs[Graph[e,v]]},
		Join[
			{PointSize[ 0.02 ]},
			Map[Point,Chop[v]],
			{Thickness[ 0.0025 ]},
			Map[(Line[Chop[ v[[#]] ]])&,pairs]
		]
	]
PointsAndProportionalLines[Graph[e_List,v_List]] :=
	Module[{triples=ToOrderedTriples[Graph[e,v]]},
		Join[
			{PointSize[ 0.02 ]},
			Map[Point,Chop[v]],
			Map[{Thickness[ 0.0025 * #[[3]]],(Line[Chop[ v[[Drop[#,-1]]] ]])}&,triples]
		]
	]


(* End Change *)

(* Change:  Narrower arrow, and different arrow positioning by 
   K. Fukuda 930604  *)
Arrows[Graph[e_,v_]] :=
	Module[{pairs=ToOrderedPairs[Graph[e,v]], size, triangle},
		size = Min[0.04, MinimumEdgeLength[v,pairs]/4];
		triangle={ {0,0}, {-size,size/4}, {-size,-size/4} };
		Map[
			(Polygon[
				TranslateVertices[
					RotateVertices[
						triangle,
						Arctan[Apply[Subtract,v[[#]]]]+Pi
					],
					v[[ #[[2]] ]]*(7/8)+v[[ #[[1]] ]]*(1/8)
				]
			])&,
			pairs
		]
	]
(* end of Change *)

(* Addition: Proportional arrows for weighted graphs by 
   K. Fukuda 930604  *)
ProportionalArrows[Graph[e_,v_]] :=
	Module[{triples=ToOrderedTriples[Graph[e,v]], 
		pairs=ToOrderedPairs[Graph[e,v]],size, triangle},
		size = Min[0.05, MinimumEdgeLength[v,pairs]/3];
		triangle={ {0,0}, {-size,size/4}, {-size,-size/4} };
		Map[
			(Polygon[
				TranslateVertices[
					RotateVertices[
						triangle * #[[3]],
						Arctan[Apply[Subtract,v[[Drop[#,-1]]]]]+Pi
					],
					v[[ #[[2]] ]]*(7/8)+v[[ #[[1]] ]]*(1/8)
				]
			])&,
			triples
		]
	]
(* end of Change *)

ShowLabeledGraph[g_Graph] := ShowLabeledGraph[g,Range[V[g]]]
ShowLabeledGraph[g1_Graph,labels_List] :=
	Module[{pairs=ToOrderedPairs[g1], g=NormalizeVertices[g1], v},
		v = Vertices[g];
		Show[
			Graphics[
				Join[
					PointsAndLines[g],
					Map[(Line[Chop[ v[[#]] ]])&, pairs],
					GraphLabels[v,labels]
				]
			],
			{AspectRatio->1, PlotRange->FindPlotRange[v]} 
		]
	]

(* Addition: Directed option for ShowLabeledGraph   
   by K. Fukuda 930604  *)
ShowLabeledGraph[g1_Graph,labels_List,type_:Undirected] :=
	Module[{pairs=ToOrderedPairs[g1], g=NormalizeVertices[g1], v},
		v = Vertices[g];
		Show[
			Graphics[
				Join[
					PointsAndLines[g],
					If[SameQ[type,Directed],Arrows[g],{}],
					Map[(Line[Chop[ v[[#]] ]])&, pairs],
					GraphLabels[v,labels]
				]
			],
			{AspectRatio->1, PlotRange->FindPlotRange[v]} 
		]
	]

ShowWeightedLabeledGraph[g1_Graph,labels_List,type_:Undirected] :=
	Module[{pairs=ToOrderedPairs[g1], g=NormalizeVertices[g1], v},
		v = Vertices[g];
		Show[
			Graphics[
				Join[
					If[SameQ[type,Directed],PointsAndLines[g],PointsAndProportionalLines[g]],
					If[SameQ[type,Directed],ProportionalArrows[g],{}],
					Map[(Line[Chop[ v[[#]] ]])&, pairs],
					GraphLabels[v,labels]
				]
			],
			{AspectRatio->1, PlotRange->FindPlotRange[v]} 
		]
	]


(* end Addition *)

GraphLabels[v_List,l_List] :=
	Module[{i},
		Table[ Text[ l[[i]],v[[i]]-{0.025,0.025},{0,1} ],{i,Length[v]}]
	]
 
CircularVertices[0] := {}

CircularVertices[n_Integer] :=
	Module[{i,x = N[2 Pi / n]},
		Chop[ Table[ N[{ (Cos[x i]), (Sin[x i]) }], {i,n} ] ]
	]

CircularVertices[Graph[g_,_]] := Graph[ g, CircularVertices[ Length[g] ] ]
 
RankGraph[g_Graph, start_List] :=
	Module[ {rank = Table[0,{V[g]}],edges = ToAdjacencyLists[g],v,queue,new},
		Scan[ (rank[[#]] = 1)&, start];
		queue = start;
		While [queue != {},
			v = First[queue];
			new = Select[ edges[[v]], (rank[[#]] == 0)&];
			Scan[ (rank[[#]] = rank[[v]]+1)&, new];
			queue = Join[ Rest[queue], new];
		];
		rank
	]
 
RankedEmbedding[g_Graph,start_List] := Graph[ Edges[g],RankedVertices[g,start] ]

RankedVertices[g_Graph,start_List] :=
	Module[{i,m,stages,rank,freq = Table[0,{V[g]}]},
		rank = RankGraph[g,start];
		stages = Distribution[ rank ];
		Table[
			m = ++ freq[[ rank[[i]] ]];
			{rank[[i]], (m-1) + (1 - stages[[ rank[[i]] ]])/2 },
			{i,V[g]}
		]
	]

Distribution[l_List] := Distribution[l, Union[l]]
Distribution[l_List, set_List] := Map[(Count[l,#])&, set]
 
Eccentricity[g_Graph] := Map[ Max, AllPairsShortestPath[g] ]
Eccentricity[g_Graph,start_Integer] := Map[ Max, Last[Dijkstra[g,start]] ]

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

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

GraphCenter[g_Graph] := 
	Module[{eccentricity = Eccentricity[g]},
		Flatten[ Position[eccentricity, Min[eccentricity]] ]
	]
 
RadialEmbedding[g_Graph,ct_Integer] :=
	Module[{center=ct,ang,i,da,theta,n,v,positioned,done,next,e=ToAdjacencyLists[g]},
		ang = Table[{0,2 Pi},{n=V[g]}];
		v = Table[{0,0},{n}];
		positioned = next = done = {center};
		While [next != {},
			center = First[next];
			new = Complement[e[[center]], positioned];
			Do [
				da = (ang[[center,2]]-ang[[center,1]])/Length[new];
				ang[[ new[[i]] ]] = {ang[[center,1]] + (i-1)*da,
					ang[[center,1]] + i*da};
				theta = Apply[Plus,ang[[ new[[i]] ]] ]/2;
				v[[ new[[i]] ]] = v[[center]] +
					N[{Cos[theta],Sin[theta]}],
				{i,Length[new]}
			];
			next = Join[Rest[next],new];
			positioned = Union[positioned,new];
			AppendTo[done,center]
		];
		Graph[Edges[g],v]
	]

RadialEmbedding[g_Graph] := RadialEmbedding[g,First[GraphCenter[g]]];
 
RootedEmbedding[g_Graph,rt_Integer] :=
	Module[{root=rt,pos,i,x,dx,new,n=V[g],v,done,next,e=ToAdjacencyLists[g]},
		pos = Table[{-Ceiling[Sqrt[n]],Ceiling[Sqrt[n]]},{n}];
		v = Table[{0,0},{n}];
		next = done = {root};
		While [next != {},
			root = First[next];
			new = Complement[e[[root]], done];
			Do [
				dx = (pos[[root,2]]-pos[[root,1]])/Length[new];
				pos[[ new[[i]] ]] = {pos[[root,1]] + (i-1)*dx,
					pos[[root,1]] + i*dx};
				x = Apply[Plus,pos[[ new[[i]] ]] ]/2;
				v[[ new[[i]] ]] = {x,v[[root,2]]-1},
				{i,Length[new]}
			];
			next = Join[Rest[next],new];
			done = Join[done,new]
		];
		Graph[Edges[g],N[v]]
	]
 
TranslateVertices[v_List,{x_,y_}] := Map[ (# + {x,y})&, v ]
TranslateVertices[Graph[g_,v_],{x_,y_}] := Graph[g, TranslateVertices[v,{x,y}] ]

DilateVertices[v_List,d_] := (d * v)
DilateVertices[Graph[e_,v_],d_] := Graph[e, DilateVertices[v,d]]

RotateVertices[v_List,t_] := 
	Module[{d,theta},
		Map[
			(If[# == {0,0}, {0,0},
				d=Sqrt[#[[1]]^2 + #[[2]]^2];
			 	theta = t + Arctan[#];
			 	N[{d Cos[theta], d Sin[theta]}]
			])&,
			v
		]
	]
RotateVertices[Graph[g_,v_],t_] := Graph[g, RotateVertices[v,t]]

Arctan[{x_,y_}] := Arctan1[Chop[{x,y}]]
Arctan1[{0,0}] := 0
Arctan1[{x_,y_}] := ArcTan[x,y]

(* Change: to normalize in x and y directions independently]
   by K. Fukuda 930601  *)
NormalizeVertices[v_List] := 
	Module[{vx=Transpose[v][[1]],vy=Transpose[v][[2]],
		xmin,xmax,ymin,ymax,dx,dy},
		xmin=Min[vx];  xmax=Max[vx];
		ymin=Min[vy];  ymax=Max[vy];
		dx=Max[(xmax-xmin),0.01];
		dy=Max[(ymax-ymin),0.01];
		Map[{(#[[1]]-xmin)/dx,(#[[2]]-ymin)/dy}&,v]
	]
(* end Change  *)

NormalizeVertices[Graph[g_,v_]] := Graph[g, NormalizeVertices[v]]
 
ShakeGraph[Graph[e_List,v_List], fract_:0.1] :=
	Module[{i,d,a},
		Graph[
			e,
			Table[ 
				d = Random[Real,{0,fract}];
				a = Random[Real,{0, 2 N[Pi]}];
				{N[v[[i,1]] + d Cos[a]], N[v[[i,2]] + d Sin[a]]},
				{i,Length[e]}
			]
		]
	]
 
CalculateForce[u_Integer,g_Graph,em_List] :=
	Module[{n=V[g],stc=0.25,gr=10.0,e=Edges[g],f={0.0,0.0},spl=1.0,v,dsquared},
		Do [
			dsquared = Max[0.001, Apply[Plus,(em[[u]]-em[[v]])^2] ];
			f += (1-e[[u,v]]) (gr/dsquared) (em[[u]]-em[[v]])
				- e[[u,v]] stc Log[dsquared/spl] (em[[u]]-em[[v]]),
			{v,n}
		];
		f
	]

SpringEmbedding[g_Graph,step_:10,inc_:0.15] :=
	Module[{new=old=Vertices[g],n=V[g],i,u,g1=MakeUndirected[g]},
		Do [
			Do [
				new[[u]] = old[[u]]+inc*CalculateForce[u,g1,old],
				{u,n}
			];
			old = new,
			{i,step}
		];
		Graph[Edges[g],new]
	]
 
(*	Rewritten for Version 2.0	*)


(* Change: A directed spring embedding made by 
Fukuda 94-10-05 *)

SpringEmbeddingDirected[g_Graph,step_:10,inc_:0.15] :=
	Module[{new=old=Vertices[g],n=V[g],i,u,g1=g},
		Do [
			Do [
				new[[u]] = old[[u]]+inc*CalculateForce[u,g1,old],
				{u,n}
			];
			old = new,
			{i,step}
		];
		Graph[Edges[g],new]
	]
 
(* end of Change *)

ReadGraph[file_] :=
	Module[{edgelist={}, v={},x},
		OpenRead[file];
		While[!SameQ[(x = Read[file,Number]), EndOfFile],
			AppendTo[v,Read[file,{Number,Number}]];
			AppendTo[edgelist,
				Convert[Characters[Read[file,String]]]
			];
		];
		Close[file];
		FromAdjacencyLists[edgelist,v]
	]

Toascii[s_String] := First[ ToCharacterCode[s] ]

Convert[l_List] := 
	Module[{ch,num,edge={},i=1},
		While[i <= Length[l],
			If[ DigitQ[ l[[i]] ], 
				num = 0;
				While[ ((i <= Length[l]) && (DigitQ[l[[i]]])),
					num = 10 num + Toascii[l[[i++]]] - Toascii["0"]
				];
				AppendTo[edge,num],
				i++
			];
		];
		edge
	]
 
WriteGraph[g_Graph,file_] := 
	Module[{edges=ToAdjacencyLists[g],v=N[NormalizeVertices[Vertices[g]]],i,x,y},
		OpenWrite[file];
		Do[
			WriteString[file,"	",ToString[i]];
			{x,y} = Chop[ v [[i]] ];
			WriteString[file,"	",ToString[x],"	",ToString[y]];
			Scan[
				(WriteString[file,"	",ToString[ # ]])&,
				edges[[i]]
			];
			Write[file],
			{i,V[g]}
		];
		Close[file];
	]
 
GraphUnion[g_Graph,h_Graph] :=
	Module[{maxg=Max[ Map[First,Vertices[g]] ], minh=Min[ Map[First,Vertices[h]] ]},
		FromOrderedPairs[
			Join[ ToOrderedPairs[g], (ToOrderedPairs[h] + V[g])],
			Join[ Vertices[g], Map[({maxg-minh+1,0}+#)&, Vertices[h] ] ]
		]
	]

GraphUnion[1,g_Graph] := g
GraphUnion[0,g_Graph] := EmptyGraph[0];
GraphUnion[k_Integer,g_Graph] := GraphUnion[ GraphUnion[k-1,g], g]

ExpandGraph[g_Graph,n_] := GraphUnion[ g, EmptyGraph[n - V[g]] ] /; V[g] <= n
 
GraphIntersection[g_Graph,h_Graph] :=
	FromOrderedPairs[
		Intersection[ToOrderedPairs[g],ToOrderedPairs[h]],
		Vertices[g]
	] /; (V[g] == V[h])
 
GraphDifference[g1_Graph,g2_Graph] :=
	Graph[Edges[g1] - Edges[g2], Vertices[g1]] /; V[g1]==V[g2]

GraphSum[g1_Graph,g2_Graph] :=
	Graph[Edges[g1] + Edges[g2], Vertices[g1]] /; V[g1]==V[g2]
 
GraphJoin[g_Graph,h_Graph] :=
	Module[{maxg=Max[ Abs[ Map[First,Vertices[g]] ] ]},
		FromUnorderedPairs[
			Join[
				ToUnorderedPairs[g],
				ToUnorderedPairs[h] + V[g],
				CartesianProduct[Range[V[g]],Range[V[h]]+V[g]]
			],
			Join[ Vertices[g], Map[({maxg+1,0}+#)&, Vertices[h]]]
		]
	]

CartesianProduct[a_List,b_List] :=
	Module[{i,j},
		Flatten[ Table[{a[[i]],b[[j]]},{i,Length[a]},{j,Length[b]}], 1]
	]
 
GraphProduct[g_Graph,h_Graph] :=
	Module[{k,eg=ToOrderedPairs[g],eh=ToOrderedPairs[h],leng=V[g],lenh=V[h]},
		FromOrderedPairs[
			Flatten[
				Join[
					Table[eg+(i-1)*leng, {i,lenh}],
					Map[ (Table[
						{leng*(#[[1]]-1)+k, leng*(#[[2]]-1)+k},
						{k,1,leng}
					      ])&,
					      eh
					]
				],
				1
			],
			ProductVertices[Vertices[g],Vertices[h]]
		]
	]

ProductVertices[vg_,vh_] :=
	Flatten[
		Map[
			(TranslateVertices[
				DilateVertices[vg, 1/(Max[Length[vg],Length[vh]])],
			#])&,
			 RotateVertices[vh,Pi/2]
		],
		1
	]
 
IncidenceMatrix[g_Graph] :=
	Map[
		( Join[
			Table[0,{First[#]-1}], {1},
			Table[0,{Last[#]-First[#]-1}], {1},
			Table[0,{V[g]-Last[#]}]
		] )&,
		ToUnorderedPairs[g]
	]
 
LineGraph[g_Graph] :=
	Module[{b=IncidenceMatrix[g], edges=ToUnorderedPairs[g], v=Vertices[g]},
		Graph[
			b . Transpose[b] - 2 IdentityMatrix[Length[edges]],
			Map[ ( (v[[ #[[1]] ]] + v[[ #[[2]] ]]) / 2 )&, edges]
		]
	]
 
K[0] := Graph[{},{}]
K[1] := Graph[{{0}},{{0,0}}]

K[n_Integer?Positive] := CirculantGraph[n,Range[1,Floor[(n+1)/2]]]

CirculantGraph[n_Integer?Positive,l_List] :=
	Module[{i,r},
		r = Prepend[MapAt[1&,Table[0,{n-1}], Map[List,Join[l,n-l]]], 0];
		Graph[ Table[RotateRight[r,i], {i,0,n-1}], CircularVertices[n] ]
	]

EmptyGraph[n_Integer?Positive] :=
	Module[{i},
		Graph[ Table[0,{n},{n}], Table[{0,i},{i,(1-n)/2,(n-1)/2}] ]
	]
 
K[l__] :=
	Module[{ll=List[l],t,i,x,row,stages=Length[List[l]]},
		t = FoldList[Plus,0,ll];
		Graph[
			Apply[
				Join,
				Table [
					row = Join[
						Table[1, {t[[i-1]]}],
						Table[0, {t[[i]]-t[[i-1]]}],
						Table[1, {t[[stages+1]]-t[[i]]}]
					];
					Table[row, {ll[[i-1]]}],
					{i,2,stages+1}
				]
			
			],
			Apply [
				Join,
				Table[
					Table[{x,i-1+(1-ll[[x]])/2},{i,ll[[x]]}],
					{x,stages}
				]
			]
		]
	] /; TrueQ[Apply[And, Map[Positive,List[l]]]] && (Length[List[l]]>1)
 
Turan[n_Integer,p_Integer] :=
	Module[{k = Floor[ n / (p-1) ], r},
		r = n - k (p-1);
		Apply[K, Join[ Table[k,{p-1-r}], Table[k+1,{r}] ] ]
	] /; (n > 0 && p > 1)
 
Cycle[n_Integer] := CirculantGraph[n,{1}]  /; n>=3
 
Star[n_Integer?Positive] :=
	Module[{g},
		g = Append [ Table[0,{n-1},{n}], Append[ Table[1,{n-1}], 0] ];
		Graph[
			g + Transpose[g],
			Append[ CircularVertices[n-1], {0,0}]
		]
	]
 
Wheel[n_Integer] :=
	Module[{i,row = Join[{0,1}, Table[0,{n-4}], {1}]},
		Graph[
			Append[
				Table[ Append[RotateRight[row,i-1],1], {i,n-1}],
				Append[ Table[1,{n-1}], 0]
			],
			Append[ CircularVertices[n-1], {0,0} ]
		]
	] /; n >= 3
 
Path[1] := K[1]
Path[n_Integer?Positive] :=
	FromUnorderedPairs[ Partition[Range[n],2,1], Map[({#,0})&,Range[n]] ]

GridGraph[n_Integer?Positive,m_Integer?Positive] :=
	GraphProduct[
		ChangeVertices[Path[n], Map[({Max[n,m]*#,0})&,Range[n]]],
		Path[m]
	]
 
Hypercube[n_Integer] := Hypercube1[n]

Hypercube1[0] := K[1]
Hypercube1[1] := Path[2]
Hypercube1[2] := Cycle[4]

Hypercube1[n_Integer] := Hypercube1[n] =
	GraphProduct[
		RotateVertices[ Hypercube1[Floor[n/2]], 2Pi/5],
		Hypercube1[Ceiling[n/2]]
	]
 
LabeledTreeToCode[g_Graph] :=
	Module[{e=ToAdjacencyLists[g],i,code},
		Table [
			{i} = First[ Position[ Map[Length,e], 1 ] ];
			code = e[[i,1]];
			e[[code]] = Complement[ e[[code]], {i} ];
			e[[i]] = {};
			code,
			{V[g]-2}
		]
	]
 
CodeToLabeledTree[l_List] :=
	Module[{m=Range[Length[l]+2],x,i},
		FromUnorderedPairs[
			Append[
				Table[
					x = Min[Complement[m,Drop[l,i-1]]];
					m = Complement[m,{x}];
					{x,l[[i]]},
					{i,Length[l]}
				],
				m
			]
		]
	]

RandomTree[n_Integer?Positive] :=
	RadialEmbedding[CodeToLabeledTree[ Table[Random[Integer,{1,n}],{n-2}] ], 1]
 
RandomGraph[n_Integer,p_] := RandomGraph[n,p,{1,1}]

RandomGraph[n_Integer,p_,range_List] :=
	Module[{i,g},
		g = Table[ 
			Join[
				Table[0,{i}],
				Table[ 
					If[Random[Real]<p, Random[Integer,range], 0],
					{n-i}
				]
			],
			{i,n}
		];
		Graph[ g + Transpose[g], CircularVertices[n] ]
	]
 
ExactRandomGraph[n_Integer,e_Integer] :=
	FromUnorderedPairs[
		Map[ NthPair, Take[ RandomPermutation[n(n-1)/2], e] ],
		CircularVertices[n]
	]

NthPair[0] := {}
NthPair[n_Integer] :=
	Module[{i=2},
		While[ Binomial[i,2] < n, i++];
		{n - Binomial[i-1,2], i}
	]

RandomVertices[n_Integer] := Table[{Random[], Random[]}, {n}]
RandomVertices[g_Graph] := Graph[ Edges[g], RandomVertices[V[g]] ]
 
RandomGraph[n_Integer,p_,range_List,Directed] :=
	RemoveSelfLoops[
		Graph[
			Table[If[Random[Real]<p,Random[Integer,range],0],{n},{n}],
			CircularVertices[n]
		]
	]

RandomGraph[n_Integer,p_,Directed] := RandomGraph[n,p,{1,1},Directed]
 
DegreeSequence[g_Graph] := Reverse[ Sort[ Degrees[g] ] ]

Degrees[Graph[g_,_]] := Map[(Apply[Plus,#])&, g]

GraphicQ[s_List] := False /; (Min[s] < 0) || (Max[s] >= Length[s])
GraphicQ[s_List] := (First[s] == 0) /; (Length[s] == 1)
GraphicQ[s_List] :=
	Module[{m,sorted = Reverse[Sort[s]]},
		m = First[sorted];
		GraphicQ[ Join[ Take[sorted,{2,m+1}]-1, Drop[sorted,m+1] ] ]
	]
 
RealizeDegreeSequence[d_List] :=
	Module[{i,j,v,set,seq,n=Length[d],e},
		seq = Reverse[ Sort[ Table[{d[[i]],i},{i,n}]] ];
		FromUnorderedPairs[
			Flatten[ Table[
				{{k,v},seq} = {First[seq],Rest[seq]};
				While[ !GraphicQ[
					MapAt[
						(# - 1)&,
						Map[First,seq],
						set = RandomKSubset[Table[{i},{i,n-j}],k] 
					] ]
				];
				e = Map[(Prepend[seq[[#,2]],v])&,set];
				seq = Reverse[ Sort[
					MapAt[({#[[1]]-1,#[[2]]})&,seq,set]
				] ];
				e,
				{j,Length[d]-1}
			], 1],
			CircularVertices[n]
		]
	] /; GraphicQ[d]

RealizeDegreeSequence[d_List,seed_Integer] :=
	(SeedRandom[seed]; RealizeDegreeSequence[d])
 
RegularQ[Graph[g_,_]] := Apply[ Equal, Map[(Apply[Plus,#])& , g] ]

RegularGraph[k_Integer,n_Integer] := RealizeDegreeSequence[Table[k,{n}]]
 
MakeGraph[v_List,f_] :=
	Module[{n=Length[v],i,j},
		Graph [
			Table[If [Apply[f,{v[[i]],v[[j]]}], 1, 0],{i,n},{j,n}],
			CircularVertices[n]
		]
	]
 
IntervalGraph[l_List] :=
	MakeGraph[
		l,
		( ((First[#1] <= First[#2]) && (Last[#1] >= First[#2])) ||
		  ((First[#2] <= First[#1]) && (Last[#2] >= First[#1])) )&
	]
 
FunctionalGraph[f_,n_] :=
	Module[{i,x},
		FromOrderedPairs[
			Table[{i, x=Mod[Apply[f,{i}],n]; If[x!=0,x,n]}, {i,n} ],
			CircularVertices[n]
		]
	]
 
ConnectedComponents[g_Graph] :=
	Module[{untraversed=Range[V[g]],traversed,comps={}},
		While[untraversed != {},
			traversed = DepthFirstTraversal[g,First[untraversed]];
			AppendTo[comps,traversed];
			untraversed = Complement[untraversed,traversed]
		];
		comps
	]

ConnectedQ[g_Graph] := Length[ DepthFirstTraversal[g,1] ] == V[g]
 
WeaklyConnectedComponents[g_Graph] := ConnectedComponents[ MakeUndirected[g] ]

ConnectedQ[g_Graph,Undirected] := Length[ WeaklyConnectedComponents[g] ] == 1
 
StronglyConnectedComponents[g_Graph] :=
	Block[{e=ToAdjacencyLists[g],s,c=1,i,cur={},low=dfs=Table[0,{V[g]}],scc={}},
		While[(s=Select[Range[V[g]],(dfs[[#]]==0)&]) != {},
			SearchStrongComp[First[s]];
		];
		scc
	]

SearchStrongComp[v_Integer] :=
	Block[{r},
		low[[v]]=dfs[[v]]=c++;
		PrependTo[cur,v];
		Scan[
			(If[dfs[[#]] == 0,
				SearchStrongComp[#];
				low[[v]]=Min[low[[v]],low[[#]]],
				If[(dfs[[#]] < dfs[[v]]) && MemberQ[cur,#],
					low[[v]]=Min[low[[v]],dfs[[#]] ]
				];
			])&,
			e[[v]]
		];
		If[low[[v]] == dfs[[v]],
			{r} = Flatten[Position[cur,v]];
			AppendTo[scc,Take[cur,r]];
			cur = Drop[cur,r];
		];
	]

ConnectedQ[g_Graph,Directed] := Length[ StronglyConnectedComponents[g] ] == 1
 
OrientGraph[g_Graph] :=
	Module[{pairs,newg,rest,cc,c,i,e},
		pairs = Flatten[Map[(Partition[#,2,1])&,ExtractCycles[g]],1];
		newg = FromUnorderedPairs[pairs,Vertices[g]];
		rest = ToOrderedPairs[ GraphDifference[ g, newg ] ];
		cc = Sort[ConnectedComponents[newg], (Length[#1]>=Length[#2])&];
		c = First[cc];
		Do[
			e = Select[rest,(MemberQ[c,#[[1]]] &&
					 MemberQ[cc[[i]],#[[2]]])&];
			rest = Complement[rest,e,Map[Reverse,e]];
			c = Union[c,cc[[i]]];
			pairs = Join[pairs, Prepend[ Rest[e],Reverse[e[[1]]] ] ],
			{i,2,Length[cc]}
		];
		FromOrderedPairs[
			Join[pairs, Select[rest,(#[[1]] > #[[2]])&] ],
			Vertices[g]
		]
	] /; SameQ[Bridges[g],{}]
 
FindBiconnectedComponents[g_Graph] :=
	Block[{e=ToAdjacencyLists[g],n=V[g],par,c=0,act={},back,dfs,ap=bcc={}},
		back=dfs=Table[0,{n}];
		par = Table[n+1,{n}]; 
		Map[(SearchBiConComp[First[#]])&, ConnectedComponents[g]];
		{bcc,Drop[ap, -1]}
	]

SearchBiConComp[v_Integer] :=
	Block[{r},
		back[[v]]=dfs[[v]]=++c;
		Scan[
			(If[ dfs[[#]] == 0, 
				If[!MemberQ[act,{v,#}], PrependTo[act,{v,#}]];
				par[[#]] = v;
				SearchBiConComp[#];
				If[ back[[#]] >= dfs[[v]],
					{r} = Flatten[Position[act,{v,#}]];
					AppendTo[bcc,Union[Flatten[Take[act,r]]]];
					AppendTo[ap,v];
					act = Drop[act,r]
				];
				back[[v]] = Min[ back[[v]],back[[#]] ],
				If[# != par[[v]],back[[v]]=Min[dfs[[#]],back[[v]]]]
			])&,
			e[[v]]
		];
	]
 
ArticulationVertices[g_Graph]  := Union[Last[FindBiconnectedComponents[g]]];

Bridges[g_Graph] := Select[BiconnectedComponents[g],(Length[#] == 2)&]

BiconnectedComponents[g_Graph] := First[FindBiconnectedComponents[g]];

BiconnectedQ[g_Graph] := Length[ BiconnectedComponents[g] ] == 1
 
EdgeConnectivity[g_Graph] :=
	Module[{i},
		Apply[Min, Table[NetworkFlow[g,1,i], {i,2,V[g]}]]
	]
 
VertexConnectivityGraph[g_Graph] :=
	Module[{n=V[g],e},
		e=Table[0,{2 n},{2 n}];
		Scan[ (e[[#-1,#]] = 1)&, 2 Range[n] ];
		Scan[
			(e[[#[[1]], #[[2]]-1]] = e[[#[[2]],#[[1]]-1]] = Infinity)&,
			2 ToUnorderedPairs[g]
		];
		Graph[e,Apply[Join,Map[({#,#})&,Vertices[g]]]]
	]

VertexConnectivity[g_Graph] :=
	Module[{p=VertexConnectivityGraph[g],k=V[g],i=0,notedges},
		notedges = ToUnorderedPairs[ GraphComplement[g] ];
		While[ i++ <= k,
			k = Min[
				Map[
					(NetworkFlow[p,2 #[[1]],2 #[[2]]-1])&,
					Select[notedges,(First[#]==i)&]
				],
				k
			]
		];
		k
	]
 
Harary[k_?EvenQ, n_Integer] := CirculantGraph[n,Range[k/2]]

Harary[k_?OddQ, n_?EvenQ] := CirculantGraph[n,Append[Range[k/2],n/2]]

Harary[k_?OddQ, n_?OddQ] :=
	Module[{g=Harary[k-1,n],i},
		FromUnorderedPairs[
			Join[
				ToUnorderedPairs[g],
				{ {1,(n+1)/2}, {1,(n+3)/2} },
				Table [ {i,i+(n+1)/2}, {i,2,(n-1)/2} ]
			],
			Vertices[g]
		]
	]
 
IdenticalQ[g_Graph,h_Graph] := Edges[g] === Edges[h]

IsomorphismQ[g_Graph,h_Graph,p_List] := False	/;
		(V[g]!=V[h]) || !PermutationQ[p] || (Length[p] != V[g])

IsomorphismQ[g_Graph,h_Graph,p_List] := IdenticalQ[g, InduceSubgraph[h,p] ]
 
Isomorphism[g_Graph,h_Graph,flag_:One] := {}	/; (V[g] != V[h]) 

Isomorphism[g_Graph,h_Graph,flag_:One] :=
	Module[{eg=Edges[g],eh=Edges[h],equiv=Equivalences[g,h]},
		If [!MemberQ[equiv,{}],
			Backtrack[
				equiv,
				(IdenticalQ[InduceSubgraph[g,Range[Length[#]]],
				    	InduceSubgraph[h,#] ] &&
			 	!MemberQ[Drop[#,-1],Last[#]])&,
				(IsomorphismQ[g,h,#])&,
				flag
			],
			{}
		]
	]

IsomorphicQ[g_Graph,h_Graph] := True /; IdenticalQ[g,h]
IsomorphicQ[g_Graph,h_Graph] := ! SameQ[ Isomorphism[g,h], {}]

Equivalences[g_Graph,h_Graph] :=
	Equivalences[ AllPairsShortestPath[g], AllPairsShortestPath[h]]

Equivalences[g_List,h_List] :=
	Module[{dg=Map[Sort,g],dh=Map[Sort,h],s,i},
		Table[
			Flatten[Position[dh,_?(Function[s,SameQ[s,dg[[i]] ]])]],
			{i,Length[dg]}
		]
	] /; Length[g] == Length[h]
 
Automorphisms[g_Graph,flag_:All] :=
	Module[{s=AllPairsShortestPath[g]},
		Backtrack[
			Equivalences[s,s],
			(IdenticalQ[InduceSubgraph[g,Range[Length[#]]],
				    InduceSubgraph[g,#] ] &&
			 !MemberQ[Drop[#,-1],Last[#]])&,
			(IsomorphismQ[g,g,#])&,
			flag
		]
	]
 
SelfComplementaryQ[g_Graph] := IsomorphicQ[g, GraphComplement[g]]
 
FindCycle[g_Graph,flag_:Undirected] :=
     Module[{edge,n=V[g],x,queue,v,seen,parent},
       edge=ToAdjacencyLists[g];
       For[ v = 1, v <= n, v++,
           parent=Table[n+1,{n}]; parent[[v]] = 0;
           seen = {}; queue = {v};
           While[ queue != {},
               {x,queue} = {First[queue], Rest[queue]};
               AppendTo[seen,x];
               If[ SameQ[ flag, Undirected],
                   Scan[ (If[ parent[[x]] != #, parent[[#]]=x])&, edge[[x]] ],
                   Scan[ (parent[[#]]=x)&, edge[[x]]]
               ];
               If[ SameQ[flag,Undirected],
                   If[ MemberQ[ edge[[x]],v ] && parent[[x]] != v,
                       Return[ FromParent[parent,x] ]
                   ],
                   If[ MemberQ[ edge[[x]],v ],
                       Return[ FromParent[parent,x] ]
                   ]
               ];
               queue = Join[ Complement[ edge[[x]], seen], queue]
           ]
       ];
     {}
     ]

FromParent[parent_List,s_Integer] :=
	Module[{i=s,lst={s}},
		While[!MemberQ[lst,(i=parent[[i]])], PrependTo[lst,i] ];
		PrependTo[lst,i];
		Take[lst, Flatten[Position[lst,i]]]
	]
 
AcyclicQ[g_Graph,flag_:Undirected] := SameQ[FindCycle[g,flag],{}]

TreeQ[g_Graph] := ConnectedQ[g] && (M[g] == V[g]-1)

ExtractCycles[gi_Graph,flag_:Undirected] := 
	Module[{g=gi,cycles={},c},
		While[!SameQ[{}, c=FindCycle[g,flag]],
			PrependTo[cycles,c];
			g = DeleteCycle[g,c,flag];
		];
		cycles
	]

DeleteCycle[g_Graph,cycle_List,flag_:Undirected] :=
	Module[{newg=g},
		Scan[(newg=DeleteEdge[newg,#,flag])&, Partition[cycle,2,1] ];
		newg
	]
 
Girth[g_Graph] := 
	Module[{v,dist,queue,n=V[g],girth=Infinity,parent,e=ToAdjacencyLists[g],x},
		Do [
			dist = parent = Table[Infinity, {n}];
			dist[[v]] = parent[[v]] = 0;
			queue = {v};
			While [queue != {},
				{x,queue} = {First[queue],Rest[queue]};
				Scan[
					(If [ (dist[[#]]+dist[[x]]<girth) &&
				     	      (parent[[x]] != #),
						girth=dist[[#]]+dist[[x]] + 1,
				 	 If [dist[[#]]==Infinity,
						dist[[#]] = dist[[x]] + 1;
						parent[[#]] = x;
						If [2 dist[[#]] < girth-1,
							AppendTo[queue,#] ]
					]])&,
					e[[ x ]]
				];
			],
			{v,n}
		];
		girth
	] /; SimpleQ[g]
 
EulerianQ[g_Graph,Directed] :=
	ConnectedQ[g,Undirected] && (InDegree[g] === OutDegree[g])

EulerianQ[g_Graph,flag_:Undirected] := ConnectedQ[g,Undirected] && 
	UndirectedQ[g] && Apply[And,Map[EvenQ,DegreeSequence[g]]]

OutDegree[Graph[e_List,_],n_Integer] := Length[ Select[ e[[n]], (# != 0)& ] ]
OutDegree[g_Graph] := Map[ (OutDegree[g,#])&, Range[V[g]] ]

InDegree[g_Graph,n_Integer] := OutDegree[ TransposeGraph[g], n ];
InDegree[g_Graph] := Map[ (InDegree[g,#])&, Range[V[g]] ]

TransposeGraph[Graph[g_List,v_List]] := Graph[ Transpose[g], v ]
 
EulerianCycle[g_Graph,flag_:Undirected] :=
	Module[{euler,c,cycles,v},
		cycles = Map[(Drop[#,-1])&, ExtractCycles[g,flag]];
		{euler, cycles} = {First[cycles], Rest[cycles]};
		Do [
			c = First[ Select[cycles, (Intersection[euler,#]=!={})&] ];
			v = First[Intersection[euler,c]];
			euler = Join[
				RotateLeft[c, Position[c,v] [[1,1]] ],
				RotateLeft[euler, Position[euler,v] [[1,1]] ]
			];
			cycles = Complement[cycles,{c}],
			{Length[cycles]}
		];
		Append[euler, First[euler]]
	] /; EulerianQ[g,flag]
 
DeBruijnSequence[alph_List,n_Integer] :=
        Module[{states = Strings[alph,n-1]},
                Rest[ Map[
                        (First[ states[[#]] ])&,
                        EulerianCycle[
                                MakeGraph[
                                        states,
                                        (Module[{i},
                                         MemberQ[
                                                Table[
                                                        Append[Rest[#1],alph[[i]]],
                                                        {i,Length[alph]}
                                                ],
                                                #2
                                         ]
                                        ])&
                                ],
                                Directed
                        ]
                ] ]
        ] /; n>=2

DeBruijnSequence[alph_List,n_Integer] := alph /; n==1
 
HamiltonianQ[g_Graph] := False /; !BiconnectedQ[g]
HamiltonianQ[g_Graph] := HamiltonianCycle[g] != {}

HamiltonianCycle[g_Graph,flag_:One] :=
	Module[{s={1},all={},done,adj=Edges[g],e=ToAdjacencyLists[g],x,v,ind,n=V[g]},
		ind=Table[1,{n}];
		While[ Length[s] > 0,
			v = Last[s];
			done = False;
			While[ ind[[v]] <= Length[e[[v]]] && !done,
				If[!MemberQ[s,(x = e[[v,ind[[v]]++]])], done=True]
			];
			If[ done, AppendTo[s,x], s=Drop[s,-1]; ind[[v]] = 1];
			If[(Length[s] == n),
				If [(adj[[x,1]]>0),
					AppendTo[all,Append[s,First[s]]];
					If [SameQ[flag,All],
						s=Drop[s,-1],
						all = Flatten[all]; s={}
					],
					s = Drop[s,-1]
				]
			]
		];
		all
	]
 
TravelingSalesman[g_Graph] :=
	Module[{v,s={1},sol={},done,cost,g1,e=ToAdjacencyLists[g],x,ind,best,n=V[g]},
		ind=Table[1,{n}];
		g1 = PathConditionGraph[g];
		best = Infinity;
		While[ Length[s] > 0,
			v = Last[s];
			done = False;
			While[ ind[[v]] <= Length[e[[v]]] && !done,
				x = e[[v,ind[[v]]++]];
				done = (best > CostOfPath[g1,Append[s,x]]) &&
					!MemberQ[s,x]
			];
			If[done, AppendTo[s,x], s=Drop[s,-1]; ind[[v]] = 1];
			If[(Length[s] == n),
				cost = CostOfPath[g1, Append[s,First[s]]];
				If [(cost < best), sol = s; best = cost ];
				s = Drop[s,-1]
			]
		];
		Append[sol,First[sol]]
	]

CostOfPath[Graph[g_,_],p_List] := Apply[Plus, Map[(Element[g,#])&,Partition[p,2,1]] ]

Element[a_List,{index___}] := a[[ index ]]
 
TriangleInequalityQ[e_?SquareMatrixQ] :=
	Module[{i,j,k,n=Length[e],flag=True},
		Do [

			If[(e[[i,k]]!=0) && (e[[k,j]]!=0) && (e[[i,j]]!=0),
				If[e[[i,k]]+e[[k,j]]<e[[i,j]],
					flag = False;
				]
			],
			{i,n},{j,n},{k,n}
		];
		flag
	]

TriangleInequalityQ[g_Graph] := TriangleInequalityQ[Edges[g]]
 
TravelingSalesmanBounds[g_Graph] := {LowerBoundTSP[g], UpperBoundTSP[g]}

UpperBoundTSP[g_Graph] :=
	CostOfPath[g, Append[DepthFirstTraversal[MinimumSpanningTree[g],1],1]]

LowerBoundTSP[g_Graph] := Apply[Plus, Map[Min,ReplaceAll[Edges[g],0->Infinity]]]
 
PartialOrderQ[g_Graph] := ReflexiveQ[g] && AntiSymmetricQ[g] && TransitiveQ[g]

TransitiveQ[g_Graph] := IdenticalQ[g,TransitiveClosure[g]]

ReflexiveQ[Graph[g_List,_]] := 
	Module[{i},
		Apply[And, Table[(g[[i,i]]!=0),{i,Length[g]}] ]
	]

AntiSymmetricQ[g_Graph] := 
	Module[{e = Edges[g], g1 = RemoveSelfLoops[g]},
		Apply[And, Map[(Element[e,Reverse[#]]==0)&,ToOrderedPairs[g1]] ]
	]
 
TransitiveClosure[g_Graph] :=
	Module[{i,j,k,e=Edges[g],n=V[g]},
		Do [
			If[ e[[j,i]] != 0,
				Do [
					If[ e[[i,k]] != 0, e[[j,k]]=1],
					{k,n}
				]
			],
			{i,n},{j,n}
		];
		Graph[e,Vertices[g]]
	]
 
TransitiveReduction[g_Graph] :=
	Module[{closure=reduction=Edges[g],i,j,k,n=V[g]},
		Do[
			If[ closure[[i,j]]!=0 && closure[[j,k]]!=0 &&
				 reduction[[i,k]]!=0 && (i!=j) && (j!=k) && (i!=k),
					reduction[[i,k]] = 0
			],
			{i,n},{j,n},{k,n}
		];
		Graph[reduction,Vertices[g]]
	] /; AcyclicQ[RemoveSelfLoops[g],Directed] 

TransitiveReduction[g_Graph] :=
	Module[{reduction=Edges[g],i,j,k,n=V[g]},
		Do[
			If[ reduction[[i,j]]!=0 && reduction[[j,k]]!=0 &&
				 reduction[[i,k]]!=0 && (i!=j) && (j!=k) && (i!=k),
					reduction[[i,k]] = 0
			],
			{i,n},{j,n},{k,n}
		];
		Graph[reduction,Vertices[g]]
	] 
 
HasseDiagram[g_Graph] :=
	Module[{r,rank,m,stages,freq=Table[0,{V[g]}]},
		r = TransitiveReduction[ RemoveSelfLoops[g] ];
		rank = RankGraph[
				MakeUndirected[r],
				Select[Range[V[g]],(InDegree[r,#]==0)&]
		];
		m = Max[rank];
		rank = MapAt[(m)&,rank,Position[OutDegree[r],0]];
		stages = Distribution[ rank ];
		Graph[
			Edges[r],
			Table[
				m = ++ freq[[ rank[[i]] ]];
				{(m-1) + (1-stages[[rank[[i]] ]])/2, rank[[i]]},
				{i,V[g]}
			]
		]
	] /; AcyclicQ[RemoveSelfLoops[g],Directed]
 
TopologicalSort[g_Graph] :=
	Module[{g1 = RemoveSelfLoops[g],e,indeg,zeros,v},
		e=ToAdjacencyLists[g1];
		indeg=InDegree[g1];
		zeros = Flatten[ Position[indeg, 0] ];
		Table [
			{v,zeros}={First[zeros],Rest[zeros]};
			Scan[
				( indeg[[#]]--;
				  If[indeg[[#]]==0, AppendTo[zeros,#]] )&,
				e[[ v ]]
			];
			v,
			{V[g]}
		]
	] /; AcyclicQ[RemoveSelfLoops[g],Directed]
 
ChromaticPolynomial[g_Graph,z_] := 0 /; Identical[g,K[0]]

ChromaticPolynomial[g_Graph,z_] :=
	Module[{i}, Product[z-i, {i,0,V[g]-1}] ] /; CompleteQ[g]

ChromaticPolynomial[g_Graph,z_] := z ( z - 1 ) ^ (V[g]-1) /; TreeQ[g]

ChromaticPolynomial[g_Graph,z_] :=
	If [M[g]>Binomial[V[g],2]/2, ChromaticDense[g,z], ChromaticSparse[g,z]]

ChromaticSparse[g_Graph,z_] := z^V[g] /; EmptyQ[g]
ChromaticSparse[g_Graph,z_] :=
	Module[{i=1, v, e=Edges[g], none=Table[0,{V[g]}]},
        	While[e[[i]] === none, i++];
        	v = Position[e[[i]],1] [[1,1]];
		ChromaticSparse[ DeleteEdge[g,{i,v}], z ] -
			ChromaticSparse[ Contract[g,{i,v}], z ]
	]

ChromaticDense[g_Graph,z_] := ChromaticPolynomial[g,z] /; CompleteQ[g]
ChromaticDense[g_Graph,z_] :=
	Module[
		{i=1, v, e=Edges[g], all=Join[Table[1,{V[g]-1}],{0}] },
		While[e[[i]] === RotateRight[all,i], i++];
		v = Last[ Position[e[[i]],0] ] [[1]];
		ChromaticDense[ AddEdge[g,{i,v}], z ] +
			ChromaticDense[ Contract[g,{i,v}], z ]
	]
 
ChromaticNumber[g_Graph] :=
	Block[{ways, z},
		ways[z_] = ChromaticPolynomial[g,z];
		For [z=0, z<=V[g], z++,
			If [ways[z] > 0, Return[z]]
		]
	]
 
TwoColoring[g_Graph] := 
	Module[{queue,elem,edges,col,flag=True,colored=Table[0,{V[g]}]},
		edges = ToAdjacencyLists[g];
		While[ MemberQ[colored,0],
			queue = First[ Position[colored,0] ];
			colored[[ First[queue] ]] = 1;
			While[ queue != {},
				elem = First[queue];
				col = colored[[elem]];
				Scan[
					(Switch[colored[[ # ]],
						col, flag = False,
						0, AppendTo[queue, # ];
						   colored[[#]] = Mod[col,2]+1
					])&,
					edges[[elem]]
				];
				queue = Rest[queue];
			]
		];
		If [!flag, colored[[1]] = 0];
		colored
	]

BipartiteQ[g_Graph] := ! MemberQ[ TwoColoring[g], 0 ]
 
VertexColoring[g_Graph] :=
	Module[{v,l,n=V[g],e=ToAdjacencyLists[g],x,color=Table[0,{V[g]}]},
		v = Map[(Apply[Plus,#])&, Edges[g]];
		Do[
			l = MaximumColorDegreeVertices[e,color];
			x = First[l];
			Scan[(If[ v[[#]] > v[[x]], x = #])&, l];
			color[[x]] = Min[
				Complement[ Range[n], color[[ e[[x]] ]] ]
			],
			{V[g]}
		];
		color
	]

MaximumColorDegreeVertices[e_List,color_List] :=
	Module[{n=Length[color],l,i,x},
		l = Table[ Count[e[[i]], _?(Function[x,color[[x]]!=0])], {i,n}];
		Do [ 
			If [color[[i]]!=0, l[[i]] = -1],
			{i,n}
		];
		Flatten[ Position[ l, Max[l] ] ]
	]
 
EdgeColoring[g_Graph] := VertexColoring[ LineGraph[g] ]

EdgeChromaticNumber[g_Graph] := ChromaticNumber[ LineGraph[g] ]
 
CliqueQ[g_Graph,clique_List] :=
	IdenticalQ[ K[Length[clique]], InduceSubgraph[g,clique] ] /; SimpleQ[g]

MaximumClique[g_Graph] := {} /; g === K[0]

MaximumClique[g_Graph] :=
	Module[{d = Degrees[g],i,clique=Null,k},
		i = Max[d];
		While[(SameQ[clique,Null]),
			k = K[i+1];
			clique = FirstExample[
				KSubsets[Flatten[Position[d,_?((#>=i)&)]], i+1],
				(IdenticalQ[k,InduceSubgraph[g,#]])&
			];
			i--;
		];
		clique
	]

FirstExample[list_List, predicate_] := Scan[(If [predicate[#],Return[#]])&,list]
 
VertexCoverQ[g_Graph,vc_List] :=
	CliqueQ[ GraphComplement[g], Complement[Range[V[g]], vc] ]

MinimumVertexCover[g_Graph] :=
	Complement[ Range[V[g]], MaximumClique[ GraphComplement[g] ] ]
 
IndependentSetQ[g_Graph,indep_List] :=
	VertexCoverQ[ g, Complement[ Range[V[g]], indep] ]

MaximumIndependentSet[g_Graph] := Complement[Range[V[g]], MinimumVertexCover[g]]
 
PerfectQ[g_Graph] :=
	Apply[
		And,
		Map[(ChromaticNumber[#] == Length[MaximumClique[#]])&,
			Map[(InduceSubgraph[g,#])&, Subsets[Range[V[g]]] ] ]
	]
 
Dijkstra[g_Graph,start_Integer] := First[ Dijkstra[g,{start}] ]

Dijkstra[g_Graph, l_List] :=
	Module[{x,start,e=ToAdjacencyLists[g],i,p,parent,untraversed},
		p=Edges[PathConditionGraph[g]];
		Table[
			start = l[[i]];
			parent=untraversed=Range[V[g]];
			dist = p[[start]]; dist[[start]] = 0;
			Scan[ (parent[[#]] = start)&, e[[start]] ];
			While[ untraversed != {} ,
				x = First[untraversed];
				Scan[(If [dist[[#]]<dist[[x]],x=#])&, untraversed];
				untraversed = Complement[untraversed,{x}];
				Scan[
					(If[dist[[#]] > dist[[x]]+p[[x,#]],
						dist[[#]] = dist[[x]]+p[[x,#]];
						parent[[#]] = x ])&,
					e[[x]]
				];
			];
			{parent, dist},
			{i,Length[l]}
		]
	]

ShortestPath[g_Graph,s_Integer,e_Integer] := 
	Module[{parent=First[Dijkstra[g,s]],i=e,lst={e}},
		While[ (i != s) && (i != parent[[i]]),
			PrependTo[lst,parent[[i]]];
			i = parent[[i]]
		];
		If[ i == s, lst, {}]
	]

ShortestPathSpanningTree[g_Graph,s_Integer] :=
	Module[{parent=First[Dijkstra[g,s]],i},
		FromUnorderedPairs[
			Map[({#,parent[[#]]})&, Complement[Range[V[g]],{s}]],
			Vertices[g]
		]
	]
 
AllPairsShortestPath[g_Graph] :=
	Module[{p=Edges[ PathConditionGraph[g] ],i,j,k,n=V[g]},
		Do [
			p = Table[Min[p[[i,k]]+p[[k,j]],p[[i,j]]],{i,n},{j,n}],
			{k,n}
		];
		p
	] /; Min[Edges[g]] < 0

AllPairsShortestPath[g_Graph] := Map[ Last, Dijkstra[g, Range[V[g]]]]

PathConditionGraph[Graph[e_,v_]] := RemoveSelfLoops[Graph[ReplaceAll[e,0->Infinity],v]]
 
GraphPower[g_Graph,1] := g

GraphPower[g_Graph,n_Integer] :=
	Module[{prod=power=p=Edges[g]},
		Do [
			prod = prod . p;
			power = prod + power,
			{n-1}
		];
		Graph[power, Vertices[g]]
	]
 
InitializeUnionFind[n_Integer] := Module[{i}, Table[{i,1},{i,n}] ]

FindSet[n_Integer,s_List] := If [n == s[[n,1]], n, FindSet[s[[n,1]],s] ]

UnionSet[a_Integer,b_Integer,s_List] :=
	Module[{sa=FindSet[a,s], sb=FindSet[b,s], set=s},
		If[ set[[sa,2]] < set[[sb,2]], {sa,sb} = {sb,sa} ];
		set[[sa]] = {sa, Max[ set[[sa,2]], set[[sb,2]]+1 ]};
		set[[sb]] = {sa, set[[sb,2]]};
		set
	]
 
MinimumSpanningTree[g_Graph] :=
	Module[{edges=Edges[g],set=InitializeUnionFind[V[g]]},
		FromUnorderedPairs[
			Select [
				Sort[
					ToUnorderedPairs[g],
					(Element[edges,#1]<=Element[edges,#2])&
				],
				(If [FindSet[#[[1]],set] != FindSet[#[[2]],set],
					set=UnionSet[#[[1]],#[[2]],set]; True,
					False
				])&
			],
			Vertices[g]
		]
	] /; UndirectedQ[g]

MaximumSpanningTree[g_Graph] := MinimumSpanningTree[Graph[-Edges[g],Vertices[g]]]
 
Cofactor[m_List,{i_Integer,j_Integer}] :=
	(-1)^(i+j) * Det[ Drop[ Transpose[ Drop[Transpose[m],{j,j}] ], {i,i}] ]
 
NumberOfSpanningTrees[Graph[g_List,_]] :=
	Cofactor[ DiagonalMatrix[Map[(Apply[Plus,#])&,g]] - g, {1,1}]
 
NetworkFlow[g_Graph,source_Integer,sink_Integer] :=
	Block[{flow=NetworkFlowEdges[g,source,sink], i},
		Sum[flow[[i,sink]], {i,V[g]}]
	]


NetworkFlowEdges[g_Graph,source_Integer,sink_Integer] :=
	Block[{e=Edges[g], x, y, flow=Table[0,{V[g]},{V[g]}], p, m},
		While[ !SameQ[p=AugmentingPath[g,source,sink], {}],
			m = Min[Map[({x,y}=#[[1]]; 
				 If[SameQ[#[[2]],f],e[[x,y]]-flow[[x,y]],
					flow[[x,y]]])&,p]];
			Scan[	
				({x,y}=#[[1]];
				 If[ SameQ[#[[2]],f],
					flow[[x,y]]+=m,flow[[x,y]]-=m])&,
				 p
			]
		];
		flow
	]

AugmentingPath[g_Graph,src_Integer,sink_Integer] :=
	Block[{l={src},lab=Table[0,{V[g]}],v,c=Edges[g],e=ToAdjacencyLists[g]},
		lab[[src]] = start;
		While[l != {} && (lab[[sink]]==0),
			{v,l} = {First[l],Rest[l]};
			Scan[ (If[ c[[v,#]] - flow[[v,#]] > 0 && lab[[#]] == 0,
				lab[[#]] = {v,f}; AppendTo[l,#]])&,
				e[[v]]
			];
			Scan[ (If[ flow[[#,v]] > 0 && lab[[#]] == 0,
				lab[[#]] = {v,b}; AppendTo[l,#]] )&,
				Select[Range[V[g]],(c[[#,v]] > 0)&]
			];
		];
		FindPath[lab,src,sink]
	]

FindPath[l_List,v1_Integer,v2_Integer] :=
	Block[{x=l[[v2]],y,z=v2,lst={}},
		If[SameQ[x,0], Return[{}]];
		While[!SameQ[x, start],
			If[ SameQ[x[[2]],f],
				PrependTo[lst,{{ x[[1]], z }, f}],
				PrependTo[lst,{{ z, x[[1]] }, b}]
			];
			z = x[[1]]; x = l[[z]];
		];
		lst
	]
 
BipartiteMatching[g_Graph] :=
	Module[{p,v1,v2,coloring=TwoColoring[g],n=V[g]},
		v1 = Flatten[Position[coloring,1]];
		v2 = Flatten[Position[coloring,2]];
		p = BipartiteMatchingFlowGraph[g,v1,v2];
		flow = NetworkFlowEdges[p,V[g]+1,V[g]+2];
		Select[ToOrderedPairs[Graph[flow,Vertices[p]]], (Max[#]<=n)&]
	] /; BipartiteQ[g]

BipartiteMatchingFlowGraph[g_Graph,v1_List,v2_List] :=
	Module[{edges = Table[0,{V[g]+2},{V[g]+2}],i,e=ToAdjacencyLists[g]},
		Do[ 
	    		Scan[ (edges[[v1[[i]],#]] = 1)&, e[[ v1[[i]] ]] ],
			{i,Length[v1]}
		];
		Scan[(edges[[V[g] + 1, #]] = 1)&, v1];
		Scan[(edges[[#, V[g] + 2]] = 1)&, v2];
		Graph[edges,RandomVertices[V[g] + 2] ]
	]
 
MinimumChainPartition[g_Graph] :=
	ConnectedComponents[
		FromUnorderedPairs[
			Map[(#-{0,V[g]})&, BipartiteMatching[DilworthGraph[g]]],
			Vertices[g]
		]
	]

MaximumAntichain[g_Graph] := MaximumIndependentSet[TransitiveClosure[g]]

DilworthGraph[g_Graph] :=
	FromUnorderedPairs[
		Map[
			(#+{0,V[g]})&,
			ToOrderedPairs[RemoveSelfLoops[TransitiveReduction[g]]]
		]
	]
 
MaximalMatching[g_Graph] :=
	Module[{match={}},
		Scan[
			(If [Intersection[#,match]=={}, match=Join[match,#]])&,
			ToUnorderedPairs[g]
		];
		Partition[match,2]
	]
 
StableMarriage[mpref_List,fpref_List] :=
	Module[{n=Length[mpref],freemen,cur,i,w,husband},
		freemen = Range[n];
		cur = Table[1,{n}];
		husband = Table[n+1,{n}];
		While[ freemen != {},
			{i,freemen}={First[freemen],Rest[freemen]};
			w = mpref[[ i,cur[[i]] ]];
			If[BeforeQ[ fpref[[w]], i, husband[[w]] ], 
				If[husband[[w]] != n+1,
					AppendTo[freemen,husband[[w]] ]
				];
				husband[[w]] = i,
				cur[[i]]++;
				AppendTo[freemen,i]
			];
		];
		InversePermutation[ husband ]
	] /; Length[mpref] == Length[fpref]

BeforeQ[l_List,a_,b_] :=
	If [First[l]==a, True, If [First[l]==b, False, BeforeQ[Rest[l],a,b] ] ]
 
PlanarQ[g_Graph] :=
	Apply[
		And,
		Map[(PlanarQ[InduceSubgraph[g,#]])&, ConnectedComponents[g]]
	] /; !ConnectedQ[g]

PlanarQ[g_Graph] := False /;  (M[g] > 3 V[g]-6) && (V[g] > 2)
PlanarQ[g_Graph] := True /;   (M[g] < V[g] + 3)
PlanarQ[g_Graph] := PlanarGivenCycle[ g, Rest[FindCycle[g]] ]

PlanarGivenCycle[g_Graph, cycle_List] :=
	Module[{b, j, i},
		{b, j} = FindBridge[g, cycle];
		If[ InterlockQ[j, cycle],
			False,
			Apply[And, Table[SingleBridgeQ[b[[i]],j[[i]]], {i,Length[b]}]]
		]
	]

SingleBridgeQ[b_Graph, {_}] := PlanarQ[b]

SingleBridgeQ[b_Graph, j_List] :=
	PlanarGivenCycle[ JoinCycle[b,j],
		Join[ ShortestPath[b,j[[1]],j[[2]]], Drop[j,2]] ]

JoinCycle[g1_Graph, cycle_List] :=
	Module[{g=g1},
		Scan[(g = AddEdge[g,#])&, Partition[cycle,2,1] ];
		AddEdge[g,{First[cycle],Last[cycle]}]
	]
 
FindBridge[g_Graph, cycle_List] :=
    Module[{rg = RemoveCycleEdges[g, cycle], b, bridge, j},
	b = Map[
		(IsolateSubgraph[rg,g,cycle,#])&,
		Select[ConnectedComponents[rg], (Intersection[#,cycle]=={})&]
	];
	b = Select[b, (!EmptyQ[#])&];
	j = Join[
		Map[Function[bridge,Select[cycle, MemberQ[Edges[bridge][[#]],1]&] ], b],
		Complement[
			Select[ToOrderedPairs[g],
				(Length[Intersection[#,cycle]] == 2)&],
			Partition[Append[cycle,First[cycle]],2,1]
		]
	];
	{b, j}
    ]

RemoveCycleEdges[g_Graph, c_List] :=
	FromOrderedPairs[
		Select[ ToOrderedPairs[g], (Intersection[c,#] === {})&],
		Vertices[g]
	]

IsolateSubgraph[g_Graph,orig_Graph,cycle_List,cc_List] :=
	Module[{eg=ToOrderedPairs[g], og=ToOrderedPairs[orig]},
		FromOrderedPairs[
			Join[
				Select[eg, (Length[Intersection[cc,#]] == 2)&],
				Select[og, (Intersection[#,cycle]!={} &&
					Intersection[#,cc]!={})&]
			],
			Vertices[g]
		]
	]
 
InterlockQ[ bl_List, c_List ] :=
	Module[{in = out = {}, code, jp, bridgelist = bl },
		While [ bridgelist != {},
			{jp, bridgelist} = {First[bridgelist],Rest[bridgelist]};
			code = Sort[ Map[(Position[c, #][[1,1]])&, jp] ];
			If[ Apply[ Or, Map[(LockQ[#,code])&, in] ],
				If [ Apply[Or, Map[(LockQ[#,code])&, out] ],
					Return[True],
					AppendTo[out,code]
				],
				AppendTo[in,code]
			]
		];
		False
	]

LockQ[a_List,b_List] := Lock1Q[a,b] || Lock1Q[b,a]

Lock1Q[a_List,b_List] :=
	Module[{bk, aj},
		bk = Min[ Select[Drop[b,-1], (#>First[a])&] ];
		aj = Min[ Select[a, (# > bk)&] ];
		(aj < Max[b])
	]
 
End[]

Protect[
AcyclicQ,
AddEdge,
AddVertex,
AllPairsShortestPath,
ArticulationVertices,
Automorphisms,
Backtrack,
BiconnectedComponents,
BiconnectedComponents,
BiconnectedQ,
BinarySearch,
BinarySubsets,
BipartiteMatching,
BipartiteQ,
BreadthFirstTraversal,
Bridges,
CartesianProduct,
CatalanNumber,
ChangeEdges,
ChangeVertices,
ChromaticNumber,
ChromaticPolynomial,
CirculantGraph,
CircularVertices,
CliqueQ,
CodeToLabeledTree,
Cofactor,
CompleteQ,
Compositions,
ConnectedComponents,
ConnectedQ,
ConstructTableau,
Contract,
CostOfPath,
Cycle,
DeBruijnSequence,
DegreeSequence,
DeleteCycle,
DeleteEdge,
DeleteFromTableau,
DeleteVertex,
DepthFirstTraversal,
DerangementQ,
Derangements,
Diameter,
Dijkstra,
DilateVertices,
DistinctPermutations,
Distribution,
DurfeeSquare,
Eccentricity,
EdgeChromaticNumber,
EdgeColoring,
EdgeConnectivity,
Edges,
Element,
EmptyGraph,
EmptyQ,
EncroachingListSet,
EquivalenceClasses,
EquivalenceRelationQ,
Equivalences,
EulerianCycle,
EulerianQ,
Eulerian,
ExactRandomGraph,
ExpandGraph,
ExtractCycles,
FerrersDiagram,
FindCycle,
FindSet,
FirstLexicographicTableau,
FromAdjacencyLists,
FromCycles,
FromInversionVector,
FromOrderedPairs,
FromUnorderedPairs,
FromOrderedTriples,
FromUnorderedTriples,
FunctionalGraph,
Girth,
GraphCenter,
GraphComplement,
GraphDifference,
GraphIntersection,
GraphJoin,
GraphPower,
GraphProduct,
GraphSum,
GraphUnion,
GraphicQ,
GrayCode,
GridGraph,
HamiltonianCycle,
HamiltonianQ,
Harary,
HasseDiagram,
HeapSort,
Heapify,
HideCycles,
Hypercube,
IdenticalQ,
IncidenceMatrix,
IndependentSetQ,
Index,
InduceSubgraph,
InitializeUnionFind,
InsertIntoTableau,
IntervalGraph,
InversePermutation,
Inversions,
InvolutionQ,
IsomorphicQ,
IsomorphismQ,
Isomorphism,
Josephus,
KSubsets,
K,
LabeledTreeToCode,
LastLexicographicTableau,
LexicographicPermutations,
LexicographicSubsets,
LineGraph,
LongestIncreasingSubsequence,
M,
MakeGraph,
MakeSimple,
MakeUndirected,
MaximalMatching,
MaximumAntichain,
MaximumClique,
MaximumIndependentSet,
MaximumSpanningTree,
MinimumChainPartition,
MinimumChangePermutations,
MinimumSpanningTree,
MinimumVertexCover,
MultiplicationTable,
NetworkFlowEdges,
NetworkFlow,
NextComposition,
NextKSubset,
NextPartition,
NextPermutation,
NextSubset,
NextTableau,
NormalizeVertices,
NthPair,
NthPermutation,
NthSubset,
NumberOfCompositions,
NumberOfDerangements,
NumberOfInvolutions,
NumberOfPartitions,
NumberOfPermutationsByCycles,
NumberOfSpanningTrees,
NumberOfTableaux,
OrientGraph,
PartialOrderQ,
PartitionQ,
Partitions,
PathConditionGraph,
Path,
PerfectQ,
PermutationGroupQ,
PermutationQ,
Permute,
PlanarQ,
PointsAndLines,
Polya,
PseudographQ,
RadialEmbedding,
Radius,
RandomComposition,
RandomGraph,
RandomHeap,
RandomKSubset,
RandomPartition,
RandomPermutation1,
RandomPermutation2,
RandomPermutation,
RandomSubset,
RandomTableau,
RandomTree,
RandomVertices,
RankGraph,
RankPermutation,
RankSubset,
RankedEmbedding,
ReadGraph,
RealizeDegreeSequence,
RegularGraph,
RegularQ,
RemoveSelfLoops,
RevealCycles,
RootedEmbedding,
RotateVertices,
Runs,
SamenessRelation,
SelectionSort,
SelfComplementaryQ,
ShakeGraph,
ShortestPathSpanningTree,
ShortestPath,
ShowGraph,
ShowLabeledGraph,
ShowWeightedGraph,
ShowWeightedLabeledGraph,
SignaturePermutation,
SimpleQ,
Spectrum,
SpringEmbedding,
SpringEmbeddingDirected,
StableMarriage,
Star,
StirlingFirst,
StirlingSecond,
Strings,
StronglyConnectedComponents,
Subsets,
TableauClasses,
TableauQ,
TableauxToPermutation,
Tableaux,
ToAdjacencyLists,
ToCycles,
ToInversionVector,
ToOrderedPairs,
ToUnorderedPairs,
ToOrderedTriples,
TopologicalSort,
TransitiveClosure,
TransitiveQ,
TransitiveReduction,
TranslateVertices,
TransposePartition,
TransposeTableau,
TravelingSalesmanBounds,
TravelingSalesman,
TreeQ,
TriangleInequalityQ,
Turan,
TwoColoring,
UndirectedQ,
UnionSet,
UnweightedQ,
V,
VertexColoring,
VertexConnectivity,
VertexCoverQ,
Vertices,
WeaklyConnectedComponents,
Wheel,
WriteGraph,
DilworthGraph ]

EndPackage[ ]