back to dc networks program description
back to dc networks page
terug naar dc netwerken pagina

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.