7
$\begingroup$

Through out our study from junior high to freshman year, we need to deal with complex resistence networks and know about how to solve them. There're three principle rules of them:

  1. when dealing with line form resistences, sum them up.

  2. when dealing with parallel resistences, do 1/Total[1/rlist].

  3. when dealing with complex networks, use transformation between triangle and star form.

How to create a program that illustrate a human like resistence network solving process in Mathematica using only the previous three rules?

Improve this question
$\endgroup$

1 Answer 1

Reset to default
11
$\begingroup$

Result

A slight view of the result first:

res

anim

Code and Explanation

Firstly, let's write out some visulization rules we'll use later:

style = {VertexLabels -> "Name", EdgeLabels -> "EdgeWeight", 
   EdgeLabelStyle -> Red, ImageSize->Medium};

vc[g_] := 
  VertexCoordinates -> (# -> 
       PropertyValue[{g, #}, VertexCoordinates] & /@ VertexList@g);

highstyle[color_, ver_, edge_] := {Style[#, Darker[color, .65]] & /@ ver, 
   Style[#, Darker@color, Thick] & /@ edge};

delhighlight[g_] := 
  Fold[SetProperty[{#1, #2}, GraphHighlight -> False] &, g, 
   PropertyValue[g, GraphHighlight]];

Where style specify the overall styling, vc can be used to keep the graph in it's original shape after modification, highstyle specify the overall highlight style and delhighlight delete all highlight style and prepare the graph for further simplification.

Then we can generate a quite beautiful image of a certain complex resistence network:

SeedRandom@1;
g = Graph[#, EdgeWeight -> RandomInteger[{1, 10}, EdgeCount@#]] &@
  Graph[{0 <-> 13, 13 <-> 14, 14 <-> 0, 0 <-> 1, 12 <-> 1, 0 <-> 12, 
    10 <-> 16, 4 <-> 9, 9 <-> 10, 10 <-> 4, 11 <-> 9, 11 <-> 10, 
    1 <-> 2, 2 <-> 3, 1 <-> 4, 1 <-> 5, 1 <-> 6, 4 <-> 8, 8 <-> 7, 
    5 <-> 7, 6 <-> 3, 7 <-> 3, 11 <-> 4, 12 <-> 17, 17 <-> 18, 
    18 <-> 19, 4 <-> 15, 15 <-> 20, 20 <-> 4, 10 <-> 21}, 
   GraphLayout -> "SpringEmbedding", style]

pt = {1, 8, 9};

where g will be the graph to process and pt specify the points concerned, so in this case with three vertexes names' in pt, I mean to eventually get a graph with three vertexes only and know how they're connected.

g

Then, for the notoriously bugsome Mathematica's Graph functions, I need to write out some code to replicate some existing functions:

myVertexDelete[g_, ptl_] := 
 Block[{ea = 
    Association[# -> PropertyValue[{g, #}, EdgeWeight] & /@ 
      EdgeList@g], el}, 
  Graph[el = EdgeList@VertexDelete[g, ptl], EdgeWeight -> ea /@ el, 
   style, VertexCoordinates -> (# -> 
        PropertyValue[{g, #}, VertexCoordinates] & /@ 
      Complement[VertexList@g, ptl])]]

myVertexDelete will properly delete vertexes while preserving other properties correctly.

mergep[resl_, cg_: True] := 
 Block[{prep = #[[1, 1]] -> 1/Total[1/#[[;; , 2]]] & /@ 
     GatherBy[resl, Sort@#[[1]] &]}, 
  Graph[prep[[;; , 1]], EdgeWeight -> prep[[;; , 2]], style, 
   If[cg =!= True, vc@cg, Automatic]]]

mergep merges parallel resistences to aviod Mathematica's wierd behaviour when dealing with complex graphs as mentioned here.

Then we can go on and teach Mathematica how to process simple resistence networks contains only parallel positioned or line formed resistences:

mline[g_] := 
  Block[{vn = VertexList@g, vd = VertexDegree@g, 
    ea = Association@
      Thread[EdgeList@g -> PropertyValue[g, EdgeWeight]], r, subg}, 
   r = UndirectedEdge @@ Complement[VertexComponent[g, #, 1], #] -> 
       Total[ea /@ EdgeList[g, (Alternatives @@ #) <-> _]] & /@ 
     ConnectedComponents[
      subg = Subgraph[g, 
        Complement[Pick[vn, vd, 2], pt]]]; {HighlightGraph[g, 
     highstyle[Green, VertexList@subg, 
      EdgeList[g, (Alternatives @@ VertexList@subg) <-> _]], style], 
    HighlightGraph[
     mergep[Join[# -> ea@# & /@ 
        EdgeList@VertexDelete[g, VertexList@subg], r], g], 
     Style[#, Darker[Green, .65], Thick] & /@ 
      DeleteDuplicates[r[[;; , 1]]]]}];

simpleproc[g_] := 
  Most@NestWhileList[mline@*delhighlight@*Last, {g}, 
    Unequal @@ (Sort@*EdgeList /@ #) &];

Where mline merges line form resistences and represent them, and simple proc will repeatedly try to simplify the network untill it cannot be further simplified using simple network's manipulation rules.

Let's try it out with this simple graph:

gg = Graph[{1 <-> 2, 2 <-> 3, 2 <-> 4, 3 <-> 5, 3 <-> 8, 4 <-> 6, 
   5 <-> 7, 6 <-> 7, 7 <-> 8}, 
  EdgeWeight -> RandomInteger[{0, 10}, 9], style]
pt = {1, 7};
simpleproc[gg]

tryout

the effect is great and the result is correct.

Then we need to know how to proceed with these two forms of transformation: star->triangle and triangle->star:

s2t[r : {r1_, r2_, r3_}] := (RotateRight[r].r)/r;
t2s[r : {r23_, r13_, r12_}] := RotateRight@r RotateLeft@r/Total@r

First thing first: how to transform between these two physically, where s2t stands for "star to triangle" and t2s do just the opposite:

triangle to star

star to triangle

then write out the code using these two rules:

simplifybypoints[g_, center_] := 
  Block[{adj, 
    ea = Association@
      Thread[EdgeList@g -> PropertyValue[g, EdgeWeight]], newedge}, 
   adj = Complement[VertexComponent[g, center, 1], {center}]; 
   newedge = 
    UndirectedEdge @@@ 
     Thread[{RotateRight@adj, RotateLeft@adj}]; {HighlightGraph[g, 
     highstyle[Purple, Append[adj, center], Thread[adj <-> center]]], 
    HighlightGraph[
     mergep[Join[# -> ea@# & /@ EdgeList@VertexDelete[g, center], 
       Thread[newedge -> 
         s2t[PropertyValue[{g, UndirectedEdge[#, center]}, 
             EdgeWeight] & /@ adj]]], g], 
     highstyle[Darker@Purple, adj, newedge]]}];

simplifybycycle[g_, cycle_] := 
 Block[{newp = Unique["new"], 
   ea = Association@
     Thread[EdgeList@g -> PropertyValue[g, EdgeWeight]], 
   el = EdgeList@EdgeDelete[g, cycle], vl = VertexList@Graph@cycle, 
   newedge}, {HighlightGraph[g, highstyle[Purple, vl, cycle]], 
   HighlightGraph[
    Graph[Join[el, 
      newedge = 
       Thread[newp <-> Complement[vl, #][[1]] & /@ List @@@ cycle]], 
     EdgeWeight -> 
      Join[ea /@ el, 
       t2s[PropertyValue[{g, #}, EdgeWeight] & /@ cycle]], style, 
     VertexCoordinates -> 
      Append[# -> PropertyValue[{g, #}, VertexCoordinates] & /@ 
        VertexList@g, 
       newp -> Mean[
         PropertyValue[{g, #}, VertexCoordinates] & /@ vl]]], 
    highstyle[Darker@Purple, {newp}, newedge]]}]

and we can use complexproc to integrate these two nasty functions as both of them must be used to solve arbitrary networks:

complexproc[g_] := 
  Block[{cycle, center}, 
   If[(cycle = FindCycle[Graph@EdgeList@g, {3}]) === {}, 
    If[(center = 
        SelectFirst[
         Thread[{VertexList@g, VertexDegree@g}], #[[2]] == 3 && 
           FreeQ[pt, #[[1]]] &]) === {}, {g, g}, 
     simplifybypoints[delhighlight@g, center[[1]]]], 
    simplifybycycle[delhighlight@g, cycle[[1]]]]];

When there's cycles, simplify by cycle using simplifybycycle. If not, check if there's any star form resistences, yes? use simplifybypoints. no? probably the whole simplify process is over~

one sample is like the following:

gg = Graph[{1 <-> center, 2 <-> center, 3 <-> center, other <-> 1, 
   4 <-> 3, 5 <-> 4, 3 <-> 5}, EdgeWeight -> Range@7, style, 
  ImageSize -> Small, GraphLayout -> "RadialDrawing"]
complexproc@gg
simplifybypoints[gg, center]

sample

Then sometimes we may need to simplify the graph and delete unnecessary vertexes and edges, for this part, I mainly copied from this answer but I added some minor adjustments so that it can work for situations with more vertexes(>2) in pt:

delline[g_] := 
 Block[{del = 
    Complement[VertexList@g, 
     DeleteDuplicates@
      Flatten[FindPath[g, First@pt, #, Infinity, All] & /@ 
        Rest@pt]]}, {HighlightGraph[g, 
    highstyle[Orange, del, 
     Flatten[Thread[
         DeleteCases[VertexComponent[g, #, 1], #] <-> #] & /@ del]]], 
   myVertexDelete[g, del]}]

The final thing is easy, repeatingly use simpleproc and complexproc:

allproc[g_] := 
 Grid[Select[Flatten[
     NestWhileList[
      Block[{res = simpleproc@#[[-1, -1]], res1}, 
        res1 = complexproc@res[[-1, -1]];
        Join[
         res, {res1, delline@delhighlight@res1[[-1]]}]] &, {delline@
        g}, ! SubsetQ[pt, VertexList@#[[-1, -1]]] &], 1], 
    Length@# == 2 && ! IsomorphicGraphQ[#[[1]], #[[2]]] &], 
  Spacings -> {5, 5}]

Then we can get an optimal result.

Final Code

Clear["`*"]
SeedRandom@1;
g = Graph[#, EdgeWeight -> RandomInteger[{1, 10}, EdgeCount@#]] &@
  Graph[{0 <-> 13, 13 <-> 14, 14 <-> 0, 0 <-> 1, 12 <-> 1, 0 <-> 12, 
    10 <-> 16, 4 <-> 9, 9 <-> 10, 10 <-> 4, 11 <-> 9, 11 <-> 10, 
    1 <-> 2, 2 <-> 3, 1 <-> 4, 1 <-> 5, 1 <-> 6, 4 <-> 8, 8 <-> 7, 
    5 <-> 7, 6 <-> 3, 7 <-> 3, 11 <-> 4, 12 <-> 17, 17 <-> 18, 
    18 <-> 19, 4 <-> 15, 15 <-> 20, 20 <-> 4, 10 <-> 21}, 
   GraphLayout -> "SpringEmbedding", VertexLabels -> "Name", 
   EdgeLabels -> "EdgeWeight", EdgeLabelStyle -> Red, 
   ImageSize -> Medium]

pt = {1, 8, 9};

style = {VertexLabels -> "Name", EdgeLabels -> "EdgeWeight", 
   EdgeLabelStyle -> Red, ImageSize -> Medium, 
   PlotRange -> 
    MinMax /@ 
     Transpose[
      PropertyValue[{g, #}, VertexCoordinates] & /@ VertexList@g]};
vc[g_] := 
  VertexCoordinates -> (# -> 
       PropertyValue[{g, #}, VertexCoordinates] & /@ VertexList@g);
highstyle[color_, ver_, 
   edge_] := {Style[#, Darker[color, .65]] & /@ ver, 
   Style[#, Darker@color, Thick] & /@ edge};

delhighlight[g_] := 
  Fold[SetProperty[{#1, #2}, GraphHighlight -> False] &, g, 
   PropertyValue[g, GraphHighlight]];

myVertexDelete[g_, ptl_] := 
 Block[{ea = 
    Association[# -> PropertyValue[{g, #}, EdgeWeight] & /@ 
      EdgeList@g], el}, 
  Graph[el = EdgeList@VertexDelete[g, ptl], EdgeWeight -> ea /@ el, 
   style, VertexCoordinates -> (# -> 
        PropertyValue[{g, #}, VertexCoordinates] & /@ 
      Complement[VertexList@g, ptl])]]


delline[g_] := 
  Block[{del = 
     Complement[VertexList@g, 
      DeleteDuplicates@
       Flatten[FindPath[g, First@pt, #, Infinity, All] & /@ 
         Rest@pt]]}, {HighlightGraph[g, 
     highstyle[Orange, del, 
      Flatten[Thread[
          DeleteCases[VertexComponent[g, #, 1], #] <-> #] & /@ del]]],
     myVertexDelete[g, del]}];

mergep[resl_, cg_: True] := 
  Block[{prep = #[[1, 1]] -> 1/Total[1/#[[;; , 2]]] & /@ 
      GatherBy[resl, Sort@#[[1]] &]}, 
   Graph[prep[[;; , 1]], EdgeWeight -> prep[[;; , 2]], style, 
    If[cg =!= True, vc@cg, Automatic]]];

mline[g_] := 
  Block[{vn = VertexList@g, vd = VertexDegree@g, 
    ea = Association@
      Thread[EdgeList@g -> PropertyValue[g, EdgeWeight]], r, subg}, 
   r = UndirectedEdge @@ Complement[VertexComponent[g, #, 1], #] -> 
       Total[ea /@ EdgeList[g, (Alternatives @@ #) <-> _]] & /@ 
     ConnectedComponents[
      subg = Subgraph[g, 
        Complement[Pick[vn, vd, 2], pt]]]; {HighlightGraph[g, 
     highstyle[Green, VertexList@subg, 
      EdgeList[g, (Alternatives @@ VertexList@subg) <-> _]], style], 
    HighlightGraph[
     mergep[Join[# -> ea@# & /@ 
        EdgeList@VertexDelete[g, VertexList@subg], r], g], 
     Style[#, Darker[Green, .65], Thick] & /@ 
      DeleteDuplicates[r[[;; , 1]]]]}];

simpleproc[g_] := 
  Most@NestWhileList[mline@*delhighlight@*Last, {g}, 
    Unequal @@ (Sort@*EdgeList /@ #) &];

s2t[r : {r1_, r2_, r3_}] := (RotateRight[r].r)/r;
t2s[r : {r23_, r13_, r12_}] := RotateRight@r RotateLeft@r/Total@r

simplifybypoints[g_, center_] := 
  Block[{adj, 
    ea = Association@
      Thread[EdgeList@g -> PropertyValue[g, EdgeWeight]], newedge}, 
   adj = Complement[VertexComponent[g, center, 1], {center}]; 
   newedge = 
    UndirectedEdge @@@ 
     Thread[{RotateRight@adj, RotateLeft@adj}]; {HighlightGraph[g, 
     highstyle[Purple, Append[adj, center], Thread[adj <-> center]]], 
    HighlightGraph[
     mergep[Join[# -> ea@# & /@ EdgeList@VertexDelete[g, center], 
       Thread[newedge -> 
         s2t[PropertyValue[{g, UndirectedEdge[#, center]}, 
             EdgeWeight] & /@ adj]]], g], 
     highstyle[Darker@Purple, adj, newedge]]}];

simplifybycycle[g_, cycle_] := 
 Block[{newp = Unique["new"], 
   ea = Association@
     Thread[EdgeList@g -> PropertyValue[g, EdgeWeight]], 
   el = EdgeList@EdgeDelete[g, cycle], vl = VertexList@Graph@cycle, 
   newedge}, {HighlightGraph[g, highstyle[Purple, vl, cycle]], 
   HighlightGraph[
    Graph[Join[el, 
      newedge = 
       Thread[newp <-> Complement[vl, #][[1]] & /@ List @@@ cycle]], 
     EdgeWeight -> 
      Join[ea /@ el, 
       t2s[PropertyValue[{g, #}, EdgeWeight] & /@ cycle]], style, 
     VertexCoordinates -> 
      Append[# -> PropertyValue[{g, #}, VertexCoordinates] & /@ 
        VertexList@g, 
       newp -> Mean[
         PropertyValue[{g, #}, VertexCoordinates] & /@ vl]]], 
    highstyle[Darker@Purple, {newp}, newedge]]}]

complexproc[g_] := 
  Block[{cycle, center}, 
   If[(cycle = FindCycle[Graph@EdgeList@g, {3}]) === {}, 
    If[(center = 
        SelectFirst[
         Thread[{VertexList@g, VertexDegree@g}], #[[2]] == 3 && 
           FreeQ[pt, #[[1]]] &]) === {}, {g, g}, 
     simplifybypoints[delhighlight@g, center[[1]]]], 
    simplifybycycle[delhighlight@g, cycle[[1]]]]];


allproc[g_] := 
  Grid[Select[
    Flatten[NestWhileList[
      Block[{res = simpleproc@#[[-1, -1]], res1}, 
        res1 = complexproc@res[[-1, -1]];
        Join[
         res, {res1, delline@delhighlight@res1[[-1]]}]] &, {delline@
        g}, ! SubsetQ[pt, VertexList@#[[-1, -1]]] &], 1], 
    Length@# == 2 && ! IsomorphicGraphQ[#[[1]], #[[2]]] &], 
   Spacings -> {5, 5}];

dynamicproc[g_] := 
 ListAnimate@
  Flatten[Select[
    Flatten[NestWhileList[
      Block[{res = simpleproc@#[[-1, -1]], res1}, 
        res1 = complexproc@res[[-1, -1]];
        Join[
         res, {res1, delline@delhighlight@res1[[-1]]}]] &, {delline@
        g}, ! SubsetQ[pt, VertexList@#[[-1, -1]]] &], 1], 
    Length@# == 2 && ! IsomorphicGraphQ[#[[1]], #[[2]]] &], 1]

then go on and see the simplification process by:

(*Grid form*)allproc@g
(*Animation form*)dynamicproc@g
Improve this answer
$\endgroup$
5
  • $\begingroup$ zhi chi yi ge. rep zhe me duo le a $\endgroup$
    – vapor
    Aug 22, 2016 at 13:10
  • $\begingroup$ :) xie xie zhi chi, zui jin you ji tian rep bao peng le, suo yi zhang de kuai ;) $\endgroup$
    – Wjx
    Aug 22, 2016 at 13:12
  • $\begingroup$ gao zhong sheng neng you zhe ge shui ping, li hai ya! $\endgroup$
    – xyz
    Aug 22, 2016 at 13:36
  • $\begingroup$ @ShutaoTang wei shen me hui tie li mian dou zai shuo han yu pin yin? $\endgroup$
    – Wjx
    Aug 22, 2016 at 14:19
  • $\begingroup$ xian shou cang le,you shi jian zai kan kan. :) $\endgroup$
    – yode
    Aug 22, 2016 at 17:57

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.