88 lines
2.7 KiB
Perl
88 lines
2.7 KiB
Perl
#!/usr/bin/perl
|
|
|
|
use strict; # https://rosettacode.org/wiki/Four_bit_adder
|
|
use warnings;
|
|
use List::Util qw( any reduce uniq );
|
|
|
|
my $circuit = @ARGV ? join '', <> : <<END;
|
|
define xor a b => a^b # internal test/demo circuit
|
|
not a => !a # from https://rosettacode.org/wiki/Four_bit_adder
|
|
not b => !b
|
|
and !a b => !a&b
|
|
and a !b => a&!b
|
|
or !a&b a&!b => a^b
|
|
|
|
define half_adder a b => carry sum
|
|
xor a b => sum
|
|
and a b => carry
|
|
|
|
define full_adder a b Cin => Cout sum
|
|
half_adder a Cin => c1 s1
|
|
half_adder s1 b => c2 sum
|
|
or c1 c2 => Cout
|
|
|
|
define Four_bit_adder a3 a2 a1 a0 b3 b2 b1 b0 => ovfl s3 s2 s1 s0
|
|
full_adder a0 b0 0 => c0 s0
|
|
full_adder a1 b1 c0 => c1 s1
|
|
full_adder a2 b2 c1 => c2 s2
|
|
full_adder a3 b3 c2 => ovfl s3
|
|
|
|
Four_bit_adder 0 ? ? ? 1 0 1 1 => carry s3 s2 s1 s0
|
|
END
|
|
our %values;
|
|
my (%blocks, @ranges);
|
|
|
|
sub parseline
|
|
{
|
|
$_[0] =~ /=>/ or die "parseline failed for '@_'\n";
|
|
my ($name, @in) = split ' ', $`;
|
|
return $name, \@in, [ uniq split ' ', $' ];
|
|
}
|
|
|
|
sub simulate
|
|
{
|
|
my ($name, $in, $out) = parseline @_;
|
|
my @inputs = map { /^[01]$/ ? $_ :
|
|
$values{$_} // die "undefined name '$_' in '@_'\n" } @$in;
|
|
my @outputs;
|
|
if( $name eq 'and' ) { @outputs = (any { !$_ } @inputs) ? 0 : 1 }
|
|
elsif( $name eq 'or' ) { @outputs = (any { $_ } @inputs) ? 1 : 0 }
|
|
elsif( $name eq 'not' ) { @outputs = reduce { $a ^ $b } 1, @inputs }
|
|
elsif( my $block = $blocks{$name} )
|
|
{
|
|
local %values;
|
|
@values{ $block->{in}->@* } = @inputs;
|
|
simulate( $_ ) for $block->{body}->@*;
|
|
@outputs = map { $values{$_} // die "undefined name '$_' in '$name'\n" }
|
|
$block->{out}->@*;
|
|
}
|
|
else { die "unknown block name '$name'\n" }
|
|
@values{ @$out } = @outputs;
|
|
}
|
|
|
|
sub many { map { /(?<=\h)\?(?=\h.*=>)/ ? many("$`0$'", "$`1$'") : $_ } @_ }
|
|
|
|
print '-' x 40, " CIRCUIT:\n\n$circuit\n";
|
|
s/#.*//g for $circuit; # remove comments
|
|
$circuit =~ s/^define\h(.*)\n((?:(?!define\h).*=>.*\n)+)/ # find the defines
|
|
my @body = split m<\n>, $2;
|
|
my ($name, $in, $out) = parseline $1;
|
|
$blocks{$name} = { in => $in, out => $out, body => \@body };
|
|
'' /gme;
|
|
$circuit =~ s/^.*\h\?\h.*=>.*/ push @ranges, $&; '' /gme;
|
|
$circuit =~ s/^(?!.*=>).*\n//gm; # clear out lines without =>
|
|
simulate $_ for split /\n/, $circuit;
|
|
my @values = map { sprintf '%*s', length, $values{$_} // '' } my @names =
|
|
map { split } $circuit =~ /=>(.*)/gm;
|
|
@names and print '-' x 40, " OUTPUT:\n\n@names\n@values\n\n";
|
|
|
|
for ( many @ranges )
|
|
{
|
|
simulate $_;
|
|
my @values = map { sprintf '%*s', length, $values{$_} // '' } my @names =
|
|
map { split } /=>(.*)/;
|
|
my $over = (my $base = s/=>\K.*//r) =~ tr/\t/ /cr;
|
|
my $name = (split)[0];
|
|
print '-' x 79, "\n$base @names\n$over @values\n";
|
|
}
|
|
#use Data::Dump 'dd'; dd { blocks => \%blocks };
|