#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of archive 2 (of 3)."
# Contents:  part3
# Wrapped by skiena@sbskiena on Tue Jul 16 13:47:18 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f part3 -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"part3\"
else
echo shar: Extracting \"part3\" \(29647 characters\)
sed "s/^X//" >part3 <<'END_OF_part3'
XMakeGraph[v_List,f_] :=
X	Block[{n=Length[v],i,j},
X		Graph [
X			Table[If [Apply[f,{v[[i]],v[[j]]}], 1, 0],{i,n},{j,n}],
X			CircularVertices[n]
X		]
X	]
X 
XIntervalGraph[l_List] :=
X	MakeGraph[
X		l,
X		( ((First[#1] <= First[#2]) && (Last[#1] >= First[#2])) ||
X		  ((First[#2] <= First[#1]) && (Last[#2] >= First[#1])) )&
X	]
X 
XFunctionalGraph[f_,n_] :=
X	Block[{i,x},
X		FromOrderedPairs[
X			Table[{i, x=Mod[Apply[f,{i}],n]; If[x!=0,x,n]}, {i,n} ],
X			CircularVertices[n]
X		]
X	]
X 
XConnectedComponents[g_Graph] :=
X	Block[{untraversed=Range[V[g]],traversed,comps={}},
X		While[untraversed != {},
X			traversed = DepthFirstTraversal[g,First[untraversed]];
X			AppendTo[comps,traversed];
X			untraversed = Complement[untraversed,traversed]
X		];
X		comps
X	]
X
XConnectedQ[g_Graph] := Length[ DepthFirstTraversal[g,1] ] == V[g]
X 
XWeaklyConnectedComponents[g_Graph] := ConnectedComponents[ MakeUndirected[g] ]
X
XConnectedQ[g_Graph,Undirected] := Length[ WeaklyConnectedComponents[g] ] == 1
X 
XStronglyConnectedComponents[g_Graph] :=
X	Block[{e=ToAdjacencyLists[g],s,c=1,i,cur={},low=dfs=Table[0,{V[g]}],scc={}},
X		While[(s=Select[Range[V[g]],(dfs[[#]]==0)&]) != {},
X			SearchStrongComp[First[s]];
X		];
X		scc
X	]
X
XSearchStrongComp[v_Integer] :=
X	Block[{r},
X		low[[v]]=dfs[[v]]=c++;
X		PrependTo[cur,v];
X		Scan[
X			(If[dfs[[#]] == 0,
X				SearchStrongComp[#];
X				low[[v]]=Min[low[[v]],low[[#]]],
X				If[(dfs[[#]] < dfs[[v]]) && MemberQ[cur,#],
X					low[[v]]=Min[low[[v]],dfs[[#]] ]
X				];
X			])&,
X			e[[v]]
X		];
X		If[low[[v]] == dfs[[v]],
X			{r} = Flatten[Position[cur,v]];
X			AppendTo[scc,Take[cur,r]];
X			cur = Drop[cur,r];
X		];
X	]
X
XConnectedQ[g_Graph,Directed] := Length[ StronglyConnectedComponents[g] ] == 1
X 
XOrientGraph[g_Graph] :=
X	Block[{pairs,newg,rest,cc,c,i,e},
X		pairs = Flatten[Map[(Partition[#,2,1])&,ExtractCycles[g]],1];
X		newg = FromUnorderedPairs[pairs,Vertices[g]];
X		rest = ToOrderedPairs[ GraphDifference[ g, newg ] ];
X		cc = Sort[ConnectedComponents[newg], (Length[#1]>=Length[#2])&];
X		c = First[cc];
X		Do[
X			e = Select[rest,(MemberQ[c,#[[1]]] &&
X					 MemberQ[cc[[i]],#[[2]]])&];
X			rest = Complement[rest,e,Map[Reverse,e]];
X			c = Union[c,cc[[i]]];
X			pairs = Join[pairs, Prepend[ Rest[e],Reverse[e[[1]]] ] ],
X			{i,2,Length[cc]}
X		];
X		FromOrderedPairs[
X			Join[pairs, Select[rest,(#[[1]] > #[[2]])&] ],
X			Vertices[g]
X		]
X	] /; SameQ[Bridges[g],{}]
X 
XFindBiconnectedComponents[g_Graph] :=
X	Block[{e=ToAdjacencyLists[g],n=V[g],par,c=0,act={},back,dfs,ap=bcc={}},
X		back=dfs=Table[0,{n}];
X		par = Table[n+1,{n}]; 
X		Map[(SearchBiConComp[First[#]])&, ConnectedComponents[g]];
X		{bcc,Drop[ap, -1]}
X	]
X
XSearchBiConComp[v_Integer] :=
X	Block[{r},
X		back[[v]]=dfs[[v]]=++c;
X		Scan[
X			(If[ dfs[[#]] == 0, 
X				If[!MemberQ[act,{v,#}], PrependTo[act,{v,#}]];
X				par[[#]] = v;
X				SearchBiConComp[#];
X				If[ back[[#]] >= dfs[[v]],
X					{r} = Flatten[Position[act,{v,#}]];
X					AppendTo[bcc,Union[Flatten[Take[act,r]]]];
X					AppendTo[ap,v];
X					act = Drop[act,r]
X				];
X				back[[v]] = Min[ back[[v]],back[[#]] ],
X				If[# != par[[v]],back[[v]]=Min[dfs[[#]],back[[v]]]]
X			])&,
X			e[[v]]
X		];
X	]
X 
XArticulationVertices[g_Graph]  := Union[Last[FindBiconnectedComponents[g]]];
X
XBridges[g_Graph] := Select[BiconnectedComponents[g],(Length[#] == 2)&]
X
XBiconnectedComponents[g_Graph] := First[FindBiconnectedComponents[g]];
X
XBiconnectedQ[g_Graph] := Length[ BiconnectedComponents[g] ] == 1
X 
XEdgeConnectivity[g_Graph] :=
X	Block[{i},
X		Apply[Min, Table[NetworkFlow[g,1,i], {i,2,V[g]}]]
X	]
X 
XVertexConnectivityGraph[g_Graph] :=
X	Block[{n=V[g],e},
X		e=Table[0,{2 n},{2 n}];
X		Scan[ (e[[#-1,#]] = 1)&, 2 Range[n] ];
X		Scan[
X			(e[[#[[1]], #[[2]]-1]] = e[[#[[2]],#[[1]]-1]] = Infinity)&,
X			2 ToUnorderedPairs[g]
X		];
X		Graph[e,Apply[Join,Map[({#,#})&,Vertices[g]]]]
X	]
X
XVertexConnectivity[g_Graph] :=
X	Block[{p=VertexConnectivityGraph[g],k=V[g],i=0,notedges},
X		notedges = ToUnorderedPairs[ GraphComplement[g] ];
X		While[ i++ <= k,
X			k = Min[
X				Map[
X					(NetworkFlow[p,2 #[[1]],2 #[[2]]-1])&,
X					Select[notedges,(First[#]==i)&]
X				],
X				k
X			]
X		];
X		k
X	]
X 
XHarary[k_?EvenQ, n_Integer] := CirculantGraph[n,Range[k/2]]
X
XHarary[k_?OddQ, n_?EvenQ] := CirculantGraph[n,Append[Range[k/2],n/2]]
X
XHarary[k_?OddQ, n_?OddQ] :=
X	Block[{g=Harary[k-1,n],i},
X		FromUnorderedPairs[
X			Join[
X				ToUnorderedPairs[g],
X				{ {1,(n+1)/2}, {1,(n+3)/2} },
X				Table [ {i,i+(n+1)/2}, {i,2,(n-1)/2} ]
X			],
X			Vertices[g]
X		]
X	]
X 
XIdenticalQ[g_Graph,h_Graph] := Edges[g] === Edges[h]
X
XIsomorphismQ[g_Graph,h_Graph,p_List] := False	/;
X		(V[g]!=V[h]) || !PermutationQ[p] || (Length[p] != V[g])
X
XIsomorphismQ[g_Graph,h_Graph,p_List] := IdenticalQ[g, InduceSubgraph[h,p] ]
X 
XIsomorphism[g_Graph,h_Graph,flag_:One] := {}	/; (V[g] != V[h]) 
X
XIsomorphism[g_Graph,h_Graph,flag_:One] :=
X	Block[{eg=Edges[g],eh=Edges[h],equiv=Equivalences[g,h]},
X		If [!MemberQ[equiv,{}],
X			Backtrack[
X				equiv,
X				(IdenticalQ[InduceSubgraph[g,Range[Length[#]]],
X				    	InduceSubgraph[h,#] ] &&
X			 	!MemberQ[Drop[#,-1],Last[#]])&,
X				(IsomorphismQ[g,h,#])&,
X				flag
X			],
X			{}
X		]
X	]
X
XIsomorphicQ[g_Graph,h_Graph] := True /; IdenticalQ[g,h]
XIsomorphicQ[g_Graph,h_Graph] := ! SameQ[ Isomorphism[g,h], {}]
X
XEquivalences[g_Graph,h_Graph] :=
X	Equivalences[ AllPairsShortestPath[g], AllPairsShortestPath[h]]
X
XEquivalences[g_List,h_List] :=
X	Block[{dg=Map[Sort,g],dh=Map[Sort,h],s,i},
X		Table[
X			Flatten[Position[dh,_?(Function[s,SameQ[s,dg[[i]] ]])]],
X			{i,Length[dg]}
X		]
X	] /; Length[g] == Length[h]
X 
XAutomorphisms[g_Graph,flag_:All] :=
X	Block[{s=AllPairsShortestPath[g]},
X		Backtrack[
X			Equivalences[s,s],
X			(IdenticalQ[InduceSubgraph[g,Range[Length[#]]],
X				    InduceSubgraph[g,#] ] &&
X			 !MemberQ[Drop[#,-1],Last[#]])&,
X			(IsomorphismQ[g,g,#])&,
X			flag
X		]
X	]
X 
XSelfComplementaryQ[g_Graph] := IsomorphicQ[g, GraphComplement[g]]
X 
XFindCycle[g_Graph,flag_:Undirected] :=
X     Block[{edge,n=V[g],x,queue,v,seen,parent},
X       edge=ToAdjacencyLists[g];
X       For[ v = 1, v <= n, v++,
X           parent=Table[n+1,{n}]; parent[[v]] = 0;
X           seen = {}; queue = {v};
X           While[ queue != {},
X               {x,queue} = {First[queue], Rest[queue]};
X               AppendTo[seen,x];
X               If[ SameQ[ flag, Undirected],
X                   Scan[ (If[ parent[[x]] != #, parent[[#]]=x])&, edge[[x]] ],
X                   Scan[ (parent[[#]]=x)&, edge[[x]]]
X               ];
X               If[ SameQ[flag,Undirected],
X                   If[ MemberQ[ edge[[x]],v ] && parent[[x]] != v,
X                       Return[ FromParent[parent,x] ]
X                   ],
X                   If[ MemberQ[ edge[[x]],v ],
X                       Return[ FromParent[parent,x] ]
X                   ]
X               ];
X               queue = Join[ Complement[ edge[[x]], seen], queue]
X           ]
X       ];
X     {}
X     ]
X
XFromParent[parent_List,s_Integer] :=
X	Block[{i=s,lst={s}},
X		While[!MemberQ[lst,(i=parent[[i]])], PrependTo[lst,i] ];
X		PrependTo[lst,i];
X		Take[lst, Flatten[Position[lst,i]]]
X	]
X 
XAcyclicQ[g_Graph,flag_:Undirected] := SameQ[FindCycle[g,flag],{}]
X
XTreeQ[g_Graph] := ConnectedQ[g] && (M[g] == V[g]-1)
X
XExtractCycles[gi_Graph,flag_:Undirected] := 
X	Block[{g=gi,cycles={},c},
X		While[!SameQ[{}, c=FindCycle[g,flag]],
X			PrependTo[cycles,c];
X			g = DeleteCycle[g,c,flag];
X		];
X		cycles
X	]
X
XDeleteCycle[g_Graph,cycle_List,flag_:Undirected] :=
X	Block[{newg=g},
X		Scan[(newg=DeleteEdge[newg,#,flag])&, Partition[cycle,2,1] ];
X		newg
X	]
X 
XGirth[g_Graph] := 
X	Block[{v,dist,queue,n=V[g],girth=Infinity,parent,e=ToAdjacencyLists[g],x},
X		Do [
X			dist = parent = Table[Infinity, {n}];
X			dist[[v]] = parent[[v]] = 0;
X			queue = {v};
X			While [queue != {},
X				{x,queue} = {First[queue],Rest[queue]};
X				Scan[
X					(If [ (dist[[#]]+dist[[x]]<girth) &&
X				     	      (parent[[x]] != #),
X						girth=dist[[#]]+dist[[x]] + 1,
X				 	 If [dist[[#]]==Infinity,
X						dist[[#]] = dist[[x]] + 1;
X						parent[[#]] = x;
X						If [2 dist[[#]] < girth-1,
X							AppendTo[queue,#] ]
X					]])&,
X					e[[ x ]]
X				];
X			],
X			{v,n}
X		];
X		girth
X	] /; SimpleQ[g]
X 
XEulerianQ[g_Graph,Directed] :=
X	ConnectedQ[g,Undirected] && (InDegree[g] === OutDegree[g])
X
XEulerianQ[g_Graph,flag_:Undirected] := ConnectedQ[g,Undirected] && 
X	UndirectedQ[g] && Apply[And,Map[EvenQ,DegreeSequence[g]]]
X
XOutDegree[Graph[e_List,_],n_Integer] := Length[ Select[ e[[n]], (# != 0)& ] ]
XOutDegree[g_Graph] := Map[ (OutDegree[g,#])&, Range[V[g]] ]
X
XInDegree[g_Graph,n_Integer] := OutDegree[ TransposeGraph[g], n ];
XInDegree[g_Graph] := Map[ (InDegree[g,#])&, Range[V[g]] ]
X
XTransposeGraph[Graph[g_List,v_List]] := Graph[ Transpose[g], v ]
X 
XEulerianCycle[g_Graph,flag_:Undirected] :=
X	Block[{euler,c,cycles,v},
X		cycles = Map[(Drop[#,-1])&, ExtractCycles[g,flag]];
X		{euler, cycles} = {First[cycles], Rest[cycles]};
X		Do [
X			c = First[ Select[cycles, (Intersection[euler,#]=!={})&] ];
X			v = First[Intersection[euler,c]];
X			euler = Join[
X				RotateLeft[c, Position[c,v] [[1,1]] ],
X				RotateLeft[euler, Position[euler,v] [[1,1]] ]
X			];
X			cycles = Complement[cycles,{c}],
X			{Length[cycles]}
X		];
X		Append[euler, First[euler]]
X	] /; EulerianQ[g,flag]
X 
XDeBruijnSequence[alph_List,n_Integer] :=
X        Block[{states = Strings[alph,n-1]},
X                Rest[ Map[
X                        (First[ states[[#]] ])&,
X                        EulerianCycle[
X                                MakeGraph[
X                                        states,
X                                        (Block[{i},
X                                         MemberQ[
X                                                Table[
X                                                        Append[Rest[#1],alph[[i]]],
X                                                        {i,Length[alph]}
X                                                ],
X                                                #2
X                                         ]
X                                        ])&
X                                ],
X                                Directed
X                        ]
X                ] ]
X        ] /; n>=2
X
XDeBruijnSequence[alph_List,n_Integer] := alph /; n==1
X 
XHamiltonianQ[g_Graph] := False /; !BiconnectedQ[g]
XHamiltonianQ[g_Graph] := HamiltonianCycle[g] != {}
X
XHamiltonianCycle[g_Graph,flag_:One] :=
X	Block[{s={1},all={},done,adj=Edges[g],e=ToAdjacencyLists[g],x,v,ind,n=V[g]},
X		ind=Table[1,{n}];
X		While[ Length[s] > 0,
X			v = Last[s];
X			done = False;
X			While[ ind[[v]] <= Length[e[[v]]] && !done,
X				If[!MemberQ[s,(x = e[[v,ind[[v]]++]])], done=True]
X			];
X			If[ done, AppendTo[s,x], s=Drop[s,-1]; ind[[v]] = 1];
X			If[(Length[s] == n),
X				If [(adj[[x,1]]>0),
X					AppendTo[all,Append[s,First[s]]];
X					If [SameQ[flag,All],
X						s=Drop[s,-1],
X						all = Flatten[all]; s={}
X					],
X					s = Drop[s,-1]
X				]
X			]
X		];
X		all
X	]
X 
XTravelingSalesman[g_Graph] :=
X	Block[{v,s={1},sol={},done,cost,g1,e=ToAdjacencyLists[g],x,ind,best,n=V[g]},
X		ind=Table[1,{n}];
X		g1 = PathConditionGraph[g];
X		best = Infinity;
X		While[ Length[s] > 0,
X			v = Last[s];
X			done = False;
X			While[ ind[[v]] <= Length[e[[v]]] && !done,
X				x = e[[v,ind[[v]]++]];
X				done = (best > CostOfPath[g1,Append[s,x]]) &&
X					!MemberQ[s,x]
X			];
X			If[done, AppendTo[s,x], s=Drop[s,-1]; ind[[v]] = 1];
X			If[(Length[s] == n),
X				cost = CostOfPath[g1, Append[s,First[s]]];
X				If [(cost < best), sol = s; best = cost ];
X				s = Drop[s,-1]
X			]
X		];
X		Append[sol,First[sol]]
X	]
X
XCostOfPath[Graph[g_,_],p_List] := Apply[Plus, Map[(Element[g,#])&,Partition[p,2,1]] ]
X
XElement[a_List,{index___}] := a[[ index ]]
X 
XTriangleInequalityQ[e_?SquareMatrixQ] :=
X	Block[{i,j,k,n=Length[e],flag=True},
X		Do [
X
X			If[(e[[i,k]]!=0) && (e[[k,j]]!=0) && (e[[i,j]]!=0),
X				If[e[[i,k]]+e[[k,j]]<e[[i,j]],
X					flag = False;
X				]
X			],
X			{i,n},{j,n},{k,n}
X		];
X		flag
X	]
X
XTriangleInequalityQ[g_Graph] := TriangleInequalityQ[Edges[g]]
X 
XTravelingSalesmanBounds[g_Graph] := {LowerBoundTSP[g], UpperBoundTSP[g]}
X
XUpperBoundTSP[g_Graph] :=
X	CostOfPath[g, Append[DepthFirstTraversal[MinimumSpanningTree[g],1],1]]
X
XLowerBoundTSP[g_Graph] := Apply[Plus, Map[Min,ReplaceAll[Edges[g],0->Infinity]]]
X 
XPartialOrderQ[g_Graph] := ReflexiveQ[g] && AntiSymmetricQ[g] && TransitiveQ[g]
X
XTransitiveQ[g_Graph] := IdenticalQ[g,TransitiveClosure[g]]
X
XReflexiveQ[Graph[g_List,_]] := 
X	Block[{i},
X		Apply[And, Table[(g[[i,i]]!=0),{i,Length[g]}] ]
X	]
X
XAntiSymmetricQ[g_Graph] := 
X	Block[{e = Edges[g], g1 = RemoveSelfLoops[g]},
X		Apply[And, Map[(Element[e,Reverse[#]]==0)&,ToOrderedPairs[g1]] ]
X	]
X 
XTransitiveClosure[g_Graph] :=
X	Block[{i,j,k,e=Edges[g],n=V[g]},
X		Do [
X			If[ e[[j,i]] != 0,
X				Do [
X					If[ e[[i,k]] != 0, e[[j,k]]=1],
X					{k,n}
X				]
X			],
X			{i,n},{j,n}
X		];
X		Graph[e,Vertices[g]]
X	]
X 
XTransitiveReduction[g_Graph] :=
X	Block[{closure=reduction=Edges[g],i,j,k,n=V[g]},
X		Do[
X			If[ closure[[i,j]]!=0 && closure[[j,k]]!=0 &&
X				 reduction[[i,k]]!=0 && (i!=j) && (j!=k) && (i!=k),
X					reduction[[i,k]] = 0
X			],
X			{i,n},{j,n},{k,n}
X		];
X		Graph[reduction,Vertices[g]]
X	] /; AcyclicQ[RemoveSelfLoops[g],Directed] 
X
XTransitiveReduction[g_Graph] :=
X	Block[{reduction=Edges[g],i,j,k,n=V[g]},
X		Do[
X			If[ reduction[[i,j]]!=0 && reduction[[j,k]]!=0 &&
X				 reduction[[i,k]]!=0 && (i!=j) && (j!=k) && (i!=k),
X					reduction[[i,k]] = 0
X			],
X			{i,n},{j,n},{k,n}
X		];
X		Graph[reduction,Vertices[g]]
X	] 
X 
XHasseDiagram[g_Graph] :=
X	Block[{r,rank,m,stages,freq=Table[0,{V[g]}]},
X		r = TransitiveReduction[ RemoveSelfLoops[g] ];
X		rank = RankGraph[
X				MakeUndirected[r],
X				Select[Range[V[g]],(InDegree[r,#]==0)&]
X		];
X		m = Max[rank];
X		rank = MapAt[(m)&,rank,Position[OutDegree[r],0]];
X		stages = Distribution[ rank ];
X		Graph[
X			Edges[r],
X			Table[
X				m = ++ freq[[ rank[[i]] ]];
X				{(m-1) + (1-stages[[rank[[i]] ]])/2, rank[[i]]},
X				{i,V[g]}
X			]
X		]
X	] /; AcyclicQ[RemoveSelfLoops[g],Directed]
X 
XTopologicalSort[g_Graph] :=
X	Block[{g1 = RemoveSelfLoops[g],e,indeg,zeros,v},
X		e=ToAdjacencyLists[g1];
X		indeg=InDegree[g1];
X		zeros = Flatten[ Position[indeg, 0] ];
X		Table [
X			{v,zeros}={First[zeros],Rest[zeros]};
X			Scan[
X				( indeg[[#]]--;
X				  If[indeg[[#]]==0, AppendTo[zeros,#]] )&,
X				e[[ v ]]
X			];
X			v,
X			{V[g]}
X		]
X	] /; AcyclicQ[RemoveSelfLoops[g],Directed]
X 
XChromaticPolynomial[g_Graph,z_] := 0 /; Identical[g,K[0]]
X
XChromaticPolynomial[g_Graph,z_] :=
X	Block[{i}, Product[z-i, {i,0,V[g]-1}] ] /; CompleteQ[g]
X
XChromaticPolynomial[g_Graph,z_] := z ( z - 1 ) ^ (V[g]-1) /; TreeQ[g]
X
XChromaticPolynomial[g_Graph,z_] :=
X	If [M[g]>Binomial[V[g],2]/2, ChromaticDense[g,z], ChromaticSparse[g,z]]
X
XChromaticSparse[g_Graph,z_] := z^V[g] /; EmptyQ[g]
XChromaticSparse[g_Graph,z_] :=
X	Block[{i=1, v, e=Edges[g], none=Table[0,{V[g]}]},
X        	While[e[[i]] === none, i++];
X        	v = Position[e[[i]],1] [[1,1]];
X		ChromaticSparse[ DeleteEdge[g,{i,v}], z ] -
X			ChromaticSparse[ Contract[g,{i,v}], z ]
X	]
X
XChromaticDense[g_Graph,z_] := ChromaticPolynomial[g,z] /; CompleteQ[g]
XChromaticDense[g_Graph,z_] :=
X	Block[
X		{i=1, v, e=Edges[g], all=Join[Table[1,{V[g]-1}],{0}] },
X		While[e[[i]] === RotateRight[all,i], i++];
X		v = Last[ Position[e[[i]],0] ] [[1]];
X		ChromaticDense[ AddEdge[g,{i,v}], z ] +
X			ChromaticDense[ Contract[g,{i,v}], z ]
X	]
X 
XChromaticNumber[g_Graph] :=
X	Block[{ways, z},
X		ways[z_] = ChromaticPolynomial[g,z];
X		For [z=0, z<=V[g], z++,
X			If [ways[z] > 0, Return[z]]
X		]
X	]
X 
XTwoColoring[g_Graph] := 
X	Block[{queue,elem,edges,col,flag=True,colored=Table[0,{V[g]}]},
X		edges = ToAdjacencyLists[g];
X		While[ MemberQ[colored,0],
X			queue = First[ Position[colored,0] ];
X			colored[[ First[queue] ]] = 1;
X			While[ queue != {},
X				elem = First[queue];
X				col = colored[[elem]];
X				Scan[
X					(Switch[colored[[ # ]],
X						col, flag = False,
X						0, AppendTo[queue, # ];
X						   colored[[#]] = Mod[col,2]+1
X					])&,
X					edges[[elem]]
X				];
X				queue = Rest[queue];
X			]
X		];
X		If [!flag, colored[[1]] = 0];
X		colored
X	]
X
XBipartiteQ[g_Graph] := ! MemberQ[ TwoColoring[g], 0 ]
X 
XVertexColoring[g_Graph] :=
X	Block[{v,l,n=V[g],e=ToAdjacencyLists[g],x,color=Table[0,{V[g]}]},
X		v = Map[(Apply[Plus,#])&, Edges[g]];
X		Do[
X			l = MaximumColorDegreeVertices[e,color];
X			x = First[l];
X			Scan[(If[ v[[#]] > v[[x]], x = #])&, l];
X			color[[x]] = Min[
X				Complement[ Range[n], color[[ e[[x]] ]] ]
X			],
X			{V[g]}
X		];
X		color
X	]
X
XMaximumColorDegreeVertices[e_List,color_List] :=
X	Block[{n=Length[color],l,i,x},
X		l = Table[ Count[e[[i]], _?(Function[x,color[[x]]!=0])], {i,n}];
X		Do [ 
X			If [color[[i]]!=0, l[[i]] = -1],
X			{i,n}
X		];
X		Flatten[ Position[ l, Max[l] ] ]
X	]
X 
XEdgeColoring[g_Graph] := VertexColoring[ LineGraph[g] ]
X
XEdgeChromaticNumber[g_Graph] := ChromaticNumber[ LineGraph[g] ]
X 
XCliqueQ[g_Graph,clique_List] :=
X	IdenticalQ[ K[Length[clique]], InduceSubgraph[g,clique] ] /; SimpleQ[g]
X
XMaximumClique[g_Graph] := {} /; g === K[0]
X
XMaximumClique[g_Graph] :=
X	Block[{d = Degrees[g],i,clique=Null,k},
X		i = Max[d];
X		While[(SameQ[clique,Null]),
X			k = K[i+1];
X			clique = FirstExample[
X				KSubsets[Flatten[Position[d,_?((#>=i)&)]], i+1],
X				(IdenticalQ[k,InduceSubgraph[g,#]])&
X			];
X			i--;
X		];
X		clique
X	]
X
XFirstExample[list_List, predicate_] := Scan[(If [predicate[#],Return[#]])&,list]
X 
XVertexCoverQ[g_Graph,vc_List] :=
X	CliqueQ[ GraphComplement[g], Complement[Range[V[g]], vc] ]
X
XMinimumVertexCover[g_Graph] :=
X	Complement[ Range[V[g]], MaximumClique[ GraphComplement[g] ] ]
X 
XIndependentSetQ[g_Graph,indep_List] :=
X	VertexCoverQ[ g, Complement[ Range[V[g]], indep] ]
X
XMaximumIndependentSet[g_Graph] := Complement[Range[V[g]], MinimumVertexCover[g]]
X 
XPerfectQ[g_Graph] :=
X	Apply[
X		And,
X		Map[(ChromaticNumber[#] == Length[MaximumClique[#]])&,
X			Map[(InduceSubgraph[g,#])&, Subsets[Range[V[g]]] ] ]
X	]
X 
XDijkstra[g_Graph,start_Integer] := First[ Dijkstra[g,{start}] ]
X
XDijkstra[g_Graph, l_List] :=
X	Block[{x,start,e=ToAdjacencyLists[g],i,p,parent,untraversed},
X		p=Edges[PathConditionGraph[g]];
X		Table[
X			start = l[[i]];
X			parent=untraversed=Range[V[g]];
X			dist = p[[start]]; dist[[start]] = 0;
X			Scan[ (parent[[#]] = start)&, e[[start]] ];
X			While[ untraversed != {} ,
X				x = First[untraversed];
X				Scan[(If [dist[[#]]<dist[[x]],x=#])&, untraversed];
X				untraversed = Complement[untraversed,{x}];
X				Scan[
X					(If[dist[[#]] > dist[[x]]+p[[x,#]],
X						dist[[#]] = dist[[x]]+p[[x,#]];
X						parent[[#]] = x ])&,
X					e[[x]]
X				];
X			];
X			{parent, dist},
X			{i,Length[l]}
X		]
X	]
X
XShortestPath[g_Graph,s_Integer,e_Integer] := 
X	Block[{parent=First[Dijkstra[g,s]],i=e,lst={e}},
X		While[ (i != s) && (i != parent[[i]]),
X			PrependTo[lst,parent[[i]]];
X			i = parent[[i]]
X		];
X		If[ i == s, lst, {}]
X	]
X
XShortestPathSpanningTree[g_Graph,s_Integer] :=
X	Block[{parent=First[Dijkstra[g,s]],i},
X		FromUnorderedPairs[
X			Map[({#,parent[[#]]})&, Complement[Range[V[g]],{s}]],
X			Vertices[g]
X		]
X	]
X 
XAllPairsShortestPath[g_Graph] :=
X	Block[{p=Edges[ PathConditionGraph[g] ],i,j,k,n=V[g]},
X		Do [
X			p = Table[Min[p[[i,k]]+p[[k,j]],p[[i,j]]],{i,n},{j,n}],
X			{k,n}
X		];
X		p
X	] /; Min[Edges[g]] < 0
X
XAllPairsShortestPath[g_Graph] := Map[ Last, Dijkstra[g, Range[V[g]]]]
X
XPathConditionGraph[Graph[e_,v_]] := RemoveSelfLoops[Graph[ReplaceAll[e,0->Infinity],v]]
X 
XGraphPower[g_Graph,1] := g
X
XGraphPower[g_Graph,n_Integer] :=
X	Block[{prod=power=p=Edges[g]},
X		Do [
X			prod = prod . p;
X			power = prod + power,
X			{n-1}
X		];
X		Graph[power, Vertices[g]]
X	]
X 
XInitializeUnionFind[n_Integer] := Block[{i}, Table[{i,1},{i,n}] ]
X
XFindSet[n_Integer,s_List] := If [n == s[[n,1]], n, FindSet[s[[n,1]],s] ]
X
XUnionSet[a_Integer,b_Integer,s_List] :=
X	Block[{sa=FindSet[a,s], sb=FindSet[b,s], set=s},
X		If[ set[[sa,2]] < set[[sb,2]], {sa,sb} = {sb,sa} ];
X		set[[sa]] = {sa, Max[ set[[sa,2]], set[[sb,2]]+1 ]};
X		set[[sb]] = {sa, set[[sb,2]]};
X		set
X	]
X 
XMinimumSpanningTree[g_Graph] :=
X	Block[{edges=Edges[g],set=InitializeUnionFind[V[g]]},
X		FromUnorderedPairs[
X			Select [
X				Sort[
X					ToUnorderedPairs[g],
X					(Element[edges,#1]<=Element[edges,#2])&
X				],
X				(If [FindSet[#[[1]],set] != FindSet[#[[2]],set],
X					set=UnionSet[#[[1]],#[[2]],set]; True,
X					False
X				])&
X			],
X			Vertices[g]
X		]
X	] /; UndirectedQ[g]
X
XMaximumSpanningTree[g_Graph] := MinimumSpanningTree[Graph[-Edges[g],Vertices[g]]]
X 
XCofactor[m_List,{i_Integer,j_Integer}] :=
X	(-1)^(i+j) * Det[ Drop[ Transpose[ Drop[Transpose[m],{j,j}] ], {i,i}] ]
X 
XNumberOfSpanningTrees[Graph[g_List,_]] :=
X	Cofactor[ DiagonalMatrix[Map[(Apply[Plus,#])&,g]] - g, {1,1}]
X 
XNetworkFlow[g_Graph,source_Integer,sink_Integer] :=
X	Block[{flow=NetworkFlowEdges[g,source,sink], i},
X		Sum[flow[[i,sink]], {i,V[g]}]
X	]
X
X
XNetworkFlowEdges[g_Graph,source_Integer,sink_Integer] :=
X	Block[{e=Edges[g], x, y, flow=Table[0,{V[g]},{V[g]}], p, m},
X		While[ !SameQ[p=AugmentingPath[g,source,sink], {}],
X			m = Min[Map[({x,y}=#[[1]]; 
X				 If[SameQ[#[[2]],f],e[[x,y]]-flow[[x,y]],
X					flow[[x,y]]])&,p]];
X			Scan[	
X				({x,y}=#[[1]];
X				 If[ SameQ[#[[2]],f],
X					flow[[x,y]]+=m,flow[[x,y]]-=m])&,
X				 p
X			]
X		];
X		flow
X	]
X
XAugmentingPath[g_Graph,src_Integer,sink_Integer] :=
X	Block[{l={src},lab=Table[0,{V[g]}],v,c=Edges[g],e=ToAdjacencyLists[g]},
X		lab[[src]] = start;
X		While[l != {} && (lab[[sink]]==0),
X			{v,l} = {First[l],Rest[l]};
X			Scan[ (If[ c[[v,#]] - flow[[v,#]] > 0 && lab[[#]] == 0,
X				lab[[#]] = {v,f}; AppendTo[l,#]])&,
X				e[[v]]
X			];
X			Scan[ (If[ flow[[#,v]] > 0 && lab[[#]] == 0,
X				lab[[#]] = {v,b}; AppendTo[l,#]] )&,
X				Select[Range[V[g]],(c[[#,v]] > 0)&]
X			];
X		];
X		FindPath[lab,src,sink]
X	]
X
XFindPath[l_List,v1_Integer,v2_Integer] :=
X	Block[{x=l[[v2]],y,z=v2,lst={}},
X		If[SameQ[x,0], Return[{}]];
X		While[!SameQ[x, start],
X			If[ SameQ[x[[2]],f],
X				PrependTo[lst,{{ x[[1]], z }, f}],
X				PrependTo[lst,{{ z, x[[1]] }, b}]
X			];
X			z = x[[1]]; x = l[[z]];
X		];
X		lst
X	]
X 
XBipartiteMatching[g_Graph] :=
X	Block[{p,v1,v2,coloring=TwoColoring[g],n=V[g]},
X		v1 = Flatten[Position[coloring,1]];
X		v2 = Flatten[Position[coloring,2]];
X		p = BipartiteMatchingFlowGraph[g,v1,v2];
X		flow = NetworkFlowEdges[p,V[g]+1,V[g]+2];
X		Select[ToOrderedPairs[Graph[flow,Vertices[p]]], (Max[#]<=n)&]
X	] /; BipartiteQ[g]
X
XBipartiteMatchingFlowGraph[g_Graph,v1_List,v2_List] :=
X	Block[{edges = Table[0,{V[g]+2},{V[g]+2}],i,e=ToAdjacencyLists[g]},
X		Do[ 
X	    		Scan[ (edges[[v1[[i]],#]] = 1)&, e[[ v1[[i]] ]] ],
X			{i,Length[v1]}
X		];
X		Scan[(edges[[V[g] + 1, #]] = 1)&, v1];
X		Scan[(edges[[#, V[g] + 2]] = 1)&, v2];
X		Graph[edges,RandomVertices[V[g] + 2] ]
X	]
X 
XMinimumChainPartition[g_Graph] :=
X	ConnectedComponents[
X		FromUnorderedPairs[
X			Map[(#-{0,V[g]})&, BipartiteMatching[DilworthGraph[g]]],
X			Vertices[g]
X		]
X	]
X
XMaximumAntichain[g_Graph] := MaximumIndependentSet[TransitiveClosure[g]]
X
XDilworthGraph[g_Graph] :=
X	FromUnorderedPairs[
X		Map[
X			(#+{0,V[g]})&,
X			ToOrderedPairs[RemoveSelfLoops[TransitiveReduction[g]]]
X		]
X	]
X 
XMaximalMatching[g_Graph] :=
X	Block[{match={}},
X		Scan[
X			(If [Intersection[#,match]=={}, match=Join[match,#]])&,
X			ToUnorderedPairs[g]
X		];
X		Partition[match,2]
X	]
X 
XStableMarriage[mpref_List,fpref_List] :=
X	Block[{n=Length[mpref],freemen,cur,i,w,husband},
X		freemen = Range[n];
X		cur = Table[1,{n}];
X		husband = Table[n+1,{n}];
X		While[ freemen != {},
X			{i,freemen}={First[freemen],Rest[freemen]};
X			w = mpref[[ i,cur[[i]] ]];
X			If[BeforeQ[ fpref[[w]], i, husband[[w]] ], 
X				If[husband[[w]] != n+1,
X					AppendTo[freemen,husband[[w]] ]
X				];
X				husband[[w]] = i,
X				cur[[i]]++;
X				AppendTo[freemen,i]
X			];
X		];
X		InversePermutation[ husband ]
X	] /; Length[mpref] == Length[fpref]
X
XBeforeQ[l_List,a_,b_] :=
X	If [First[l]==a, True, If [First[l]==b, False, BeforeQ[Rest[l],a,b] ] ]
X 
XPlanarQ[g_Graph] :=
X	Apply[
X		And,
X		Map[(PlanarQ[InduceSubgraph[g,#]])&, ConnectedComponents[g]]
X	] /; !ConnectedQ[g]
X
XPlanarQ[g_Graph] := False /;  (M[g] > 3 V[g]-6) && (V[g] > 2)
XPlanarQ[g_Graph] := True /;   (M[g] < V[g] + 3)
XPlanarQ[g_Graph] := PlanarGivenCycle[ g, Rest[FindCycle[g]] ]
X
XPlanarGivenCycle[g_Graph, cycle_List] :=
X	Block[{b, j, i},
X		{b, j} = FindBridge[g, cycle];
X		If[ InterlockQ[j, cycle],
X			False,
X			Apply[And, Table[SingleBridgeQ[b[[i]],j[[i]]], {i,Length[b]}]]
X		]
X	]
X
XSingleBridgeQ[b_Graph, {_}] := PlanarQ[b]
X
XSingleBridgeQ[b_Graph, j_List] :=
X	PlanarGivenCycle[ JoinCycle[b,j],
X		Join[ ShortestPath[b,j[[1]],j[[2]]], Drop[j,2]] ]
X
XJoinCycle[g1_Graph, cycle_List] :=
X	Block[{g=g1},
X		Scan[(g = AddEdge[g,#])&, Partition[cycle,2,1] ];
X		AddEdge[g,{First[cycle],Last[cycle]}]
X	]
X 
XFindBridge[g_Graph, cycle_List] :=
X    Block[{rg = RemoveCycleEdges[g, cycle], b, bridge, j},
X	b = Map[
X		(IsolateSubgraph[rg,g,cycle,#])&,
X		Select[ConnectedComponents[rg], (Intersection[#,cycle]=={})&]
X	];
X	b = Select[b, (!EmptyQ[#])&];
X	j = Join[
X		Map[Function[bridge,Select[cycle, MemberQ[Edges[bridge][[#]],1]&] ], b],
X		Complement[
X			Select[ToOrderedPairs[g],
X				(Length[Intersection[#,cycle]] == 2)&],
X			Partition[Append[cycle,First[cycle]],2,1]
X		]
X	];
X	{b, j}
X    ]
X
XRemoveCycleEdges[g_Graph, c_List] :=
X	FromOrderedPairs[
X		Select[ ToOrderedPairs[g], (Intersection[c,#] === {})&],
X		Vertices[g]
X	]
X
XIsolateSubgraph[g_Graph,orig_Graph,cycle_List,cc_List] :=
X	Block[{eg=ToOrderedPairs[g], og=ToOrderedPairs[orig]},
X		FromOrderedPairs[
X			Join[
X				Select[eg, (Length[Intersection[cc,#]] == 2)&],
X				Select[og, (Intersection[#,cycle]!={} &&
X					Intersection[#,cc]!={})&]
X			],
X			Vertices[g]
X		]
X	]
X 
XInterlockQ[ bl_List, c_List ] :=
X	Block[{in = out = {}, code, jp, bridgelist = bl },
X		While [ bridgelist != {},
X			{jp, bridgelist} = {First[bridgelist],Rest[bridgelist]};
X			code = Sort[ Map[(Position[c, #][[1,1]])&, jp] ];
X			If[ Apply[ Or, Map[(LockQ[#,code])&, in] ],
X				If [ Apply[Or, Map[(LockQ[#,code])&, out] ],
X					Return[True],
X					AppendTo[out,code]
X				],
X				AppendTo[in,code]
X			]
X		];
X		False
X	]
X
XLockQ[a_List,b_List] := Lock1Q[a,b] || Lock1Q[b,a]
X
XLock1Q[a_List,b_List] :=
X	Block[{bk, aj},
X		bk = Min[ Select[Drop[b,-1], (#>First[a])&] ];
X		aj = Min[ Select[a, (# > bk)&] ];
X		(aj < Max[b])
X	]
X 
XEnd[]
X
XProtect[
XAcyclicQ,
XAddEdge,
XAddVertex,
XAllPairsShortestPath,
XArticulationVertices,
XAutomorphisms,
XBacktrack,
XBiconnectedComponents,
XBiconnectedComponents,
XBiconnectedQ,
XBinarySearch,
XBinarySubsets,
XBipartiteMatching,
XBipartiteQ,
XBreadthFirstTraversal,
XBridges,
XCartesianProduct,
XCatalanNumber,
XChangeEdges,
XChangeVertices,
XChromaticNumber,
XChromaticPolynomial,
XCirculantGraph,
XCircularVertices,
XCliqueQ,
XCodeToLabeledTree,
XCofactor,
XCompleteQ,
XCompositions,
XConnectedComponents,
XConnectedQ,
XConstructTableau,
XContract,
XCostOfPath,
XCycle,
XDeBruijnSequence,
XDegreeSequence,
XDeleteCycle,
XDeleteEdge,
XDeleteFromTableau,
XDeleteVertex,
XDepthFirstTraversal,
XDerangementQ,
XDerangements,
XDiameter,
XDijkstra,
XDilateVertices,
XDistinctPermutations,
XDistribution,
XDurfeeSquare,
XEccentricity,
XEdgeChromaticNumber,
XEdgeColoring,
XEdgeConnectivity,
XEdges,
XElement,
XEmptyGraph,
XEmptyQ,
XEncroachingListSet,
XEquivalenceClasses,
XEquivalenceRelationQ,
XEquivalences,
XEulerianCycle,
XEulerianQ,
XEulerian,
XExactRandomGraph,
XExpandGraph,
XExtractCycles,
XFerrersDiagram,
XFindCycle,
XFindSet,
XFirstLexicographicTableau,
XFromAdjacencyLists,
XFromCycles,
XFromInversionVector,
XFromOrderedPairs,
XFromUnorderedPairs,
XFunctionalGraph,
XGirth,
XGraphCenter,
XGraphComplement,
XGraphDifference,
XGraphIntersection,
XGraphJoin,
XGraphPower,
XGraphProduct,
XGraphSum,
XGraphUnion,
XGraphicQ,
XGrayCode,
XGridGraph,
XHamiltonianCycle,
XHamiltonianQ,
XHarary,
XHasseDiagram,
XHeapSort,
XHeapify,
XHideCycles,
XHypercube,
XIdenticalQ,
XIncidenceMatrix,
XIndependentSetQ,
XIndex,
XInduceSubgraph,
XInitializeUnionFind,
XInsertIntoTableau,
XIntervalGraph,
XInversePermutation,
XInversions,
XInvolutionQ,
XIsomorphicQ,
XIsomorphismQ,
XIsomorphism,
XJosephus,
XKSubsets,
XK,
XLabeledTreeToCode,
XLastLexicographicTableau,
XLexicographicPermutations,
XLexicographicSubsets,
XLineGraph,
XLongestIncreasingSubsequence,
XM,
XMakeGraph,
XMakeSimple,
XMakeUndirected,
XMaximalMatching,
XMaximumAntichain,
XMaximumClique,
XMaximumIndependentSet,
XMaximumSpanningTree,
XMinimumChainPartition,
XMinimumChangePermutations,
XMinimumSpanningTree,
XMinimumVertexCover,
XMultiplicationTable,
XNetworkFlowEdges,
XNetworkFlow,
XNextComposition,
XNextKSubset,
XNextPartition,
XNextPermutation,
XNextSubset,
XNextTableau,
XNormalizeVertices,
XNthPair,
XNthPermutation,
XNthSubset,
XNumberOfCompositions,
XNumberOfDerangements,
XNumberOfInvolutions,
XNumberOfPartitions,
XNumberOfPermutationsByCycles,
XNumberOfSpanningTrees,
XNumberOfTableaux,
XOrientGraph,
XPartialOrderQ,
XPartitionQ,
XPartitions,
XPathConditionGraph,
XPath,
XPerfectQ,
XPermutationGroupQ,
XPermutationQ,
XPermute,
XPlanarQ,
XPointsAndLines,
XPolya,
XPseudographQ,
XRadialEmbedding,
XRadius,
XRandomComposition,
XRandomGraph,
XRandomHeap,
XRandomKSubset,
XRandomPartition,
XRandomPermutation1,
XRandomPermutation2,
XRandomPermutation,
XRandomSubset,
XRandomTableau,
XRandomTree,
XRandomVertices,
XRankGraph,
XRankPermutation,
XRankSubset,
XRankedEmbedding,
XReadGraph,
XRealizeDegreeSequence,
XRegularGraph,
XRegularQ,
XRemoveSelfLoops,
XRevealCycles,
XRootedEmbedding,
XRotateVertices,
XRuns,
XSamenessRelation,
XSelectionSort,
XSelfComplementaryQ,
XShakeGraph,
XShortestPathSpanningTree,
XShortestPath,
XShowGraph,
XShowLabeledGraph,
XSignaturePermutation,
XSimpleQ,
XSpectrum,
XSpringEmbedding,
XStableMarriage,
XStar,
XStirlingFirst,
XStirlingSecond,
XStrings,
XStronglyConnectedComponents,
XSubsets,
XTableauClasses,
XTableauQ,
XTableauxToPermutation,
XTableaux,
XToAdjacencyLists,
XToCycles,
XToInversionVector,
XToOrderedPairs,
XToUnorderedPairs,
XTopologicalSort,
XTransitiveClosure,
XTransitiveQ,
XTransitiveReduction,
XTranslateVertices,
XTransposePartition,
XTransposeTableau,
XTravelingSalesmanBounds,
XTravelingSalesman,
XTreeQ,
XTriangleInequalityQ,
XTuran,
XTwoColoring,
XUndirectedQ,
XUnionSet,
XUnweightedQ,
XV,
XVertexColoring,
XVertexConnectivity,
XVertexCoverQ,
XVertices,
XWeaklyConnectedComponents,
XWheel,
XWriteGraph,
XDilworthGraph ]
X
XEndPackage[ ]
END_OF_part3
if test 29647 -ne `wc -c <part3`; then
    echo shar: \"part3\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 2 \(of 3\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 ; do
    if test ! -f ark${I}isdone ; then
	MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 3 archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
