[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 5352 - (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 4664 ##########################################################
78 :    
79 : gage 4997 =cut
80 : dpvc 4664
81 :     package LimitedPowers;
82 :    
83 : dpvc 5350 sub NoBaseE {
84 :     my $context = (Value::isContext($_[0]) ? shift : Value->context);
85 :     $context->operators->set(
86 : dpvc 5351 '^' => {class => 'LimitedPowers::NoBaseE', isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval', @_},
87 :     '**' => {class => 'LimitedPowers::NoBaseE', isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval', @_},
88 : dpvc 5350 );
89 :     }
90 :    
91 :     sub OnlyIntegers {
92 :     my $context = (Value::isContext($_[0]) ? shift : Value->context);
93 :     $context->operators->set(
94 : dpvc 5351 '^' => {class => 'LimitedPowers::OnlyIntegers', message => "integer constants", @_},
95 :     '**' => {class => 'LimitedPowers::OnlyIntegers', message => "integer constants",@_},
96 : dpvc 5350 );
97 :     }
98 :    
99 :     sub OnlyNonNegativeIntegers {
100 :     my $context = (Value::isContext($_[0]) ? shift : Value->context);
101 :     OnlyIntegers($context, minPower=>0, message=>"non-negative integer constants", @_);
102 :     }
103 :    
104 :     sub OnlyPositiveIntegers {
105 :     my $context = (Value::isContext($_[0]) ? shift : Value->context);
106 :     OnlyIntegers($context, minPower => 1, message => "positive integer constants", @_);
107 :     }
108 :    
109 :     sub OnlyNonTrivialPositiveIntegers {
110 :     my $context = (Value::isContext($_[0]) ? shift : Value->context);
111 :     OnlyIntegers($context, minPower=>2, message=>"integer constants bigger than 1", @_);
112 :     }
113 :    
114 :     #
115 : dpvc 5351 # Test for whether the power is an integer in the specified range
116 :     #
117 :     sub isInteger {
118 :     my $self = shift; my $n = shift;
119 :     my $def = $self->{def};
120 :     return 0 if defined($def->{minPower}) && $n < $def->{minPower};
121 :     return 0 if defined($def->{maxPower}) && $n > $def->{maxPower};
122 :     return Value::Real->make($n - int($n)) == 0;
123 :     }
124 :    
125 :     #
126 : dpvc 5350 # Legacy code to accommodate older approach to setting the operators
127 :     #
128 : dpvc 4664 our @NoBaseE = (
129 : dpvc 5351 '^' => {class => 'LimitedPowers::NoBaseE', isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval'},
130 :     '**' => {class => 'LimitedPowers::NoBaseE', isCommand=>1, perl=>'LimitedPowers::NoBaseE->_eval'},
131 : dpvc 4664 );
132 :     our @OnlyIntegers = (
133 : dpvc 5351 '^' => {class => 'LimitedPowers::OnlyIntegers', message => "integer constants"},
134 :     '**' => {class => 'LimitedPowers::OnlyIntegers', message => "integer constants"},
135 : dpvc 4664 );
136 : dpvc 5350 our @OnlyNonNegativeIntegers = (
137 : dpvc 5351 '^' => {class => 'LimitedPowers::OnlyIntegers', minPower => 0, message => "non-negative integer constants"},
138 :     '**' => {class => 'LimitedPowers::OnlyIntegers', minPower => 0, message => "non-negative integer constants"},
139 : dpvc 5350 );
140 : dpvc 4664 our @OnlyPositiveIntegers = (
141 : dpvc 5351 '^' => {class => 'LimitedPowers::OnlyIntegers', minPower => 1, message => "positive integer constants"},
142 :     '**' => {class => 'LimitedPowers::OnlyIntegers', minPower => 1, message => "positive integer constants"},
143 : dpvc 4664 );
144 : dpvc 5350 our @OnlyNonTrivialPositiveIntegers = (
145 : dpvc 5351 '^' => {class => 'LimitedPowers::OnlyIntegers', minPower => 2, message => "integer constants bigger than 1"},
146 :     '**' => {class => 'LimitedPowers::OnlyIntegers', minPower => 2, message => "integer constants bigger than 1"},
147 : dpvc 5332 );
148 :    
149 : dpvc 5350
150 : dpvc 4664 ##################################################
151 :    
152 :     package LimitedPowers::NoBaseE;
153 :     @ISA = qw(Parser::BOP::power);
154 :    
155 :     my $e = CORE::exp(1);
156 :    
157 :     sub _check {
158 :     my $self = shift;
159 :     $self->SUPER::_check(@_);
160 :     $self->Error("Can't raise e to a power") if $self->{lop}->string eq 'e';
161 :     }
162 :    
163 :     sub _eval {
164 :     my $self = shift;
165 :     Value::cmp_Message("Can't raise e to a power") if $_[0] - $e == 0;
166 :     $self->SUPER::_eval(@_);
167 :     }
168 :    
169 :     ##################################################
170 :    
171 :     package LimitedPowers::OnlyIntegers;
172 :     @ISA = qw(Parser::BOP::power);
173 :    
174 :     sub _check {
175 : dpvc 5350 my $self = shift; my $p = $self->{rop}; my $def = $self->{def};
176 : dpvc 5351 my $checker = (defined($def->{checker}) ? $def->{checker} : \&LimitedPowers::isInteger);
177 : dpvc 4664 $self->SUPER::_check(@_);
178 : dpvc 5350 $self->Error("Powers must be $def->{message}")
179 : dpvc 5351 if $p->type ne 'Number' || !$p->{isConstant} || !&{$checker}($self,$p->eval);
180 : dpvc 4664 }
181 :    
182 :     ##################################################
183 :    
184 :     1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9