$ cat attenuator_pad.pl
#!env perl
#
# attenuator_pad.pl
#
# Resistive attenuator pads are supposed to decrease the
# amount of signal through them, and provide a specific
# input and # output impedance.
#
# They're often chained together, which strikes me as a
# bit weird, so I'm gonna put together a toy program to
# chain them together and compute the input impedance,
# just to verify to myself that they present the expected
# impedance.  I *know* they do, I just don't feel it now.
#
# I'm just gonna use Pi pads, as they're the ones I'm
# going to use first.  They're built like:
#
#   o--+--\/\/\/--+--o    dB   Ra   Rb
#      |    Ra    |       --  ---  ---
#      >          >        3   18  300
#  Zi  > Rb    Rb >  Zo    6   35  150
#      >          >       10   75  100
#      |          |       20  270   68
#   o--+----------+---o
#
# I'll build the circuits as graphs, and then just apply
# some trivial simplifications repeatedly until there's
# just a single impedance left.
#
# NOTE: Simplifier won't delete a named node, so be sure
# to delete node names you don't care about before you
# simplify the graph.
#
# 20181013 Works: as expected, we get about 50 ohms.
#
use v5.20;
use strict;
use warnings;
use Data::Dump 'pp';

# The Pi pad configurations I'll be using.
my %pi_pad_xlat = (
     3 => { Ra=> 18, Rb=>300 },
     6 => { Ra=> 35, Rb=>150 },
    10 => { Ra=> 75, Rb=>100 },
    20 => { Ra=>270, Rb=> 68 },
);

##########
star_bar("10dB Attenuator terminated w/ 50 ohms");

my $atten = build_pad(10);
$atten->dump("10dB Pad");

my $term = build_impedance(50);
$term->dump("50 ohm terminator");

my $g = $atten->attach($term, [qw( out_pos in_pos )], [qw( out_neg in_
+neg )]);
$g->_keep_only_names(qw( in_pos in_neg ));
$g->dump("10dB Pad + terminator");

my $h = $g->simplify();
$h->dump("Simplified network");


##########
star_bar("Two pads cascaded and terminated");

# Reset node IDs for simpler comparison with my notes
node(0);

$atten = build_pad(10);
$atten->dump("PAD 10dB");

my $atten2 = build_pad(20);
$atten2->dump("PAD 20dB");

$term = build_impedance(50);
$term->dump("TERM 50ohm");

$g = $atten2->attach($term, [qw( out_pos in_pos )], [qw( out_neg in_ne
+g )]);
delete $g->{nodes}{out_neg};
delete $g->{nodes}{out_pos};
$g->dump("PAD 20dB + TERM 50ohm");

$h = $atten->attach($atten2, [qw( out_pos in_pos )], [qw( out_neg in_n
+eg )]);
delete $h->{nodes}{out_neg};
delete $h->{nodes}{out_pos};
$h->dump("PAD 10dB + PAD 20dB + TERM 50ohm");

my $i = $h->simplify();
$i->dump("RESULT!");

#---------------------------------------------------------------------
+--
# Miscellaneous stuff
#---------------------------------------------------------------------
+--

sub star_bar {
    my $msg = shift;
    print "\n", "*" x 80, "\n";
    if (defined $msg) {
        print $msg, "\n", "*" x 80, "\n";
    }
}

sub build_impedance {
    my $ohms = shift;

    # in sort order for clarity when printing
    my ($in_neg, $in_pos) = (node(), node());
    my $rv = {
        nodes => { in_pos=>$in_pos, in_neg=>$in_neg },
        edges => [ [ $in_pos, $in_neg, $ohms ] ],
    };
    return bless $rv, "Gr";
}

sub build_pad {
    my $dB = shift;
    die "Can't build pi-pad for $dB dB!" unless exists $pi_pad_xlat{$d
+B};

    # in sort order for clarity when printing
    my ($in_neg, $in_pos, $out_neg, $out_pos) = (node(), node(), node(
+), node());
    my $rv = {
        nodes => {
            in_pos=>$in_pos, in_neg=>$in_neg, out_pos=>$out_pos, out_n
+eg=>$out_neg
        },
        edges => [
            [ $in_pos,  $in_neg,  $pi_pad_xlat{$dB}{Rb} ],
            [ $in_pos,  $out_pos, $pi_pad_xlat{$dB}{Ra} ],
            [ $in_neg,  $out_neg, 0.05 ],
            [ $out_pos, $out_neg, $pi_pad_xlat{$dB}{Rb} ],
        ],
    };
    return bless $rv, "Gr";
}

