[system] / trunk / pg / macros / contextLimitedPowers.pl Repository:
ViewVC logotype

View of /trunk/pg/macros/contextLimitedPowers.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5350 - (download) (as text) (annotate)
Fri Aug 17 21:07:00 2007 UTC (12 years, 6 months ago) by dpvc
File size: 5679 byte(s)
Updated to allow more flexibility in controlling the range of powers
to be allowed (as per John Jones' suggestion).  Also changed the
way that you request the changes:  you now make a function call rather
than modify the operators list directly yourself.  (The old way is
still provided, however, for backward compatibility.)

See the comments in the file for more details.

    1 
    2 loadMacros("Parser.pl");
    3 
    4 sub _contextLimitedPowers_init {}; # don't load it again
    5 
    6 =head3 Context("LimitedPowers")
    7 
    8 ##########################################################
    9 #
   10 #  Implements subclasses of the "^" operator that restrict
   11 #  the base or power that is allowed.  There are four
   12 #  available restrictions:
   13 #
   14 #    No raising e to a power
   15 #    Only allowing integer powers (positive or negative)
   16 #    Only allowing positive interger powers
   17 #    Only allowing positive interger powers (and 0)
   18 #
   19 #  You install these via one of the commands:
   20 #
   21 #    LimitedPowers::NoBaseE();
   22 #    LimitedPowers::OnlyIntegers();
   23 #    LimitedPowers::OnlyPositiveIntegers();
   24 #    LimitedPowers::OnlyNonNegativeIntegers();
   25 #
   26 #  Only one of the three can be in effect at a time; setting
   27 #  a second one overrides the first.
   28 #
   29 #  These function affect the current context, or you can pass
   30 #  a context reference, as in
   31 #
   32 #    $context = Context("Numeric")->copy;
   33 #    LimitedPowers::OnlyIntegers($context);
   34 #
   35 #  For the Interger power functions, you can pass additional
   36 #  parameters that control the range of values that are allowed
   37 #  for the powers.  The oprtions include:
   38 #
   39 #    minPower => m      only integer powers bigger than or equal
   40 #                       to m are allowed.  (If m is undef, then
   41 #                       there is no minimum power.)
   42 #
   43 #    maxPower => M      only integer powers less than or equal
   44 #                       to M are allowed.  (If M is undef, then
   45 #                       there is no maximum power.)
   46 #
   47 #    message => "text"  a description of the type of power
   48 #                       allowed (e.g., "positive integer constants");
   49 #
   50 #    checker => code    a reference to a subroutine that will be
   51 #                       used to check if the powers are acceptable.
   52 #                       It should accept a reference to the BOP::power
   53 #                       structure and return 1 or 0 depending on
   54 #                       whether the power is OK or not.
   55 #
   56 ##########################################################
   57 
   58 =cut
   59 
   60 package LimitedPowers;
   61 
   62 sub NoBaseE {
   63   my $context = (Value::isContext($_[0]) ? shift : Value->context);
   64   $context->operators->set(
   65     '^'  => {class => LimitedPowers::NoBaseE, isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval', @_},
   66     '**' => {class => LimitedPowers::NoBaseE, isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval', @_},
   67   );
   68 }
   69 
   70 sub OnlyIntegers {
   71   my $context = (Value::isContext($_[0]) ? shift : Value->context);
   72   $context->operators->set(
   73     '^'  => {class => LimitedPowers::OnlyIntegers, message => "integer constants", @_},
   74     '**' => {class => LimitedPowers::OnlyIntegers, message => "integer constants",@_},
   75   );
   76 }
   77 
   78 sub OnlyNonNegativeIntegers {
   79   my $context = (Value::isContext($_[0]) ? shift : Value->context);
   80   OnlyIntegers($context, minPower=>0, message=>"non-negative integer constants", @_);
   81 }
   82 
   83 sub OnlyPositiveIntegers {
   84   my $context = (Value::isContext($_[0]) ? shift : Value->context);
   85   OnlyIntegers($context, minPower => 1, message => "positive integer constants", @_);
   86 }
   87 
   88 sub OnlyNonTrivialPositiveIntegers {
   89   my $context = (Value::isContext($_[0]) ? shift : Value->context);
   90   OnlyIntegers($context, minPower=>2, message=>"integer constants bigger than 1", @_);
   91 }
   92 
   93 #
   94 #  Legacy code to accommodate older approach to setting the operators
   95 #
   96 our @NoBaseE = (
   97   '^'  => {class => LimitedPowers::NoBaseE, isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval'},
   98   '**' => {class => LimitedPowers::NoBaseE, isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval'},
   99 );
  100 our @OnlyIntegers = (
  101   '^'  => {class => LimitedPowers::OnlyIntegers, message => "integer constants"},
  102   '**' => {class => LimitedPowers::OnlyIntegers, message => "integer constants"},
  103 );
  104 our @OnlyNonNegativeIntegers = (
  105   '^'  => {class => LimitedPowers::OnlyIntegers, minPower => 0, message => "non-negative integer constants"},
  106   '**' => {class => LimitedPowers::OnlyIntegers, minPower => 0, message => "non-negative integer constants"},
  107 );
  108 our @OnlyPositiveIntegers = (
  109   '^'  => {class => LimitedPowers::OnlyIntegers, minPower => 1, message => "positive integer constants"},
  110   '**' => {class => LimitedPowers::OnlyIntegers, minPower => 1, message => "positive integer constants"},
  111 );
  112 our @OnlyNonTrivialPositiveIntegers = (
  113   '^'  => {class => LimitedPowers::OnlyIntegers, minPower => 2, message => "integer constants bigger than 1"},
  114   '**' => {class => LimitedPowers::OnlyIntegers, minPower => 2, message => "integer constants bigger than 1"},
  115 );
  116 
  117 
  118 ##################################################
  119 
  120 package LimitedPowers::NoBaseE;
  121 @ISA = qw(Parser::BOP::power);
  122 
  123 my $e = CORE::exp(1);
  124 
  125 sub _check {
  126   my $self = shift;
  127   $self->SUPER::_check(@_);
  128   $self->Error("Can't raise e to a power") if $self->{lop}->string eq 'e';
  129 }
  130 
  131 sub _eval {
  132   my $self = shift;
  133   Value::cmp_Message("Can't raise e to a power") if $_[0] - $e == 0;
  134   $self->SUPER::_eval(@_);
  135 }
  136 
  137 ##################################################
  138 
  139 package LimitedPowers::OnlyIntegers;
  140 @ISA = qw(Parser::BOP::power);
  141 
  142 sub _check {
  143   my $self = shift; my $p = $self->{rop}; my $def = $self->{def};
  144   my $checker = (defined($def->{checker}) ? $def->{checker} :  \&isInteger);
  145   $self->SUPER::_check(@_);
  146   $self->Error("Powers must be $def->{message}")
  147     if $p->type ne 'Number' || !$p->{isConstant} || !&{$checker}($self);
  148 }
  149 
  150 sub isInteger {
  151   my $self = shift; my $n = $self->{rop}->eval;
  152   my $def = $self->{def};
  153   return 0 if defined($def->{minPower}) && $n < $def->{minPower};
  154   return 0 if defined($def->{maxPower}) && $n > $def->{maxPower};
  155   return Value::Real->make($n - int($n)) == 0;
  156 }
  157 
  158 ##################################################
  159 
  160 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9