view release on metacpan or  search on metacpan

lib/AI/Evolve/Befunge/Critter.pm  view on Meta::CPAN

    # redundant assignment avoids a "possible typo" warning
    *Language::Befunge::Storage::Generic::Vec::XS::expand = \&_expand;
    *Language::Befunge::Storage::Generic::Vec::XS::expand = \&_expand;
    *Language::Befunge::Storage::Generic::Vec::expand     = \&_expand;

    # override IP->spush() to impose stack size checking
    my $_lbip_spush;
    BEGIN { $_lbip_spush = \&Language::Befunge::IP::spush; };
    sub _spush {
        my ($ip, @newvals) = @_;
        my $critter = $$ip{_ai_critter};
        return $ip->dir_reverse unless $critter->spend($critter->stackcost * scalar @newvals);
        my $rv = &$_lbip_spush(@_);
        return $rv;
    }
    *Language::Befunge::IP::spush = \&_spush;

    # override IP->ss_create() to impose stack count checking
    sub _block_open {
        my ($interp) = @_;
        my $ip       = $interp->get_curip;
        my $critter = $$ip{_ai_critter};
        my $count    = $ip->svalue(1);
        return $ip->dir_reverse unless $critter->spend($critter->stackcost * $count);
        return Language::Befunge::Ops::block_open(@_);
    }

    # override op_flow_jump_to to impose skip count checking
    sub _op_flow_jump_to_wrap {
        my ($interp) = @_;
        my $ip       = $interp->get_curip;
        my $critter  = $$interp{_ai_critter};
        my $count    = $ip->svalue(1);
        return $ip->dir_reverse unless $critter->spend($critter->repeatcost * abs($count));
        return Language::Befunge::Ops::flow_jump_to(@_);
    }

    # override op_flow_repeat to impose loop count checking
    sub _op_flow_repeat_wrap {
        my ($interp) = @_;
        my $ip       = $interp->get_curip;
        my $critter  = $$interp{_ai_critter};
        my $count    = $ip->svalue(1);
        return $ip->dir_reverse unless $critter->spend($critter->repeatcost * abs($count));
        return Language::Befunge::Ops::flow_repeat(@_);
    }

    # override op_spawn_ip to impose thread count checking
    sub _op_spawn_ip_wrap {
        my ($interp) = @_;
        my $ip       = $interp->get_curip;
        my $critter  = $$interp{_ai_critter};
        my $cost     = 0;$critter->threadcost;
        foreach my $stack ($ip->get_toss(), @{$ip->get_ss}) {
            $cost   += scalar @$stack;
        }
        $cost       *= $critter->stackcost;
        $cost       += $critter->threadcost;
        return $ip->dir_reverse unless $critter->spend($cost);
        # This is a hack; Storable can't deep copy our data structure.
        # It will get re-added to both parent and child, next time around.
        delete($$ip{_ai_critter});
        return Language::Befunge::Ops::spawn_ip(@_);
    }
}

1;