# Fetch a new node ID (passing in a value resets the ID sequence to th
+e value)
sub node {
    state $new_node_ID;
    my $arg = shift;
    if (defined $arg) {
        $new_node_ID = $arg;
    }
    else {
        ++$new_node_ID;
    }
    return $new_node_ID;
    return $new_node_ID;
}

#---------------------------------------------------------------------
+--
# some simple graph operations
#---------------------------------------------------------------------
+--

package Gr;

use Data::Dump 'pp';

# Attach graph A to graph B returning a new graph C.  The user provide
+s an alias
# list where each alias is a pair of node names [ grA(node name), grB(
+node name) ],
# The resulting graph C will have all named nodes in A as well as all 
+the nodes
# in B except for the aliased ones.  The edges will be the combination
+ of all edges
# in A and B.  To handle aliasing, the ID for all named nodes in B wil
+l be replaced
# with the ID from the aliasing nodes in A.
#
# Ex:
#   grA={ n:[a=1,b=2,c=3], e:[ [1,2,t], [2,3,u], [1,3,v] ]}
#   grB={ n:[x=7,y=8,z=9], e:[ [7,8,p], [7,9,q] ] }
#
#   grC = attach(grA, grB, [a,x], [b,z])
#
#   grC={ n:[a=1,b=2,c=3,y=8], e:[ [1,2,t], [2,3,u], [1,3,v], [1,8,p],
+ [1,2,q] ]}
#
sub attach {
    my ($gA, $gB, @alias_list) = @_;
    die "Expected attach(rGr, rGr, alias_list)!"
        unless "Gr" eq ref $gA and "Gr" eq ref $gB;

    # The result will consist of everything in A, plus appropriate edi
+ts of B
    my $rv = { %$gA };

    # Edges to edit
    my @B_edges = @{$gB->{edges}};
    my %B_nodes = %{$gB->{nodes}};

    for my $rAlias (@alias_list) {
        die "Each alias must be an array of node names in graphs A and
+ B"
        unless "ARRAY" eq ref $rAlias;

        my ($nA, $nB) = @$rAlias;
        die "Node $nA DNE in graph A!" unless exists $gA->{nodes}{$nA}
+;
        die "Node $nB DNE in graph B!" unless exists $gB->{nodes}{$nB}
+;

        my $A_nID = $gA->{nodes}{$nA};
        my $B_nID = $gB->{nodes}{$nB};

        # Remove node name from B if aliased, so it's not in the outpu
+t
        delete $B_nodes{$nB} if exists $B_nodes{$nB};

        # Alias all the edges and add them to the resulting graph
        for my $rEdge (@B_edges) {
            $rEdge->[0]=$A_nID if $rEdge->[0] == $B_nID;
            $rEdge->[1]=$A_nID if $rEdge->[1] == $B_nID;
        }
    }
    push @{$rv->{edges}}, @B_edges;

    # Finally, add all the unused node names in B to the output graph 
+(rename
    # them with an _B suffix if the name is already in use)
    for my $nB (keys %{$gB->{nodes}}) {
        next if ! exists $B_nodes{$nB};
        my $new_name_B = $nB . (exists $gA->{nodes}{$nB} ? "_B" : "");
        $rv->{nodes}{$new_name_B} = $gB->{nodes}{$nB};
    }

    return bless $rv, "Gr";
}

# Brief/somewhat readable dump to the
sub dump {
    my ($r, $msg) = @_;

    my $hdr = "";
    if (defined $msg) {
        print $msg, "\n";
        $hdr = "   ";
    }

    print "${hdr}N: ";
    print "$_($r->{nodes}{$_}) " for sort keys %{$r->{nodes}};

    my @tmp =   map { "($_->[0] $_->[1] $_->[2])" }
                sort { $a->[0] <=> $b->[0]
                       or $a->[1] <=> $b->[1]
                       or $a->[2] <=> $b->[2]
                } @{$r->{edges}};
    print "\n$hdr", join(", ", @tmp), "\n\n";
}

# Remove all named nodes other than those listed
sub _keep_only_names {
    my $gr = shift;
    my %keep = map { $_=>1 } @_;
    delete $gr->{nodes}{$_} for grep { ! exists $keep{$_} }
                                keys %{$gr->{nodes}};
}

# Merge nodes that are shorted together (i.e. no resistance)
sub _merge_shorted_nodes {
    my $self = shift;
    my %tmpN = %{$self->{nodes}};
    my @tmpE = @{$self->{edges}};
    my $DBG = $self->{dbg};

    # Merge/Remap node IDs that are shorted
    my %remap = map { $_->[0], $_->[0], $_->[1], $_->[1] } @tmpE;
    my @tmp = grep { $_->[2] == 0 } @tmpE;
    if (@tmp) {
        $DBG && do {
            print "Gr:_msn: ", scalar(@tmp), " node merges (0 resistan
+ce)\n";
            print "  ", pp(\@tmp), "\n";
        };
        ++$self->{CHGS};

        # Build the remap updates and update the node names
        $remap{$_->[1]} = $_->[0] for @tmp;
        $tmpN{$_}=$remap{$tmpN{$_}} for keys %tmpN;

        $DBG && print "  Remap: ", pp(\%remap), "\n";
    }

    # Delete self-loops (src==dest)
    # NOTE: We use a temp array with the remapping so we don't have to
+ build it twice
    my @tmp2 = map { [ @$_, $remap{$_->[0]}, $remap{$_->[1]} ] } @tmpE
+;
    ###print "X: ", pp(\@tmp2), "\n";
    @tmp = grep { $_->[3] == $_->[4] } @tmp2;
    ###print "Y: ", pp(\@tmp), "\n";
    if (@tmp) {
        $DBG && do {
            print "Gr:_msn: ", scalar(@tmp), " self-loops removed\n";
            print "  ", pp(\@tmp), "\n";
        };
        ++$self->{CHGS};

        # OK, we have some self loops, remove them!
        @tmpE = map { [ $_->[3], $_->[4], $_->[2] ] }
                grep { $_->[3] != $_->[4] }
                @tmp2;
    }

    $self->{nodes} = \%tmpN;
    $self->{edges} = \@tmpE;
}

