Problem 3

This problem involved attaching a voltage generator to the following graph.  The generator attached at the source 6 and sink 4 yields absolute voltage potentials of 1 at vertex 6 and 0 at vertex 4.  The graph below was given with conductance at each edge as labelled.  We solve the problem below:

g=;

weights=(AbsoluteOptions[g,EdgeWeight]/.HoldPattern[EdgeWeight->x_]->x)[[1]]

edges=EdgeList[g]

vertices=VertexList[g]

n=VertexCount[g]

m=EdgeCount[g]

conductancematrix=Normal[WeightedAdjacencyMatrix[g]];
MatrixForm[conductancematrix]

In order to solve the problem, we need to choose directions for each edge.  The answer will be independent of our choice.

directedadjacencymatrix=ConstantArray[0,{n,n}];
Do[
directedadjacencymatrix[[i,j]]=conductancematrix[[i,j]],{j,1,n},{i,1,j}];
MatrixForm[directedadjacencymatrix]

It’s not necessary, but let’s get a picture.  To make it look like the picture above, it will be helpful to have the vertex coordinates of the given drawing:

myvertexcoords=VertexCoordinates/.AbsoluteOptions[g,VertexCoordinates]

graphoptions={VertexSize->Medium,VertexStyle->{6->Red,4->Directive[Black],LightBlue},VertexLabelStyle->{6->Directive[White,14,Bold],4->Directive[White,14,Bold],Directive[Black,14,Bold]},EdgeLabels->"EdgeWeight",EdgeLabelStyle->Directive[Black,14,Bold],EdgeShapeFunction->GraphElementData[{"UnfilledArrow","ArrowSize"->.05}],EdgeStyle->{Thick,Opacity[.5]}};

directedg=WeightedAdjacencyGraph[directedadjacencymatrix/.(0->Infinity),VertexLabels->Table[i->Placed["Name",{1/2,1/2}],{i,VertexList[WeightedAdjacencyGraph[directedadjacencymatrix]]}],graphoptions,VertexCoordinates->myvertexcoords]

directededges=EdgeList[directedg]

boundarymatrix=Normal[IncidenceMatrix[directedg]];
MatrixForm[boundarymatrix]

vvect=Table[Subscript[v,i],{i,vertices}]

Now we’ll get the conductances of each edge.  Notice, this is the difference of the absolute voltage potential at the endpoints multiplied by the conductance, which we read off the conductance matrix:

wvect=Table[conductancematrix[[edge[[1]],edge[[2]]]](Subscript[v,edge[[1]]]-Subscript[v,edge[[2]]]),{edge,directededges}]

The source and sink are given:

source=6;sink=4;

vertexcurrents=ConstantArray[0,{n}];
vertexcurrents[[VertexIndex[directedg,source]]]=-c;
vertexcurrents[[VertexIndex[directedg,sink]]]=c;
vertexcurrents

Now, we use Kirchoff’s current laws to solve for the absolute voltage potentials:

sols=Solve[{boundarymatrix.wvect==vertexcurrents,(Subscript[v, source])==1,(Subscript[v, sink])==0},Join[vvect,{c}]]

Here are the voltage potentials at each vertex:

absolutevoltages=(vvect/.sols)[[1]]

and the total current

totalcurrent=c/.sols [[1]]

which is approximately

N[totalcurrent,3]

The currents on the edges are then

edgecurrents=wvect/.sols[[1]]

Unsurprisingly, some of the currents are negative, indicating that the current flows in the opposite direction from the direction we assigned to the edge.  Just for fun, let’s redirect the edges according to the current flow, and then label the picture with the current on each edge.  So our picture isn’t too cluttered, let’s use three decimal places.

redirectedadjacencymatrix=ConstantArray[Infinity,{n,n}];
Do[
If[edgecurrents[[Position[directededges,edge][[1,1]]]]<=0,
redirectedadjacencymatrix[[edge[[2]],edge[[1]]]]=-N[edgecurrents[[Position[directededges,edge][[1,1]]]],3],redirectedadjacencymatrix[[edge[[1]],edge[[2]]]]=N[edgecurrents[[Position[directededges,edge][[1,1]]]],3]],{edge,directededges}];

redirectededges=
Table[If[edgecurrents[[Position[directededges,edge][[1,1]]]]<0, edge[[2]]\[DirectedEdge]edge[[1]],edge[[1]]\[DirectedEdge]edge[[2]]],{edge,directededges}]

redirectedg=WeightedAdjacencyGraph[redirectedadjacencymatrix,VertexLabels->Table[i->Placed["Name",{1/2,1/2}],{i,VertexList[WeightedAdjacencyGraph[directedadjacencymatrix]]}],graphoptions,VertexCoordinates->myvertexcoords]

Export["WeightedGraphSolution.pdf",redirectedg]