X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FNary.pm;h=14b882285723a2e3d20bbb7472c8502df1166d8a;hb=3b10ab9a7a01f579892a98a1ffc53202d6adc8d6;hp=6dc1820a15ae53e3b170fbbb64ebf2f0d9e1f7f8;hpb=2edec20dc456a6756846bbac264a99b9d6892848;p=perl%2Fmodules%2FSub-Nary.git diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index 6dc1820..14b8822 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -6,7 +6,6 @@ use strict; use warnings; use Carp qw/croak/; -use List::Util qw/reduce/; use B qw/class ppname svref_2object OPf_KIDS/; @@ -178,41 +177,6 @@ sub name ($) { $n eq 'null' ? substr(ppname($_[0]->targ), 3) : $n } -sub normalize ($) { - my $r = $_[0]; - return unless defined $r; - return { 0 => 1 } unless keys %$r; - my $total = count $r; - return { map { $_ => $r->{$_} / $total } keys %$r }; -} - -sub scale { - my ($c, $r) = @_; - return unless defined $r; - return (ref $r) ? { map { $_ => $r->{$_} * $c } keys %$r } : { $r => $c }; -} - -sub combine { - reduce {{ - my %res; - my $la = delete $a->{list}; - my $lb = delete $b->{list}; - if (defined $la || defined $lb) { - $la ||= 0; - $lb ||= 0; - $res{list} = $la + $lb - $la * $lb; - } - while (my ($ka, $va) = each %$a) { - $ka = int $ka; - while (my ($kb, $vb) = each %$b) { - my $key = $ka + int $kb; - $res{$key} += $va * $vb; - } - } - \%res - }} map { (ref) ? $_ : { $_ => 1 } } grep defined, @_; -} - sub power { my ($p, $n, $c) = @_; return unless defined $p; @@ -228,13 +192,6 @@ sub power { return $r; } -sub add { - reduce { - $a->{$_} += $b->{$_} for keys %$b; - $a - } map { (ref) ? $_ : { $_ => 1 } } grep defined, @_; -} - my %ops; $ops{$_} = 1 for scalops; @@ -316,7 +273,7 @@ sub inspect { if (null $op) { # If the logop has no else branch, it can also return the *scalar* result of # the conditional - $l3 = { 1 => $c }; + $l3 = { 1 => 1 }; } else { ($r3, $l3) = $self->inspect($op); } @@ -354,18 +311,20 @@ sub inspect_kids { $op = $op->first; redo; } - diag "> $n ($c)" if $DEBUG; + diag "> $n" if $DEBUG; my ($rc, $lc) = $self->inspect($op); + $c = 1 - count $r; + diag Dumper [ $c, $r, \@l, $rc, $lc ] if $DEBUG; $r = add $r, scale $c, $rc if defined $rc; - if ($rc and not defined $lc) { + if (not defined $lc) { @l = (); last; } push @l, scale $c, $lc; - $c *= count $lc if defined $lc; } - my $l = combine @l; +# diag Dumper \@l if $DEBUG; + my $l = scale +(1 - count $r), normalize combine @l; return $r, $l; } @@ -481,7 +440,7 @@ sub pp_const { if ($c eq 'AV') { $n = $sv->FILL + 1 } elsif ($c eq 'HV') { - $n = 2 * $sv->FILL + $n = 2 * $sv->KEYS } return undef, $n @@ -525,16 +484,32 @@ sub pp_leaveloop { $op = $op->first; my ($r1, $l1); - if (name($op) eq 'enteriter') { + my $for; + if (name($op) eq 'enteriter') { # for loop ? + $for = 1; ($r1, $l1) = $self->inspect($op); - return $r1, $l1 if $r1 and zero $l1; + return $r1, $l1 if defined $r1 and zero $l1; } $op = $op->sibling; - my $r = (name($op->first) eq 'and') ? ($self->inspect($op->first->first->sibling))[0] - : ($self->inspect($op))[0]; + my ($r2, $l2); + if (name($op->first) eq 'and') { + ($r2, $l2) = $self->inspect($op->first->first); + return $r2, $l2 if defined $r2 and zero $l2; + my $c = count $l2; + return { list => 1 }, undef if !$for and defined $r2; + my ($r3, $l3) = $self->inspect($op->first->first->sibling); + return { list => 1 }, undef if defined $r3 and defined $l3; + $r2 = add $r2, scale $c, $r3; + } else { + ($r2, $l2) = $self->inspect($op); + return { list => 1 }, undef if defined $r2 and defined $l2; + } + + my $r = (defined $r1) ? add $r1, scale +(1 - count $r1), $r2 + : $r2; my $c = 1 - count $r; - diag "& leaveloop" if $DEBUG; + diag "& leaveloop $c" if $DEBUG; return $r, $c ? { 0 => $c } : undef; } @@ -565,7 +540,7 @@ sub pp_flip { } my $c = 1 - count $r; - return $r, ($l && $c) ? { 'list' => $c } : undef + return $r, $c ? { 'list' => $c } : undef } sub pp_grepwhile { @@ -577,19 +552,18 @@ sub pp_grepwhile { my ($r2, $l2) = $self->inspect($op->sibling); return $r2, $l2 if $r2 and zero $l2; - diag Dumper [ $r2, $l2 ] if $DEBUG; - my $c = count $l2; # First one to happen + my $c2 = count $l2; # First one to happen my ($r1, $l1) = $self->inspect($op); - diag Dumper [ $r1, $l1 ] if $DEBUG; - return (add $r2, scale $c, $r1), undef if $r1 and zero $l1 and not zero $l2; - return { 'list' => 1 }, undef if list $l2; + return (add $r2, scale $c2, $r1), undef if $r1 and zero $l1 and not zero $l2; + diag Dumper [ [ $r1, $l1 ], [ $r2, $l2 ] ] if $DEBUG; + my $c1 = count $l1; $l2 = { $l2 => 1 } unless ref $l2; - my $r = add $r2, scale $c, - normalize - add map { power $r1, $_, $l2->{$_} } keys %$l2; - $c = 1 - count $r; + my $r = add $r2, + scale $c2, + add map { scale $l2->{$_}, cumulate $r1, $_, $c1 } keys %$l2; + my $c = 1 - count $r; return $r, $c ? { ((zero $l2) ? 0 : 'list') => $c } : undef; } @@ -602,17 +576,18 @@ sub pp_mapwhile { my ($r2, $l2) = $self->inspect($op->sibling); return $r2, $l2 if $r2 and zero $l2; - my $c = count $l2; # First one to happen + my $c2 = count $l2; # First one to happen my ($r1, $l1) = $self->inspect($op); - return (add $r2, scale $c, $r1), undef if $r1 and zero $l1 and not zero $l2; + return (add $r2, scale $c2, $r1), undef if $r1 and zero $l1 and not zero $l2; diag Dumper [ [ $r1, $l1 ], [ $r2, $l2 ] ] if $DEBUG; + my $c1 = count $l1; $l2 = { $l2 => 1 } unless ref $l2; - my $r = add $r2, scale $c, - normalize - add map { power $r1, $_, $l2->{$_} } keys %$l2; - $c = 1 - count $r; + my $r = add $r2, + scale $c2, + add map { scale $l2->{$_}, cumulate $r1, $_, $c1 } keys %$l2; + my $c = 1 - count $r; my $l = scale $c, normalize add map { power $l1, $_, $l2->{$_} } keys %$l2; return $r, $l; } @@ -631,7 +606,7 @@ C isn't specialized when encountered in the optree. L 5.8.1. -L (standard since perl 5), L (since perl 5.005), L (since perl 5.006) and L (since perl 5.007003). +L (standard since perl 5), L (since perl 5.005) and L (since perl 5.006). =head1 AUTHOR