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

Diff of /trunk/pg/macros/contextOrdering.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 5961 Revision 5962
… …
89 $context->constants->clear(); 89 $context->constants->clear();
90 $context->operators->clear(); 90 $context->operators->clear();
91 $context->functions->clear(); 91 $context->functions->clear();
92 $context->strings->clear(); 92 $context->strings->clear();
93 $context->operators->add( 93 $context->operators->add(
94 '>' => {precedence => 1.5, associativity => 'left', type => 'bin', class => 'context::Ordering::BOP'}, 94 '>' => {precedence => 1.5, associativity => 'left', type => 'bin', class => 'context::Ordering::BOP::ordering'},
95 '=' => {precedence => 1.7, associativity => 'left', type => 'bin', class => 'context::Ordering::BOP'}, 95 '=' => {precedence => 1.7, associativity => 'left', type => 'bin', class => 'context::Ordering::BOP::ordering'},
96 ); 96 );
97 $context->{parser}{String} = "context::Ordering::Parser::String";
98 $context->{parser}{Value} = "context::Ordering::Parser::Value";
99 $context->{parser}{BOP} = "context::Ordering::Parser::BOP";
97 $context->{value}{String} = "context::Ordering::Value::String"; 100 $context->{value}{String} = "context::Ordering::Value::String";
98 $context->{value}{Ordering} = "context::Ordering::Value::Ordering"; 101 $context->{value}{Ordering} = "context::Ordering::Value::Ordering";
99 $context->strings->add('='=>{hidden=>1},'>'=>{hidden=>1}); 102 $context->strings->add('='=>{hidden=>1},'>'=>{hidden=>1});
100 $context->{error}{msg}{"Variable '%s' is not defined in this context"} = "'%s' is not defined in this context"; 103 $context->{error}{msg}{"Variable '%s' is not defined in this context"} = "'%s' is not defined in this context";
101 $context->{error}{msg}{"Unexpected character '%s'"} = "Can't use '%s' in this context"; 104 $context->{error}{msg}{"Unexpected character '%s'"} = "Can't use '%s' in this context";
102 $context->{error}{msg}{"Missing operand before '%s'"} = "Missing letter before '%s'"; 105 $context->{error}{msg}{"Missing operand before '%s'"} = "Missing letter before '%s'";
… …
163# standard list comparisons. The operands are either the strings 166# standard list comparisons. The operands are either the strings
164# for individual letters, or another Ordering object as a 167# for individual letters, or another Ordering object as a
165# nested List. 168# nested List.
166# 169#
167 170
168package context::Ordering::BOP; 171package context::Ordering::BOP::ordering;
169our @ISA = ('Parser::BOP'); 172our @ISA = ('Parser::BOP');
170 173
171sub class {"Ordering"} 174sub class {"Ordering"}
172 175
173sub isOrdering { 176sub isOrdering {
174 my $self = shift; my $obj = shift; my $class = $obj->class; 177 my $self = shift; my $obj = shift; my $class = $obj->class;
175 return ($class eq 'Value' && $obj->{value}->class eq 'Ordering') ||
176 ($class eq 'Ordering') || $obj->{def}{isLetter}; 178 return $class eq 'Ordering' || $obj->{def}{isLetter};
177} 179}
178 180
179sub _check { 181sub _check {
180 my $self = shift; 182 my $self = shift;
181 return if $self->isOrdering($self->{lop}) && $self->isOrdering($self->{rop});
182 $self->Error("Operators of %s must be letters",$self->{bop}); 183 $self->Error("Operators of %s must be letters",$self->{bop})
184 unless $self->isOrdering($self->{lop}) && $self->isOrdering($self->{rop});
185 $self->{letters} = $self->{lop}{letters}; # we modify {lop}{letters} this way, but that doesn't matter
186 foreach my $x (keys %{$self->{rop}{letters}}) {
187 if (defined($self->{letters}{$x})) {
188 $self->{ref} = $self->{rop}{letters}{$x};
189 $self->Error("Letters can appear only once in an ordering");
190 }
191 $self->{letters}{$x} = $self->{rop}{letters}{$x};
192 }
193 $self->{equation}{letters} = $self->{letters}; # removed by context::Ordering::Parser::BOP;
183} 194}
184 195
185sub _eval { 196sub _eval {
186 my $self = shift; 197 my $self = shift;
187 return $self->Package("Ordering")->new($self->context,$self->{bop},@_); 198 return $self->Package("Ordering")->new($self->context,$self->{bop},@_);
… …
194 205
195sub TeX { 206sub TeX {
196 my $self = shift; 207 my $self = shift;
197 return $self->{lop}->TeX." ".$self->{bop}." ".$self->{rop}->TeX; 208 return $self->{lop}->TeX." ".$self->{bop}." ".$self->{rop}->TeX;
198} 209}
210
199 211
200############################################################# 212#############################################################
201# 213#
202# This is the Value object used to implement the list That represents 214# This is the Value object used to implement the list That represents
203# one ordering operation. It is simply a normal Value::List with the 215# one ordering operation. It is simply a normal Value::List with the
… …
246# Make sure we do comparison as a list of lists (rather than as the 258# Make sure we do comparison as a list of lists (rather than as the
247# individual entries in the underlying Value::List that encodes 259# individual entries in the underlying Value::List that encodes
248# the ordering) 260# the ordering)
249# 261#
250sub cmp_equal { 262sub cmp_equal {
251 my $self = shift; my $ans = $_[0]; 263 my $self = shift; my $ans = $_[0];
252 $ans->{typeMatch} = $ans->{firstElement} = $self; 264 $ans->{typeMatch} = $ans->{firstElement} = $self;
253 $self = $ans->{correct_value} = Value::List->make($self); 265 $self = $ans->{correct_value} = Value::List->make($self);
254 $ans->{student_value} = Value::List->make($ans->{student_value}) 266 $ans->{student_value} = Value::List->make($ans->{student_value})
255 if Value::classMatch($ans->{student_value},'Ordering'); 267 if Value::classMatch($ans->{student_value},'Ordering');
256 return $self->SUPER::cmp_equal(@_); 268 return $self->SUPER::cmp_equal(@_);
… …
282sub TeX {shift->value} 294sub TeX {shift->value}
283 295
284 296
285############################################################# 297#############################################################
286# 298#
299# Override Parser classes so that we can check for repeated letters
300#
301
302package context::Ordering::Parser::String;
303our @ISA = ('Parser::String');
304
305#
306# Save the letters positional reference
307#
308sub new {
309 my $self = shift;
310 $self = $self->SUPER::new(@_);
311 $self->{letters}{$self->{value}} = $self->{ref} if $self->{def}{isLetter};
312 return $self;
313}
314
315#########################
316
317package context::Ordering::Parser::Value;
318our @ISA = ('Parser::Value');
319
320#
321# Move letters to Value object
322#
323sub new {
324 my $self = shift;
325 $self = $self->SUPER::new(@_);
326 if (defined($self->{value}{letters})) {
327 $self->{letters} = $self->{value}{letters};
328 delete $self->{value}{letters};
329 }
330 return $self;
331}
332
333#
334# Return Ordering class if the object is one
335#
336sub class {
337 my $self = shift;
338 return "Ordering" if $self->{value}->classMatch('Ordering');
339 return $self->SUPER::class;
340}
341
342#########################
343
344package context::Ordering::Parser::BOP;
345our @ISA = ('Parser::BOP');
346
347#
348# If a BOP is constant and so reduced automatically we will lose the
349# letters hash, so it is stored temporarily in the equation by _check(),
350# and replaced here. A hack, but that avoids adding letters to the
351# Ordering object in eval() and having them remain there after parsing.
352#
353sub new {
354 my $self = shift;
355 $self = $self->SUPER::new(@_);
356 $self->{letters} = $self->{equation}{letters} unless defined $self->{letters} || $self->class ne 'Ordering';
357 delete $self->{equation}{letters};
358 return $self;
359}
360
361
362#############################################################
363#
287# This overrides the cmp_equal method to make sure that 364# This overrides the cmp_equal method to make sure that
288# Ordering lists are put into nested lists (since the 365# Ordering lists are put into nested lists (since the
289# underlying ordering is a list, we don't want the 366# underlying ordering is a list, we don't want the
290# list checker to test the individual parts of the list, 367# list checker to test the individual parts of the list,
291# but rather the list as a whole). 368# but rather the list as a whole).
… …
298 my $self = shift; my $ans = $_[0]; 375 my $self = shift; my $ans = $_[0];
299 $ans->{student_value} = Value::List->make($ans->{student_value}) 376 $ans->{student_value} = Value::List->make($ans->{student_value})
300 if Value::classMatch($ans->{student_value},'Ordering'); 377 if Value::classMatch($ans->{student_value},'Ordering');
301 return $self->SUPER::cmp_equal(@_); 378 return $self->SUPER::cmp_equal(@_);
302} 379}
380
381#############################################################
382
3831;
Legend:
Removed from v.5961  
changed lines
  Added in v.5962
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9