I have a sub named "lookup" which does a lookup in a hash for a given value.
I realized it would be much more powerful if I can ask it to look not for a given value, but a value smaller than the one passed as a parameter.
I could make lookupbigger, lookupsmall.. etc, but I am sure there is a better way.
# lookup id according to the search criteria
sub lookup {
my( $data, $lk, $lv ) = ( #_ );
my #res;
foreach my $key (keys $data) {
my $value = $$data{$key};
next unless( defined $$value{$lk} );
# this is the line where I want to replace eq with another operator
push(#res, $key) if( $$value{$lk} eq $lv );
}
return \#res;
}
You can pass a criterion function to your lookup function:
#!/usr/bin/env perl
use strict; use warnings;
use YAML;
my %hash = qw(a 1 b 2 c 3 d 4 e 5);
# find all keys with odd values
print Dump lookup_keys_by_value(\%hash, sub {
return unless #_;
my $v = shift;
return $v % 2;
},
);
sub lookup_keys_by_value {
my ($hash, $criterion) = #_;
my #keys;
while (my ($k, $v) = each %$hash) {
push #keys, $k if $criterion->($v);
}
return \#keys;
}
Here's an idea (perhaps too "clever"):
use strict;
use warnings;
{ no strict 'refs';
# When called like __PACKAGE__->$op( ... ), __PACKAGE__ is $_[0]
*{'>'} = sub { return $_[1] > $_[2]; };
*{'<'} = sub { return $_[1] < $_[2]; };
*{'=='} = sub { return $_[1] == $_[2]; };
}
sub determine {
my ( $first_arg, $op, $second_arg )
= map { s/^\s+//; s/\s+$//; $_ }
split( /\s*([<>]|==)\s*/, #_ == 1 ? shift : "#_" )
;
say "$first_arg $op $second_arg => "
. ( __PACKAGE__->$op( $first_arg, $second_arg ) ? 'TRUE' : 'FALSE' )
;
}
determine( qw( 1 < 2 ) );
determine( qw( 2 < 1 ) );
determine( qw( 1 > 2 ) );
determine( qw( 2 > 1 ) );
determine( qw( 1 == 2 ) );
determine( qw( 1 == 1 ) );
determine( qw( 2 == 2 ) );
determine( ' 1 < 2 ' );
determine( ' 2 < 1 ' );
determine( ' 1 > 2 ' );
determine( ' 2 > 1 ' );
determine( ' 1 == 2 ' );
determine( ' 1 == 1 ' );
determine( ' 2 == 2 ' );
You could try to use overload
use overload (
'>' => 'compareBigger',
'<' => 'compareSmaller',
'==' => 'equals'
)
Related
I can slice kes/values as next:
$item->%{ #cols }
But if some column does not exist at $item It will be created at resulting hash.
Can I slice only defined values?
You can check whether they exist.
$item->%{ grep {exists $item->{$_}} #cols }
should do the job slicing only the existing values.
Anyway - simply accessing these values should NOT autovivify them. Only if you Pass these values as parameters to some function and they are implicetly aliased there, they are autovivified.
use strict;
use warnings;
use Data::Dumper;
my #cols =qw (a b c);
my $item = [{a => 1, c => 3}];
print Dumper({$item->[0]->%{ grep {exists $item->[0]->{$_}} #cols }});
print Dumper($item);
print Dumper({$item->[0]->%{ #cols }});
print Dumper($item);
print Dumper($item->[0]->%{ grep {exists $item->[0]->{$_}} #cols });
print Dumper($item);
print Dumper($item->[0]->%{ #cols }); ## Only here does autovivication take place
print Dumper($item);
Only the last print will generate the:
$VAR1 = [
{
'c' => 3,
'a' => 1,
'b' => undef
}
];
indicating that b got autovivified.
Use
$item->%{ grep { exists($item->{$_}) } #cols }
or
do { $item->%{ #cols } }
Indexing/slicing a hash does not add elements to it.
my #cols = qw( a b c );
my $item = { };
say 0+%$item; # 0
my #kvs = $item->%{ #cols };
say 0+%$item; # 0 ok
Except when it's used as an lvalue (assignable value, such as when on the left-hand side of =).
my #cols = qw( a b c );
my $item = { };
say 0+%$item; # 0
1 for $item->%{ #cols };
say 0+%$item; # 3 XXX
You could filter out the keys of elements that don't exist.
my #cols = qw( a b c );
my $item = { };
say 0+%$item; # 0
1 for $item->%{ grep { exists($item->{$_}) } #cols };
say 0+%$item; # 0 ok
But the simple solution is to not use it as an lvalue.
my #cols = qw( a b c );
my $item = { };
say 0+%$item; # 0
1 for do { $item->%{ #cols } };
say 0+%$item; # 0 ok
Several dumpers exist that can show the names of variables without requiring the programmer to explicitely repeat the name.
› perl -MData::Dumper::Simple -e'my $foo = 42; print Dumper($foo)'
$foo = 42;
The trickery is a source filter (breaks often).
› perl -MDDS -e'my $foo = 42; DumpLex $foo'
$foo = 42;
The trickery is PadWalker.
They also work to some extent with variables of other types, but slices or other complex expressions are problematic.
Which modern (post-5.10) trickery can be leveraged to make the following example dumper (as in: data structure viewer, not eval-able code producer) work? The point of emphasis is to always print nice names, to accept multiple expressions, and no need for changing expressions with an extra reference level.
use 5.020; use Syntax::Construct qw(%slice);
use strictures;
use Acme::Hypothetical::Dumper 'd';
my %foo = (
Me => 'person',
You => 'beloved one',
Them => 'space aliens',
);
d %foo, $foo{'Me'}, #foo{qw(You Me)}, %foo{qw(You Me)};
# %foo = ('Me' => 'person', 'Them' => 'space aliens', 'You' => 'beloved one');
# $foo{'Me'} = 'person';
# #foo{qw(You Me)} = ('beloved one', 'person');
# %foo{qw(You Me)} = ('Me' => 'person', 'You' => 'beloved one');
my #bar = qw(Me You Them);
d #bar, $bar[0], #bar[2, 1], %bar[2, 1];
# #bar = ('Me', 'You', 'Them');
# $bar[0] = 'Me';
# #bar[2, 1] = ('Them', 'You');
# %bar[2, 1] = (2 => 'Them', 1 => 'You');
use LWP::UserAgent qw();
my $ua = LWP::UserAgent->new;
d $ua->{ssl_opts}{verify_hostname};
# $ua->{ssl_opts}{verify_hostname} = 1;
Whitespace in the output doesn't perfectly match your examples, but this is pretty close...
use v5.14;
use strict;
use warnings;
BEGIN {
package Acme::Hypothetical::Dumper;
use Keyword::Simple;
use PPR;
use Data::Dumper;
use B 'perlstring';
sub import {
my ( $class, $fname ) = ( shift, #_ );
$fname ||= 'd';
Keyword::Simple::define $fname => sub {
my $code = shift;
my ( #ws, #vars, #ws2 );
while ( $$code =~ / ^ ((?&PerlOWS)) ((?&PerlTerm)) ((?&PerlOWS)) $PPR::GRAMMAR /x ) {
my $len = length( $1 . $2 . $3 );
push #ws, $1;
push #vars, $2;
push #ws2, $3;
substr( $$code, 0, $len ) = '';
$$code =~ s/ ^ (?&PerlComma) $PPR::GRAMMAR //x;
}
my $newcode = perlstring( $class ) . '->d(';
while ( #vars ) {
my $var = shift #vars;
$newcode .= sprintf(
'%s%s,[%s],%s',
shift( #ws ),
perlstring( $var ),
$var,
shift( #ws2 ),
);
}
$newcode .= ');';
substr( $$code, 0, 0 ) = $newcode;
return;
};
}
our $OUTPUT = \*STDERR;
sub d {
my ( $class, #args ) = ( shift, #_ );
while ( #args ) {
my ( $label, $value ) = splice( #args, 0, 2 );
my $method = 'dump_list';
if ( $label =~ /^\$/ ) {
$method = 'dump_scalar';
$value = $value->[0];
}
elsif ( $label =~ /^\%/ ) {
$method = 'dump_hash';
}
printf { $OUTPUT } "%s = %s;\n", $label, $class->$method( $value );
}
}
sub dump_scalar {
my ( $class, $value ) = ( shift, #_ );
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Indent = 0;
return Dumper( $value );
}
sub dump_list {
my ( $class, $value ) = ( shift, #_ );
my $dumped = $class->dump_scalar( $value );
$dumped =~ s/\[/(/;
$dumped =~ s/\]/)/;
return $dumped;
}
sub dump_hash {
my ( $class, $value ) = ( shift, #_ );
my $dumped = $class->dump_scalar( { #$value } );
$dumped =~ s/\{/(/;
$dumped =~ s/\}/)/;
return $dumped;
}
$INC{'Acme/Hypothetical/Dumper.pm'} = __FILE__;
};
use Acme::Hypothetical::Dumper 'd';
my %foo = (
Me => 'person',
You => 'beloved one',
Them => 'space aliens',
);
d %foo, $foo{'Me'}, #foo{qw(You Me)}, %foo{qw(You Me)};
my #bar = qw(Me You Them);
d #bar, $bar[0], #bar[2, 1], %bar[2, 1];
use LWP::UserAgent qw();
my $ua = LWP::UserAgent->new;
d $ua->{ssl_opts}{verify_hostname};
As a follow up to my previous post here!
I tested the algorithm with nested hash references:
Algorithm:
use strict;
use warnings;
&expand_references2([a,b,{c=>123},d]);
sub expand_references2 {
my $indenting = -1;
my $inner; $inner = sub {
my $ref = $_[0];
my $key = $_[1];
$indenting++;
if(ref $ref eq 'ARRAY'){
print ' ' x $indenting;
printf("%s\n",($key) ? $key : '');
$inner->($_) for #{$ref};
}elsif(ref $ref eq 'HASH'){
print ' ' x $indenting;
printf("%s\n",($key) ? $key : '');
for my $k(sort keys %{$ref}){
$inner->($ref->{$k},$k);
}
}else{
if($key){
print ' ' x $indenting,$key,' => ',$ref,"\n";
}else{
print ' ' x $indenting,$ref,"\n";
}
}
$indenting--;
};
$inner->($_) for #_;
}
In some cases, the indentation and the newline character do not display as expected:
Example1:
expand_references2(hash=>{
d1=>{a=>123,
b=>234},
d2=>[1,2,3],
d3=>'hello'});
Output:
Hash
<newline> # not required
d1
a => 123
b => 234
d2
1
2
3
d3 => hello
Instead I would prefer an output something like this:
Hash
d1
a => 123
b => 234
d2
1
2
3
d3 => hello
OR
Hash
d1
a => 123
b => 234
d2
1
2
3
d3 => hello
Example2:
expand_references2([a,b,{c=>123},d]);
output:
a
b
c=>123 # indentation not required
d
Any guidance on how to achieve the above to scenario or indenting it right without extra newlines?
Appreciate any help.
Thanks
I'd use a somewhat different approach:
sub prindent {
my( $ref, $ind ) = #_;
if( ref( $ref ) eq 'HASH' ){
for my $key (sort keys %{$ref}){
print ' ' x $ind, $key;
my $val = $ref->{$key};
if( ref( $val ) ){
print "\n";
prindent( $val, $ind + 1 );
} else {
print " => $val\n";
}
}
} elsif( ref( $ref ) eq 'ARRAY' ){
for my $el ( #{$ref} ){
if( ref( $el ) ){
prindent( $el, $ind + 1 );
} else {
print ' ' x $ind, "$el\n";
}
}
}
}
sub prindent2 {
my( $key, $val ) = #_;
if( defined $val ){
print "$key\n";
prindent( $val, 1 );
} else {
prindent( $key, 0 );
}
}
This produces:
hash
d1
a => 123
b => 234
d2
1
2
3
d3 => hello
a
b
c => 123
d
You may not like the output for multidimensional arrays: all elements are in one column.
So I have an array like this:
W,X,Y,Z
-7,6,101,15
-7,6,101,16
-7,6,101,17
-7,6,101,78
-7,6,101,79
-7,6,101,84
-7,6,101,92
-7,9,615,49
-7,9,615,50
-7,10,759,38
-7,10,759,39
Now, I want to print a line when W=X=Y and Z are consecutive numbers.
Expected Output:
W,X,Y,Z
-7,6,101,15-16-17
-7,6,101,78-79
-7,6,101,84
-7,6,101,92
-7,9,615,49-50
-7,10,759,38-39
How do I implement this on Perl?
Thanks,
Art
Here is my script:
while ( $output_line = <FILE_C> ) {
chomp $output_line;
my ( $W, $X, $Y, $C, $D, $E, $F, $Z ) = ( split /\s/, $output_line );
if ( $Y == $Block_previous ) {
print("Yes\t$Block_previous\t$Y\t$Z\n");
push( #Z_array, $Z );
push( #Y_array, $Y );
next;
}
else {
push( #Z_array_nonblkmatch, $Z );
}
foreach $Z_printer (#Z_array) {
print("$Y_array[0]\t$Z_printer\n");
if ( ( $Z_delta == 1 ) || ( $Z_delta == -1 ) ) {
push( #Z_adj, $Z_printer, $Z_printer_prev );
#~ print ("pair: $Z_printer_prev-$Z_printer\n");
}
else {
#~ print ("$Z_printer\n");
}
$Z_printer_prev = $Z_printer;
}
#Z_adj = ();
#Z_array = ();
#Y_array = ();
#Z_array_nonblkmatch = ();
$Block_previous = $Y;
#~ <STDIN>;
}
close(FILE_C);
Thanks, raina77ow! However, this is what the output look like:
-7,6,101,15-16-17-79
-7,6,101,16-17-79
-7,6,101,17-79
-7,6,101,78-79
-7,6,101,79-50
-7,6,101,84-50
-7,6,101,92
-7,6,615,49-50-39
-7,6,615,50
One possible approach (ideone demo):
use warnings;
use strict;
my $prev;
while (<DATA>) {
chomp;
next unless /\S/;
my #numbers = split /,/;
if (defined $prev && $numbers[3] == $prev + 1) {
print '-' . ++$prev;
next;
}
print "\n" if defined $prev;
print join ',', #numbers;
$prev = $numbers[3];
}
__DATA__
-7,6,101,15
-7,6,101,16
-7,6,101,17
-7,6,101,78
-7,6,101,79
-7,6,101,84
-7,6,101,92
-7,9,615,49
-7,9,615,50
-7,10,759,38
-7,10,759,39
I choose not to collect this data into intermediate array, as you did, as the question was simple: print it grouped. The key is storing the value of the last (Z) column, then checking each new line against it: if it matches, you print just the incremented value (that's what print '-' . ++$prev line for), if not, you end this line (for all but the first case) and start a new one with the numbers of this line.
I'm using Perl to run through a tree, and then calculate the leaf nodes of the tree using the internal nodes as operators. I want to be able to print this in a postfix manner, and I managed to this this fairly easily with the basic operands (simply call the left and right nodes respectively before calling the parent) but I am having trouble producing the desired output for an average function. I don't have any trouble printing the actual result of the calculation, but I want to be able to print the operators and operands in postfix notation.
For example, 1 + average(3, 4, 5) will be shown as 1 ; 3 4 5 average +.
Here is my code:
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
my $debug = 0;
# an arithmetic expression tree is a reference to a list, which can
# be of two kinds as follows:
# [ 'leaf', value ]
# [ 'internal', operation, leftarg, rightarg ]
# Evaluate($ex) takes an arithmetic expression tree and returns its
# evaluated value.
sub Evaluate {
my ($ex) = #_;
$debug and
print "evaluating: ", Dumper($ex), "\n";
# the kind of node is given in the first element of the array
my $node_type = $ex->[0];
# if a leaf, then the value is a number
if ( $node_type eq 'leaf' ) {
# base case
my $value = $ex->[1];
$debug and
print "returning leaf: $value\n";
return $value;
}
# if not a leaf, then is internal,
if ( $node_type ne 'internal' ) {
die "Eval: Strange node type '$node_type' when evaluating tree";
}
# should now have an operation and two arguments
my $operation = $ex->[1];
my $left_ex = $ex->[2];
my $right_ex = $ex->[3];
# evaluate the left and right arguments;
my $left_value = Evaluate($left_ex);
my $right_value = Evaluate($right_ex);
# if any arguments are undefined, our value is undefined.
return undef unless
defined($left_value) and defined($right_value);
my $result;
# or do it explicitly for the required operators ...
if ($operation eq 'average') {
$result = ($left_value + $right_value) / 2;
}
if ($operation eq '+') {
$result = $left_value + $right_value;
} elsif ($operation eq '-') {
$result = $left_value - $right_value;
} elsif ($operation eq '*') {
$result = $left_value * $right_value;
} elsif ($operation eq 'div') {
if ($right_value != 0 ) {
$result = int ($left_value / $right_value);
} else {
$result = undef;
}
} elsif ($operation eq 'mod') {
$result = $left_value % $right_value;
} elsif ($operation eq '/') {
if ( $right_value != 0 ) {
$result = $left_value / $right_value;
}
else {
$result = undef;
}
}
$debug and
print "returning '$operation' on $left_value and $right_value result: $result\n";
return $result;
}
# Display($ex, $style) takes an arithmetic expression tree and a style
# parameter ('infix' or 'postfix') and returns a string that represents
# printable form of the expression in the given style.
sub Display {
my ($ex, $style) = #_;
# the kind of node is given in the first element of the array
my $node_type = $ex->[0];
# if a leaf, then the value is a number
if ( $node_type eq 'leaf' ) {
# base case
my $value = $ex->[1];
return $value;
}
# if not a leaf, then is internal,
if ( $node_type ne 'internal' ) {
die "Display: Strange node type '$node_type' when evaluating tree";
}
# should now have an operation and two arguments
my $operation = $ex->[1];
my $left_ex = $ex->[2];
my $right_ex = $ex->[3];
# evaluate the left and right arguments;
my $left_value = Display($left_ex, $style);
my $right_value = Display($right_ex, $style);
my $result;
if ($operation ne 'average') {
$result = "($left_value $operation $right_value) \n $left_value $right_value $operation";
} else {
$result = "($left_value $operation $right_value) \n $left_value $right_value $operation";
}
return $result;
}
# module end;
1;
And here is a test:
use strict;
use warnings;
use Display;
use arith;
my $ex1 = [ 'leaf', 42];
my $ex2 = [ 'internal', '+', [ 'leaf', 42], [ 'leaf', 10 ] ];
my $ex3 = [ 'internal', 'average', $ex2, [ 'leaf', 1 ] ];
print "ex1 is ", Evaluate($ex1), "\n";
print "ex1: ", Display($ex1), "\n";
print "\n";
print "ex2 is ", Evaluate($ex2), "\n";
print "ex2: ", Display($ex2), "\n";
print "\n";
print "ex3 is ", Evaluate($ex3), "\n";
print "ex3: ", Display($ex3), "\n";
print "\n";
Display::Render(\$ex3);
In order to do this, I realize I will have to change the subroutine "Display", but I'm not sure how to get the output --> value value ; #to indicate values that aren't averaged# value value average operand etc.
Any ideas?
I am not 100% sure that I understand your problem, but here is a cleanup / improvement of your two functions:
my %ops = ( # dispatch table for operations
average => sub {my $acc; $acc += $_ for #_; $acc / #_},
'+' => sub {$_[0] + $_[1]},
'-' => sub {$_[0] - $_[1]},
'*' => sub {$_[0] * $_[1]},
'mod' => sub {$_[0] % $_[1]},
(map {$_ => sub {$_[1] ? $_[0] / $_[1] : undef}} qw (/ div)),
);
sub Evaluate {
my $ex = shift;
print "evaluating: ", Dumper($ex), "\n" if $debug;
my $node_type = $ex->[0];
if ( $node_type eq 'leaf' ) {
print "returning leaf: $$ex[1]\n" if $debug;
return $$ex[1];
}
elsif ( $node_type ne 'internal' ) {
die "Eval: Strange node type '$node_type' when evaluating tree";
}
my $operation = $ex->[1];
my #values = map {Evaluate($_)} #$ex[2 .. $#$ex];
defined or return for #values;
if (my $op = $ops{$operation}) {
return $op->(#values);
} else {
print "operation $operation not found\n";
return undef;
}
}
Here the large if/elsif block is replaced with a dispatch table. This allows you to separate the logic from the parser. I have also replaced the $left_value and $right_value variables with the #values array, allowing your code to scale to n-arity operations (like average).
The following Display function has also been updated to handle n-arity operations:
my %is_infix = map {$_ => 1} qw( * + / - );
sub Display {
my ($ex, $style) = #_;
my $node_type = $ex->[0];
# if a leaf, then the value is a number
if ( $node_type eq 'leaf' ) {
return $$ex[1];
}
# if not a leaf, then is internal,
if ( $node_type ne 'internal' ) {
die "Display: Strange node type '$node_type' when evaluating tree";
}
# should now have an operation and n arguments
my $operation = $ex->[1];
if ($style and $style eq 'infix') {
my #values = map {Display($_, $style)} #$ex[2 .. $#$ex];
if ($is_infix{$operation}) {
return "$values[0] $operation $values[1]"
} else {
local $" = ', '; # "
return "$operation( #values )"
}
} else { # postfix by default
my #out;
for (#$ex[2 .. $#$ex]) {
if (#out and $_->[0] eq 'internal') {
push #out, ';'
}
push #out, Display($_, $style)
}
return join ' ' => #out, $operation;
}
}
You can call Display as Display($tree) or Display($tree, 'postfix') for postfix notation. And Display($tree, 'infix') for the infix notation.
ex1 is 42
ex1: 42
ex1: 42
ex2 is 52
ex2: 42 10 +
ex2: 42 + 10
ex3 is 26.5
ex3: 42 10 + 1 average
ex3: average( 42 + 10, 1 )
Which I believe is what you are looking for.
Finally, using your first example 1 + average(3, 4, 5):
my $avg = ['internal', 'average', [leaf => 3], [leaf => 4], [leaf => 5] ];
my $ex4 = ['internal', '+', [leaf => 1], $avg ];
print "ex4 is ", Evaluate($ex4), "\n";
print "ex4: ", Display($ex4), "\n";
print "ex4: ", Display($ex4, 'infix'), "\n";
print "\n";
which prints:
ex4 is 5
ex4: 1 ; 3 4 5 average +
ex4: 1 + average( 3, 4, 5 )
Maybe try AlgebraicToRPN?