# Reorder src/dst for resistors to simplify code in general.
# Resistors don't care!
sub _sort_edges {
    my $rGr = shift;
    for my $e (@{$rGr->{edges}}) {
        ($e->[0], $e->[1]) = ($e->[1], $e->[0]) if $e->[0] > $e->[1];
    }
}

# I don't really care about very small resistances, so convert them
# to shorts to further simplify the network if they appear
sub _short_resistors_less_than {
    my ($rGr, $ohms) = @_;
    for my $e (@{$rGr->{edges}}) {
        $e->[2]=0 if $e->[2] < $ohms;
    }
}

# Replace multiple resistances between the same nodes with their
# parallel equivalent:
#
#       1           1        1               1
#     -----   =   ------ + ------ + .... + ------
#      Req         R(1)     R(2)            R(n)
#
sub _reduce_parallel_resistors {
    my $gr = shift;

    #print "REDUCE PARALLEL:\n";

    my %cnx;
    $cnx{$_->[0]}{$_->[1]}++ for @{$gr->{edges}};

    # If we have any entries with a count greater than one, we've foun
+d a set of parallel
    # resistors that we can crunch
    for my $src (keys %cnx) {
        for my $dst (keys %{$cnx{$src}}) {
            next unless $cnx{$src}{$dst} > 1;
            ++$gr->{CHGS};
            #print "    $src--$dst has $gr->{CNX}{$src}{$dst} resistan
+ces in parallel\n";

            my @tmp = grep { $_->[0]==$src and $_->[1]==$dst } @{$gr->
+{edges}};
            #print pp(\@tmp), "\n\n";
            my $recip_R = 0;
            $recip_R += 1 / $_->[2] for @tmp;
            my $R = sprintf "%.1f", 1 / $recip_R;
            #print "New resistance = $R\n";

            # Filter out all the parallel resistors, and add the new o
+ne
            $gr->{edges} = [ grep { $_->[0]!=$src or $_->[1]!=$dst } @
+{$gr->{edges}} ];
            push @{$gr->{edges}}, [ $src, $dst, $R+0 ];
        }
    }
    #print "EOParallel\n";
}

