unit network_unit;
{
data and procedures to define and calculate a resistor network
using Kirchhoff's laws
}
interface
uses windows,graphics,classes,sysutils;
const maxelement = 30;
maxcontact = 60;
maxEC = maxElement + maxContact;
type TElementType = (etNone,etDelete,etWire,etResistor,etVoltage);
TS6 = string[6];
TElement = record
elType : TElementtype;
con1 : byte; //nr of interconnection
con2 : byte; //..
value : double; //Ohm, voltage
vtext : TS6;
end;
TContact = record
inUse : boolean;
x,y : smallInt;
end;
Tcircuit = record
ctIn,ctOut : byte; //entry contact
el : byte; //element
mult : shortInt; //1, -1 multiplier
end;
TVolt = record
ok : boolean;
v : double;
end;
var element : array[1..maxelement] of Telement;
elCount : byte;
contact : array[1..maxcontact] of TContact;
EQA : array[0..maxelement,1..maxEC] of double;
topEQA : byte;
circuit : array[1..maxContact] of Tcircuit;
ccLength: byte;
ECV : array[1..maxcontact] of dword; //element-contact-vector
CEF : array[1..maxcontact] of boolean;//contact enable flag
EEF : array[1..maxelement] of boolean;//element enable flag
CCOK : boolean; //circuit OK
CVA : array[1..maxcontact] of TVolt; //contact voltages
groundContact : byte;
procedure initData;
function registerElement(var ep : TElement; x1,y1,x2,y2 : smallInt) : byte;
procedure makeEQA;
procedure solveEQA;
implementation
uses debug_unit,result_unit;
procedure clearElement(n : byte);
begin
with element[n] do
begin
elType := etNone;
con1 := 0;
con2 := 0;
value := 0;
vtext := '';
end;
end;
procedure clearContact(n : byte);
begin
with contact[n] do
begin
inUse := false;
x := 0;
y := 0;
end;
end;
procedure clearVolt(n : byte);
begin
with CVA[n] do
begin
ok := false;
v := 0;
end;
end;
procedure initData;
var i : byte;
begin
elCount := 0;
for i := 1 to maxelement do clearElement(i);
for i := 1 to maxcontact do
begin
clearContact(i);
clearVolt(i);
end;
end;
function GetFreeContact : byte;
//there always is a free contact
begin
result := 1;
while (contact[result].inUse) do inc(result);
end;
function testExisting(const ep : TElement) : byte;
//result 0 : deleted
// 1 : replaced
var del,i,c1,c2 : byte;
ac : array[1..maxcontact] of boolean;
hit : boolean;
begin
i := 0;
hit := false;
while (hit=false) and (i < elCount) do
begin
inc(i);
c1 := element[i].con1;
c2 := element[i].con2;
hit := ((ep.con1 = c1) and (ep.con2 = c2)) or
((ep.con1 = c2) and (ep.con2 = c1));
end;
if hit then
begin
del := i;
if ep.elType = etDelete then //delete element
begin
result := 0;
for i := del to elCount-1 do element[i] := element[i+1];
clearElement(elCount);
dec(elCount);
for i := 1 to maxcontact do ac[i] := false;
for i := 1 to elCount do
begin
c1 := element[i].con1;
c2 := element[i].con2;
if c1 <> 0 then ac[c1] := true;
if c2 <> 0 then ac[c2] := true;
end;
for i := 1 to maxcontact do contact[i].inUse := ac[i];
end
else
with element[del] do //replace element
begin
result := 1;
elType := ep.elType;
value := ep.value;
vtext := ep.vtext;
end;
end
else result := 2;
end;
function registerElement(var ep : Telement; x1,y1,x2,y2 : smallInt) : byte;
//if existing : remove
//exit 0 : element deleted
// 1 : element replaced
// 2 : registered OK
// 3 : max elements reached
// 4 : fake delete
var ctNr : byte;
begin
result := testExisting(ep);
if result < 2 then exit;
//
if ep.elType = etDelete then
begin
result := 4;
exit;
end;
//
if elCount= maxElement then
begin
result := 3;
exit;
end;
//
inc(elCount);
element[elCount] := ep;
if ep.con1 = 0 then
begin
ctNr := getFreeContact;
element[elCount].con1 := ctNr;
contact[ctNr].x := x1;
contact[ctNr].y := y1;
contact[ctNr].inUse := true;
ep.con1 := ctNr; //report new contact
end else ep.con1 := 0;
if (ep.con2 = 0) then
begin
ctNr := getFreeContact;
element[elCount].con2 := ctNr;
contact[ctNr].x := x2;
contact[ctNr].y := y2;
contact[ctNr].inUse := true;
ep.con2 := ctNr; //report new contact
end else ep.con2 :=0;
element[elCount].value := ep.value;
element[elcount].vtext := ep.vtext;
result := 2;
end;
//---circuit procs
function GetNextFreeElement(var el:byte; ct:byte) : boolean;
//get next free element connected to contact ct
//drop contact and element enables
var n,conOut : byte;
begin
result := false;
n := el;
while (result = false) and (n < elCount) do
begin
inc(n);
result := EEF[n] and (((1 shl n) and ECV[ct]) > 0);
if result then
with element[n] do
begin
if con1 = ct then conOut := con2 else conOut := con1;
result := CEF[conOut];
end;
end;
if result then
with element[n] do
begin
EEF[n] := false;
CEF[con1] := false;
CEF[con2] := false;
el := n;
end;
end;
function findcircuit(fel : byte) : boolean;
//find shortest circuit starting at element el1
//move from contact to contact via elements
var i : byte;
node : array[1..maxElement] of TCircuit;
nn,nel : byte; //node nr
label nextNode,nextMove;
begin
result := false;
//preset CEF contact enable flag
for i := 1 to maxcontact do CEF[i] := false;
for i := 1 to elCount do
with element[i] do
begin
CEF[con1] := true;
CEF[con2] := true;
end;
//preset element enable flags
for i := 1 to maxElement do EEF[i] := i <= elcount;
//clear nodes
for i := 1 to maxElement do
with node[i] do //clear circuit
begin
ctIn := 0;
ctOut := 0;
el := 0;
mult := 1;
end;
//initialize
with node[1] do //set 1st node
begin
ctIn := element[fel].con1;
ctOut := element[fel].con2;
el := fel;
mult := 1;
CEF[ctOut] := false;
end;
EEF[fel] := false;
nn := 1;
//--------
nextNode:
inc(nn);
with node[nn] do
begin
ctIn := node[nn-1].ctOut;
el := 0;
end;
//
nextMove:
with node[nn] do
begin
nel := el;
if getNextFreeElement(nel,ctIn) then
begin //next free element found
if el > 0 then //test old element
begin
CEF[ctOut] := true; //free contact
EEF[el] := true; //free element
end;
el := nel;
if element[el].con1 = ctIn then
begin
ctOut := element[el].con2;
mult := 1;
end
else
begin
ctOut := element[el].con1;
mult := -1;
end;
if ctOut = node[1].ctIn then //check for circuit
begin
if (ccLength = 0) or (nn < ccLength) then
begin
for i := 1 to nn do circuit[i] := node[i];
ccLength := nn;
result := true;
end;
end
else goto nextNode; //no circuit
end;
end;//with
//
if nn >= 3 then
begin
with node[nn] do
begin
CEF[ctOut] := true;
EEF[el] := true;
end;
dec(nn);
goto nextMove;
end;
end;
procedure makeEQA;
//make equation array
var i,j,n,nr : byte;
mask : dword;
mlt : shortInt;
mf : boolean;
begin
//make ECV : bit set for element connected to contact
for j := 1 to maxcontact do ECV[j] := 0;
for i := 1 to elCount do
with element[i] do
begin
mask := 1 shl i;
ECV[con1] := ECV[con1] or mask;
ECV[con2] := ECV[con2] or mask;
end;
// clear EQA
for j := 1 to maxelement+maxcontact do
for i := 0 to maxElement do EQA[i,j] := 0;
topEQA := 0;
// Kirchhoff currents
for j := 1 to maxContact do
begin
nr := topEQA + 1;
mf := false;
for i := 1 to elCount do //Kirchhoff current
with element[i] do
begin
if j = con1 then begin
EQA[i,nr] := 1;
mf := true;
end;
if j = con2 then begin
EQA[i,nr] := -1;
mf := true;
end;
end;//for i
if mf then topEQA := nr;
end;//for j
// Kirchhoff voltages
for i := 1 to elCount do
begin
ccLength := 0;
if findCircuit(i) then
begin
inc(topEQA);
for j := 1 to ccLength do
begin
with circuit[j] do
begin
n := el;
mlt := mult;
end;
with element[n] do
begin
case eltype of
etResistor : EQA[n,topEQA] := mlt*value;
etVoltage : EQA[0,topEQA] := EQA[0,topEQA] + mlt*value;
end;//case
end;
end;//for j
end;//if find..
end;//for i
end;
procedure solveEQA;
var i,j,k,n,c1,c2 : byte;
HV,M,D : double;
nochange : boolean;
begin
//GaussJordan down
for i := 1 to elCount do
begin
n := i;
while (n <= topEQA) and (EQA[i,n] = 0) do inc(n);
if n <= topEQA then
begin
for k := 0 to elCount do
begin //swap rows i ....n
HV := EQA[k,i];
EQA[k,i] := EQA[k,n];
EQA[k,n] := HV;
end;
for j := i+1 to topEQA do
if EQA[i,j] <> 0 then
begin
M := EQA[i,j]/EQA[i,i];
EQA[i,j] := 0;
D := EQA[0,j] - M*EQA[0,i];
if abs(D) < 1E-12 then D := 0;
EQA[0,j] := D;
for k := i+1 to elCount do
begin
D := EQA[k,j] - M*EQA[k,i];
if abs(D) < 1E-12 then D := 0;
EQA[k,j] := D;
end;
end;
end;//if n
end;//for i
//Gauss Jordan up
for i := elCount downto 2 do
begin
n := topEQA;
while (n > 1) and (EQA[i,n] = 0) do dec(n);
if n > 1 then
for j := n-1 downto 1 do
if EQA[i,j] <> 0 then
begin
M := EQA[i,j]/EQA[i,n];
EQA[i,j] := 0;
D := EQA[0,j] - M*EQA[0,n];
if abs(D) < 1E-12 then D := 0;
EQA[0,j] := D;
for k := i-1 downto 1 do
begin
D := EQA[k,j] - M*EQA[k,n];
if abs(D) < 1E-12 then D := 0;
EQA[k,j] := D;
end;
end;
end;
//normalize
CCOK := true;
for i := 1 to elCount do
if EQA[i,i] <> 0 then
begin
EQA[0,i] := EQA[0,i] / EQA[i,i];
EQA[i,i] := 1;
end
else CCOK := false;
//short circuit check
if CCOK then
begin
i := elCount + 1;
while (i <= topEQA) and CCOK do
begin
CCOK := EQA[0,i] = 0;
inc(i);
end;
end;
//voltage list CVA
for i := 1 to maxcontact do
with CVA[i] do
begin
ok := false;
v := 0;
end;
if CCOK and (groundContact > 0) then
begin
CVA[groundcontact].ok := true;
CVA[groundcontact].v := 0;
repeat
nochange := true;
for n := 1 to elCount do
begin
with element[n] do
begin
c1 := con1;
c2 := con2;
end;
if (CVA[c1].ok) and (CVA[c2].ok = false) then
begin
nochange := false;
CVA[c2].ok := true;
case element[n].elType of
etwire : CVA[c2].v := CVA[c1].v;
etResistor : CVA[c2].v := CVA[c1].v + EQA[0,n]*element[n].value;
etVoltage : CVA[c2].v := CVA[c1].v - element[n].value;
end;//case
end;
if (CVA[c2].ok) and (CVA[c1].ok = false) then
begin
nochange := false;
CVA[c1].ok := true;
case element[n].elType of
etwire : CVA[c1].v := CVA[c2].v;
etResistor : CVA[c1].v := CVA[c2].v - EQA[0,n]*element[n].value;
etVoltage : CVA[c1].v := CVA[c2].v + element[n].value;
end;//case
end;
end;//for n
until nochange;
end;//if CCOK
end;
end.
