我可以根据元素是否在Perl的子例程中使用来从堆栈中弹出元素吗？

yv5phkfx  于 2023-03-09  发布在  Perl
关注(0)|答案(1)|浏览(160)

编辑：包含我的perl脚本
有没有一种方法可以调用一个子程序，通过提供参数作为pop（@stack）和值，只有当它们在子程序中使用时才从堆栈中弹出。在下面的例子中，我想：“printok”子例程从堆栈弹出0个元素。“check”子例程从堆栈弹出1个元素。“compare”子例程从堆栈弹出2个元素。

sub compare{
    my ($v1,$v2) = @_;
    if ($v1 < $v2){
        return $v1;
    }
    else{
        return $v2;
    }
}

sub check{
    my $v = $_[0];
    if ($v > 0){
        return "ckeck done\n";
    }
    else{
        exit;
    }
}

sub printok{
    return "ok\n";
}

print printok(pop(@stack),pop(@stack)),"\n";
print check(pop(@stack),pop(@stack)),"\n";
print compare(pop(@stack),pop(@stack)),"\n";

print join(" ",@stack), "\n";

我的实际用例是在一个程序中，其中的操作名是散列的，并且一些操作需要比其他操作更多的参数。我希望能够根据散列中列出的操作代码调用函数。

我不想在子例程内部使用堆栈。
我希望能够用一行代码调用每个子例程。（或使用尽可能少的条件语句）

$opcodes{$op}->(pop(@stack),pop(@stack),$n);
有些子例程只需要堆栈中的一个元素，有些需要2个元素，有些需要一个额外的整数。
我的剧本：

#!/usr/bin/perl
use strict;
use warnings;

#regex for numbers
my $regN = qr/[-+]?(?:\d+(?:\.\d+)?|\.\d+)(?:[eE][-+]?\d+)?/;
#creating the stack
my @stack;
#creating the hash table for the opcodes
my %opcodes = (
    '+'    => \&add,
    '-'    => \&subtract,
    '*'    => \&multi,
    '/'    => \&divide,
    'neg'  => \&negate,
    'conj' => \&conjugate,
    'abs'  => \&absolute,
    'sqrt' => \&squarert,
    'drop' => \&drop,
    'dup'  => \&dup,
    'swap' => \&swap,
    'rot'  => \&rot,
);

#declaration of the n variable used in the rot N function
my $n;

#realisation of the + function
sub add{
    die "Error: The + function requires at least 2 elements in the stack" 
    if 2 > scalar @stack;
    
    my @q;
    my ($q2, $q1) = (pop(@stack),pop(@stack));

    #adding the elements of the quaternions
    @q[0] = @$q1[0] + @$q2[0];
    @q[1] = @$q1[1] + @$q2[1];
    @q[2] = @$q1[2] + @$q2[2];
    @q[3] = @$q1[3] + @$q2[3];
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
};

#realisation of the - function
sub subtract{
    die "Error: The - function requires at least 2 elements in the stack" 
    if 2 > scalar @stack;
    
    my @q;
    my ($q2, $q1) = (pop(@stack),pop(@stack));

    #subtracting the elements of the quaternions
    @q[0] = @$q1[0] - @$q2[0];
    @q[1] = @$q1[1] - @$q2[1];
    @q[2] = @$q1[2] - @$q2[2];
    @q[3] = @$q1[3] - @$q2[3];
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
};

#realisation of the * function
sub multi{
    die "Error: The * function requires at least 2 elements in the stack" 
    if 2 > scalar @stack;
    
    my @q;
    my ($q2, $q1) = (pop(@stack),pop(@stack));

    #https://www.euclideanspace.com/maths/algebra/
    #realNormedAlgebra/quaternions/arithmetic/
    @q[0] = (@$q1[0] * @$q2[0] - @$q1[1] * @$q2[1] - 
    @$q1[2] * @$q2[2] - @$q1[3] * @$q2[3]);
    @q[1] = (@$q1[1] * @$q2[0] + @$q1[0] * @$q2[1] + 
    @$q1[2] * @$q2[3] - @$q1[3] * @$q2[2]);
    @q[2] = (@$q1[0] * @$q2[2] - @$q1[1] * @$q2[3] + 
    @$q1[2] * @$q2[0] + @$q1[3] * @$q2[1]);
    @q[3] = (@$q1[0] * @$q2[3] + @$q1[1] * @$q2[2] - 
    @$q1[2] * @$q2[1] + @$q1[3] * @$q2[0]);
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
};

