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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5353 - (view) (download) (as text)

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9