# Replace two resistors in series with the equivalent series resistanc
+e:
#
#   Req = R(1) + R(2)
#
# This routine doesn't try to find chains of more than two resistors.
# Instead we rely on the fact that we're looping over the simplificati
+ons
# anyway, and multiple loops will successively crunch through the chai
+n.
sub _reduce_series_resistors {
    my $gr = shift;
    #print "SERIES:\n";

    my %named = map { $gr->{nodes}{$_}=>1 } keys %{$gr->{nodes}};
    my %in;
    for my $E (@{$gr->{edges}}) {
        my ($src,$dst) = @$E;
        ++$in{$src}; ++$in{$dst};
    }

    # We have a reducible series resistor combination if we find an un
+named node
    # with two connections to it
    my @candidates =    grep { $in{$_} == 2 }
                        grep { ! $named{$_} }
                        keys %in;
    #print "  Candidates: ", pp(\@candidates), "\n";

    if (@candidates) {
        # Note: a series strand of resistors won't be handled correctl
+y by this
        # routine right now.  I'm simplifying it by just shortening th
+e first
        # one I see.  Since we execute the whole thing in a loop, it'l
+l just take
        # a few iterations to chew through 'em.
        my $id = shift @candidates;
        ++$gr->{CHGS};

        # Fetch the involved edges
        my @tmp = grep { $_->[0]==$id or $_->[1]==$id } @{$gr->{edges}
+};
        die "Eh?" unless 2 == @tmp;

        # Compute the series resistance:
        my $R = $tmp[0][2] + $tmp[1][2];

        # Fetch the src & dst nodes: The src & dest are unique, and th
+e id is in
        # the list twice.  So by getting all four node IDs, removing t
+he ones
        # matching $id and sorting 'em, we get the desired $src and $d
+st ids
        my ($src,$dst) = sort { $a <=> $b }
                         grep { $_ != $id }
                         map { $_->[0], $_->[1] }
                         @tmp;

        # Now remove the series resistor pair and add the replacement
        $gr->{edges} = [ grep { ! ($_->[0]==$id or $_->[1] ==$id) } @{
+$gr->{edges}} ];

        push @{$gr->{edges}}, [ $src, $dst, $R ];
    }
}

# Simplify the graph: Merge shorted nodes, combine series and
# parallel resistors.  Keep doing it in a loop until we detect
# no changes.
sub simplify {
    my $rGr = shift;

    #$rGr->dump("**** SIMPLIFY INPUT ****");
    #$rGr->{DBG}=1;

    # We call functions that modify the underlying graph (names beginn
+ing
    # with an underscore), so build a clone of our graph before whacki
+ng it.
    my $ngr = { %$rGr };
    bless $ngr, "Gr";

    # Order resistance edges by ID order.  It'll simplify the code, an
+d the
    # resistors don't care anyway.
    $ngr->_sort_edges();

    my $loop_cnt = 0;
    my $chgs = 1;
    while ($chgs) {
        ++$loop_cnt;
        $ngr->{DBG} && print "simplify $loop_cnt ***\n";

        die if $loop_cnt>10;

        $chgs = $ngr->{CHGS}=0;

        # For now, assume resistance less than 0.1ohms is a short
        $ngr->_short_resistors_less_than(0.1);

        $ngr->_merge_shorted_nodes();

        #print "A: chgs $chgs, NGR chgs? $ngr->{CHGS}\n";
        $chgs += $ngr->{CHGS};
        $ngr->{CHGS}=0;

        # Handles to our graph data
        my $tmpN = $ngr->{nodes};
        my $tmpE = $ngr->{edges};

        $ngr->_reduce_parallel_resistors();
        #print "B: chgs $chgs, NGR chgs? $ngr->{CHGS}\n";
        $chgs += $ngr->{CHGS};
        $ngr->{CHGS}=0;

        $ngr->_reduce_series_resistors();
        #print "C: chgs $chgs, NGR chgs? $ngr->{CHGS}\n";
        $chgs += $ngr->{CHGS};
        $ngr->{CHGS}=0;
    }

    return $ngr;
}
[download]