#realisation of the / function
sub divide{
    die "Error: The / function requires at least 2 elements in the stack" 
    if 2 > scalar @stack;
    
    my @q;
    my ($q2, $q1) = (pop(@stack),pop(@stack));

    #https://www.mathworks.com/help/aeroblks/quaterniondivision.html
    @q[0] = (@$q1[0] * @$q2[0] + @$q1[1] * @$q2[1] + 
    @$q1[2] * @$q2[2] + @$q1[3] * @$q2[3])/
    (@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
    @q[1] = (@$q1[0] * @$q2[1] - @$q1[1] * @$q2[0] - 
    @$q1[2] * @$q2[3] + @$q1[3] * @$q2[2])/
    (@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
    @q[2] = (@$q1[0] * @$q2[2] + @$q1[1] * @$q2[3] - 
    @$q1[2] * @$q2[0] - @$q1[3] * @$q2[1])/
    (@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
    @q[3] = (@$q1[0] * @$q2[3] - @$q1[1] * @$q2[2] + 
    @$q1[2] * @$q2[1] - @$q1[3] * @$q2[0])/
    (@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}

#realisation of the neg function
sub negate{
    die "Error: The neg function requires at least 1 elements in the stack" 
    if 0 == scalar @stack;
    
    my @q;
    my $q1 = pop(@stack);

    @q[0] = @$q1[0] * -1;
    @q[1] = @$q1[1] * -1;
    @q[2] = @$q1[2] * -1;
    @q[3] = @$q1[3] * -1;
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}

#realisation of the conj function
sub conjugate{
    die "Error: The conj function requires at least 1 element in the stack" 
    if 0 == scalar @stack;
    
    my @q;
    my $q1 = pop(@stack);
    @q[0] = @$q1[0];
    @q[1] = @$q1[1] * -1;
    @q[2] = @$q1[2] * -1;
    @q[3] = @$q1[3] * -1;
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}

#realisation of the abs function
sub absolute{
    die "Error: The abs function requires at least 1 element in the stack" 
    if 0 == scalar @stack;
    
    my @q;
    my $q1 = pop(@stack);
    #finding absolute values of each individual component
    @q[0] = abs(@$q1[0]);
    @q[1] = abs(@$q1[1]);
    @q[2] = abs(@$q1[2]);
    @q[3] = abs(@$q1[3]);
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}

#realisation of the sqrt function
sub squarert{
    die "Error: The sqrt function requires at least 1 element in the stack" 
    if 0 == scalar @stack;
    
    my @q;
    my $q1 = pop(@stack);
    #https://www.johndcook.com/blog/2021/01/06/quaternion-square-roots/
    #finding the magnitude of the quaternion
    my $magnitude = sqrt(@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
    my $theta = atan2(sqrt(1 - (@$q1[0] / $magnitude)**2), @$q1[0] / $magnitude);
    @q[0] = cos($theta/2);
    @q[1] = sin($theta/2) * (@$q1[1] / $magnitude);
    @q[2] = sin($theta/2) * (@$q1[2] / $magnitude);
    @q[3] = sin($theta/2) * (@$q1[3] / $magnitude);
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
    conjugate();
}

#realisation of the exp function
sub drop{
    die "Error: The drop function requires at least 1 element in the stack" 
    if 0 == scalar @stack;
    
    pop(@stack);
}

#realisation of the dup function
sub dup{
    die "Error: The dup function requires at least 1 element in the stack" 
    if 0 == scalar @stack;
    
    my @q;
    my $q1 = pop(@stack);
    @q = @$q1;
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
    push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}

#realisation of the swap function
sub swap{
    die "Error: The swap function requires at least 2 elements in the stack" 
    if 2 > scalar @stack;
    
    my @q1 = @{pop(@stack)};
    my @q2 = @{pop(@stack)};
    push(@stack,[$q1[0], $q1[1], $q1[2], $q1[3]]);
    push(@stack,[$q2[0], $q2[1], $q2[2], $q2[3]]);
}

#realisation of the rot function
sub rot{
    die "Error: N (in rot N) cannot be 0" if $n == 0;
    die "Error: N (in rot N) cannot be greater than 
    the amount of elements in the stack"
    if abs($n) > scalar @stack;
    
    my @q ;
    if ($n > 0) {
        print "positive\n";
        @q = @{pop(@stack)};
        splice (@stack, $n-1, 0, [$q[0], $q[1], $q[2], $q[3]]);
    } 
    elsif ($n < 0) {
        print "negative\n";
        @q = @{$stack[$n-1]};
        splice (@stack, $n-1, 1);
        push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
    }
}

while(<>){
    chomp;
    next if /^\s*$/;
    if (/^\s*#@/){
        die "Error: The column line is not of the right format" 
        unless (/^\s*#@\s*1\s*i\s*j\s*k\s*$/);
    }
    next if /^\s*#/;
    if (/^\s*($regN)\s+($regN)\s+($regN)\s+($regN)\s*$/){
        my $quat = [$1,$2,$3,$4];
        push(@stack,[$1,$2,$3,$4]);
        #print join("; ",@{$stack[0]}),"\n";
    }
    elsif (/^\s*$regN(\s+$regN)*\s*$/){
        die "Error: Number of input number components is not 4";
    
    }
    elsif (/^\s*(\S+)([\s,[\d,-]*]?)\s*$/){
        my $op = $1 ;
        $n = $2 ;
        die "Error: Unknown operation '$op'" 
        unless exists $opcodes{$op};
        $opcodes{$op}->();  
        #print pop(@stack), "\n" ;
        #print pop(@stack), "\n"
        # foreach my $qr(@stack){
        #   print join("; ",@{$qr}),"\n";
        # }
        # print "\n";   
    }
}

warn "Warning: Extra values left in the stack at the end of the",
" program" 
if scalar @stack > 1;

die "Error: Not enough values on the stack 
for printing at the end of the program"
if scalar @stack == 0;

print "#@ 1 i j k\n";
my @ans = @{pop(@stack)};

if (grep {$_ eq "NaN"} @ans){
    print "NaN\n";
}
elsif (grep {$_ eq "Inf"} @ans){
    print "+Inf\n";
}
elsif (grep {$_ eq "-Inf"} @ans){
    print "-Inf\n";
}
else{
    print join ("; ",@ans);
}
perl

1条答案

按热度按时间
5ssjco0h

5ssjco0h1#

没有，但是这里有一些想法，你可能会感兴趣。

将引用传递到堆栈

您可以将堆栈的引用传递给函数，并让它们自己弹出参数。

use v5.10;

sub compare {
    my $v1 = pop @{ $_[0] };
    my $v2 = pop @{ $_[0] };
    if ( $v1 < $v2 ) {
        return $v1;
    }
    else {
        return $v2;
    }
}

sub check {
    my $v = pop @{ $_[0] };
    if ( $v > 0 ) {
        return "check done";
    }
    else {
        exit;
    }
}

sub printok {
    return "ok";
}

say printok( \@stack );
say check( \@stack );
say compare( \@stack );

say join( " ", @stack );

这很简单，但是函数需要知道堆栈的存在。

关于函数需要多少参数的元数据

你可以保留每个函数的元数据，这样你就知道它需要多少个参数，然后使用一个实用函数从堆栈中精确地检索那么多的参数，并用它调用函数。

use v5.10;
use Sub::Talisman qw( ArgCount );

sub compare :ArgCount(2) {
    my ( $v1, $v2 ) = @_;
    if ( $v1 < $v2 ) {
        return $v1;
    }
    else {
        return $v2;
    }
}

sub check :ArgCount(1) {
    my $v = shift;
    if ( $v > 0 ) {
        return "check done";
    }
    else {
        exit;
    }
}

sub printok :ArgCount(0) {
    return "ok";
}

sub call_with_stack {
    my ( $function, $stack, @extra_args ) = @_;
    my $coderef = ref( $function )
        ? $function
        : __PACKAGE__->can( $function );
    my $count = Sub::Talisman
        ->get_attribute_parameters( $coderef, 'ArgCount' )
        ->[0];
    $count -= scalar @extra_args;
    my @args = ();
    if ( $count > 0 ) {
        push @args, pop @$stack for 1 .. $count;
    }
    $coderef->( @args, @extra_args );
}

say call_with_stack printok => \@stack;
say call_with_stack check => \@stack;
say call_with_stack compare => \@stack;

say join( " ", @stack );

这允许函数体不知道堆栈，但要求函数的调用方将调用 Package 在call_with_stack中。
基本上，一种解决方案需要函数方面的专门知识，而另一种需要调用者方面的专门知识。
第二种解决方案似乎是一种最好的解决方案，它可以满足额外的要求，即可以传递一个不是来自堆栈的额外$n，尽管在本例中，它硬编码了这样一个假设，即任何额外的非堆栈参数将始终位于参数列表的 end。

赞(0）分享  回复(0）举报  2023-03-09
我来回答

相关问题

    查看更多

    热门标签

    更多
    JavaquerypythonNode开发语言requestUtil数据库Table后端算法LoggerMessageElementParser

    最新问答

    更多
    • 蜀ICP备13028337号-1 大数据知识库 https://www.saoniuhuo.com © All rights reserved
    • 本站内容来源互联网,如果侵犯您的权益请联系我们删除, 联系方式：448109455@qq.com