[system] / trunk / pg / lib / Value.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Value.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2654 - (download) (as text) (annotate)
Fri Aug 20 02:11:08 2004 UTC (15 years, 6 months ago) by dpvc
File size: 14221 byte(s)
Avoid possible infinite recursion in promotePrecedence() when special
precedence is used.

    1 package Value;
    2 my $pkg = 'Value';
    3 use vars qw($context $defaultContext %Type);
    4 use strict;
    5 
    6 #############################################################
    7 #
    8 #  Initialize the context
    9 #
   10 
   11 use Value::Context;
   12 
   13 $defaultContext = Value::Context->new(
   14   lists => {
   15     'Point'  => {open => '(', close => ')'},
   16     'Vector' => {open => '<', close => '>'},
   17     'Matrix' => {open => '[', close => ']'},
   18     'List'   => {open => '(', close => ')'},
   19   },
   20   flags => {
   21     #
   22     #  For vectors:
   23     #
   24     ijk => 0,  # print vectors as <...>
   25     #
   26     #  word to use for infinity
   27     #
   28     infiniteWord => 'infinity',
   29     #
   30     #  For fuzzy reals:
   31     #
   32     useFuzzyReals => 1,
   33     tolerance    => 1E-4,
   34     tolType      => 'relative',
   35     zeroLevel    => 1E-14,
   36     zeroLevelTol => 1E-12,
   37     #
   38     #  For functions
   39     #
   40     limits => [-2,2],
   41     num_points => 5,
   42   },
   43 );
   44 
   45 $context = \$defaultContext;
   46 
   47 
   48 #
   49 #  Precedence of the various types
   50 #    (They will be promoted upward automatically when needed)
   51 #
   52 $$context->{precedence} = {
   53    'Number'   =>  0,
   54    'Real'     =>  1,
   55    'Infinity' =>  2,
   56    'Complex'  =>  3,
   57    'Point'    =>  4,
   58    'Vector'   =>  5,
   59    'Matrix'   =>  6,
   60    'List'     =>  7,
   61    'Interval' =>  8,
   62    'Union'    =>  9,
   63    'String'   => 10,
   64    'Formula'  => 11,
   65    'special'  => 12,
   66 };
   67 
   68 #
   69 #  Binding of perl operator to class method
   70 #
   71 $$context->{method} = {
   72    '+'   => 'add',
   73    '-'   => 'sub',
   74    '*'   => 'mult',
   75    '/'   => 'div',
   76    '**'  => 'power',
   77    '.'   => '_dot',  # see _dot below
   78    'x'   => 'cross',
   79    '<=>' => 'compare',
   80    'cmp' => 'cmp',
   81 };
   82 
   83 $$context->{pattern}{infinite} = '[-+]?inf(?:inity)?';
   84 $$context->{pattern}{infinity} = '\+?inf(?:inity)?';
   85 $$context->{pattern}{-infinity} = '-inf(?:inity)?';
   86 
   87 push(@{$$context->{data}{values}},'method','precedence');
   88 
   89 #############################################################
   90 
   91 #
   92 #  Check if a value is a number, complex, etc.
   93 #
   94 sub matchNumber   {my $n = shift; $n =~ m/^$$context->{pattern}{signedNumber}$/i}
   95 sub matchInfinite {my $n = shift; $n =~ m/^$$context->{pattern}{infinite}$/i}
   96 sub isReal    {class(shift) eq 'Real'}
   97 sub isComplex {class(shift) eq 'Complex'}
   98 sub isFormula {
   99   my $v = shift;
  100   return class($v) eq 'Formula' || (ref($v) && $v->{isFormula});
  101 }
  102 sub isValue   {
  103   my $v = shift;
  104   return (ref($v) || $v) =~ m/^Value::/ || (ref($v) && $v->{isValue});
  105 }
  106 
  107 sub isNumber {
  108   my $n = shift;
  109   return $n->{tree}->isNumber if isFormula($n);
  110   return isReal($n) || isComplex($n) || matchNumber($n);
  111 }
  112 
  113 sub isRealNumber {
  114   my $n = shift;
  115   return $n->{tree}->isRealNumber if isFormula($n);
  116   return isReal($n) || matchNumber($n);
  117 }
  118 
  119 #
  120 #  Convert non-Value objects to Values, if possible
  121 #
  122 sub makeValue {
  123   my $x = shift;
  124   return $x if ref($x);
  125   return Value::Real->make($x) if matchNumber($x);
  126   if (matchInfinite($x)) {
  127     my $I = Value::Infinity->new();
  128     $I = $I->neg if $x =~ m/^$$Value::context->{pattern}{-infinity}$/;
  129     return $I;
  130   }
  131   if ($Parser::installed) {return $x unless $$Value::context->{strings}{$x}}
  132   return Value::String->make($x);
  133 }
  134 
  135 #
  136 #  Get a printable version of the class of an object
  137 #
  138 sub showClass {
  139   my $value = makeValue(shift);
  140   return "'".$value."'" unless Value::isValue($value);
  141   my $class = class($value);
  142   return showType($value) if ($class eq 'List');
  143   $class .= ' Number' if $class =~ m/^(Real|Complex)$/;
  144   $class .= ' of Intervals' if $class eq 'Union';
  145   $class = 'Word' if $class eq 'String';
  146   return 'a Formula that returns '.showType($value->{tree}) if ($class eq 'Formula');
  147   return 'an '.$class if $class =~ m/^[aeio]/i;
  148   return 'a '.$class;
  149 }
  150 
  151 #
  152 #  Get a printable version of the type of an object
  153 #
  154 sub showType {
  155   my $value = shift;
  156   my $type = $value->type;
  157   if ($type eq 'List') {
  158     my $ltype = $value->typeRef->{entryType}{name};
  159     if ($ltype && $ltype ne 'unknown') {
  160       $ltype =~ s/y$/ie/;
  161       $type .= ' of '.$ltype.'s';
  162     }
  163   }
  164   return 'a Word' if $type eq 'String';
  165   return 'a Complex Number' if $value->isComplex;
  166   return 'an '.$type if $type =~ m/^[aeio]/i;
  167   return 'a '.$type;
  168 }
  169 
  170 #
  171 #  Return a string describing a value's type
  172 #
  173 sub getType {
  174   my $equation = shift; my $value = shift;
  175   my $strings = $equation->{context}{strings};
  176   if (ref($value) eq 'ARRAY') {
  177     return 'Interval' if ($value->[0] =~ m/^[(\[]$/ && $value->[-1] =~ m/^[)\]]$/);
  178     my ($type,$ltype);
  179     foreach my $x (@{$value}) {
  180       $type = getType($equation,$x);
  181       if ($type eq 'value') {
  182         $type = $x->type if $x->class eq 'Formula';
  183         $type = 'Number' if $x->class eq 'Complex' || $type eq 'Complex';
  184       }
  185       $ltype = $type if $ltype eq '';
  186       return 'List' if $type ne $ltype;
  187     }
  188     return 'Point' if $ltype eq 'Number';
  189     return 'Matrix' if $ltype =~ m/Point|Matrix/;
  190     return 'List';
  191   }
  192   elsif (Value::isFormula($value)) {return 'Formula'}
  193   elsif (Value::class($value) eq 'Infinity') {return 'String'}
  194   elsif (Value::isReal($value)) {return 'Number'}
  195   elsif (Value::isValue($value)) {return 'value'}
  196   elsif (ref($value)) {return 'unknown'}
  197   elsif (defined($strings->{$value})) {return 'String'}
  198   elsif (Value::isNumber($value)) {return 'Number'}
  199   return 'unknown';
  200 }
  201 
  202 #
  203 #  Get a string describing a value's type,
  204 #    and convert the value to a Value object (if needed)
  205 #
  206 sub getValueType {
  207   my $equation = shift; my $value = shift;
  208   my $type = Value::getType($equation,$value);
  209   if ($type eq 'String') {$type = $Value::Type{string}}
  210   elsif ($type eq 'Number') {$type = $Value::Type{number}}
  211   elsif ($type eq 'value' || $type eq 'Formula') {$type = $value->typeRef}
  212   elsif ($type eq 'unknown') {
  213     $equation->Error("Can't convert ".Value::showClass($value)." to a constant");
  214   } else {
  215     $type = 'Value::'.$type, $value = $type->new(@{$value});
  216     $type = $value->typeRef;
  217   }
  218   return ($value,$type);
  219 }
  220 
  221 #
  222 #  Convert a list of values to a list of formulas (called by Parser::Value)
  223 #
  224 sub toFormula {
  225   my $formula = shift;
  226   my $processed = 0;
  227   my @f = (); my $vars = {};
  228   foreach my $x (@_) {
  229     if (isFormula($x)) {
  230       $formula->{context} = $x->{context}, $processed = 1 unless $processed;
  231       $formula->{variables} = {%{$formula->{variables}},%{$x->{variables}}};
  232       push(@f,$x->{tree}->copy($formula));
  233     } else {
  234       push(@f,Parser::Value->new($formula,$x));
  235     }
  236   }
  237   return (@f);
  238 }
  239 
  240 #
  241 #  Convert a list of values (and open and close parens)
  242 #    to a formula whose type is the list type associated with
  243 #    the parens.  If the formula is constant, evaluate it.
  244 #
  245 sub formula {
  246   my $self = shift; my $values = shift;
  247   my $class = $self->class;
  248   my $list = $$context->lists->get($class);
  249   my $open = $list->{'open'};
  250   my $close = $list->{'close'};
  251   my $paren = $open; $paren = 'list' if $class eq 'List';
  252   my $formula = Value::Formula->blank;
  253   my @coords = Value::toFormula($formula,@{$values});
  254   $formula->{tree} = Parser::List->new($formula,[@coords],0,
  255      $formula->{context}{parens}{$paren},$coords[0]->typeRef,$open,$close);
  256 #   return $formula->eval if scalar(%{$formula->{variables}}) == 0;
  257   return $formula;
  258 }
  259 
  260 #
  261 #  A shortcut for new() that creates an instance of the object,
  262 #    but doesn't do the error checking.  We assume the data are already
  263 #    known to be good.
  264 #
  265 sub make {
  266   my $self = shift; my $class = ref($self) || $self;
  267   bless {data => [@_]}, $class;
  268 }
  269 
  270 #
  271 #  Return a type structure for the item
  272 #    (includes name, length of vectors, and so on)
  273 #
  274 sub Type {
  275   my $name = shift; my $length = shift; my $entryType = shift;
  276   $length = 1 unless defined $length;
  277   return {name => $name, length => $length, entryType => $entryType,
  278           list => (defined $entryType), @_};
  279 }
  280 
  281 #
  282 #  Some predefined types
  283 #
  284 %Type = (
  285   number  => Value::Type('Number',1),
  286   complex => Value::Type('Number',2),
  287   string  => Value::Type('String',1),
  288   unknown => Value::Type('unknown',0,undef,list => 1)
  289 );
  290 
  291 #
  292 #  Return various information about the object
  293 #
  294 sub value {return @{(shift)->{data}}}                  # the value of the object (as an array)
  295 sub data {return (shift)->{data}}                      # the reference to the value
  296 sub length {return (shift)->typeRef->{length}}         # the number of coordinates
  297 sub type {return (shift)->typeRef->{name}}             # the object type
  298 sub entryType {return (shift)->typeRef->{entryType}}   # the coordinate type
  299 #
  300 #  The the full type-hash for the item
  301 #
  302 sub typeRef {
  303   my $self = shift;
  304   return Value::Type($self->class, $self->length, $Value::Type{number});
  305 }
  306 #
  307 #  The Value.pm object class
  308 #
  309 sub class {
  310   my $self = shift; my $class = ref($self) || $self;
  311   $class =~ s/Value:://;
  312   return $class;
  313 }
  314 
  315 #
  316 #  Get an element from a point, vector, matrix, or list
  317 #
  318 sub extract {
  319   my $M = shift; my $i;
  320   while (scalar(@_) > 0) {
  321     return unless Value::isValue($M);
  322     $i = shift; $i-- if $i > 0;
  323     Value::Error("Can't extract element number '$i' (index must be an integer)")
  324       unless $i =~ m/^-?\d+$/;
  325     $M = $M->data->[$i];
  326   }
  327   return $M;
  328 }
  329 
  330 
  331 #
  332 #  Promote an operand to the same precedence as the current object
  333 #
  334 sub promotePrecedence {
  335   my $self = shift; my $other = shift;
  336   my $sprec = $$context->{precedence}{class($self)};
  337   my $oprec = $$context->{precedence}{class($other)};
  338   return (defined($oprec) && $sprec < $oprec) ||
  339     ($sprec > $oprec && $sprec >= $$context->{precedence}{special});
  340 }
  341 
  342 sub promote {shift}
  343 
  344 #
  345 #  Default stub to call when no function is defined for an operation
  346 #
  347 sub nomethod {
  348   my ($l,$r,$flag,$op) = @_;
  349   my $call = $$context->{method}{$op};
  350   if (defined($call) && $l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
  351   my $error = "Can't use '$op' with ".$l->class."-valued operands";
  352   $error .= " (use '**' for exponentiation)" if $op eq '^';
  353   Value::Error($error);
  354 }
  355 
  356 #
  357 #  Stubs for the sub-classes
  358 #
  359 sub add   {nomethod(@_,'+')}
  360 sub sub   {nomethod(@_,'-')}
  361 sub mult  {nomethod(@_,'*')}
  362 sub div   {nomethod(@_,'/')}
  363 sub power {nomethod(@_,'**')}
  364 sub cross {nomethod(@_,'x')}
  365 
  366 #
  367 #  If the right operand is higher precedence, we switch the order.
  368 #
  369 #  If the right operand is also a Value object, we do the object's
  370 #  dot method to combine the two objects of the same class.
  371 #
  372 #  Otherwise, since . is used for string concatenation, we want to retain
  373 #  that.  Since the resulting string is often used in Formula and will be
  374 #  parsed again, we put parentheses around the values to guarantee that
  375 #  the values will be treated as one mathematical unit.  For example, if
  376 #  $f = Formula("1+x") and $g = Formula("y") then Formula("$f/$g") will be
  377 #  (1+x)/y not 1+(x/y), as it would be without the implicit parentheses.
  378 #
  379 sub _dot {
  380   my ($l,$r,$flag) = @_;
  381   return Value::_dot($r,$l,!$flag) if ($l->promotePrecedence($r));
  382   return $l->dot($r,$flag) if (Value::isValue($r));
  383   $l = $l->stringify; $l = '('.$l.')' unless $$Value::context->flag('StringifyAsTeX');
  384   return ($flag)? ($r.$l): ($l.$r);
  385 }
  386 #
  387 #  Some classes override this
  388 #
  389 sub dot {
  390   my ($l,$r,$flag) = @_;
  391   my $tex = $$Value::context->flag('StringifyAsTeX');
  392   $l = $l->stringify; $l = '('.$l.')' if $tex;
  393   if (ref($r)) {$r = $r->stringify; $r = '('.$l.')' if $tex}
  394   return ($flag)? ($r.$l): ($l.$r);
  395 }
  396 
  397 #
  398 #  Compare the values of the objects
  399 #    (list classes should replace this)
  400 #
  401 sub compare {
  402   my ($l,$r,$flag) = @_;
  403   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  404   return $l->value <=> $r->value;
  405 }
  406 
  407 #
  408 #  Compare the values as strings
  409 #
  410 sub cmp {
  411   my ($l,$r,$flag) = @_;
  412   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  413   $l = $l->stringify; $r = $r->stringify if Value::isValue($r);
  414   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  415   return $l cmp $r;
  416 }
  417 
  418 #
  419 #  Generate the various output formats
  420 #  (can be replaced by sub-classes)
  421 #
  422 sub stringify {
  423   my $self = shift;
  424   return $self->TeX() if $$Value::context->flag('StringifyAsTeX');
  425   $self->string;
  426 }
  427 sub string {shift->value}
  428 sub TeX {shift->string(@_)}
  429 #
  430 #  For perl, call the appropriate constructor around the objects data
  431 #
  432 sub perl {
  433   my $self = shift; my $parens = shift; my $matrix = shift;
  434   my $class = $self->class; my $mtype = $class eq 'Matrix';
  435   my $perl; my @p = ();
  436   foreach my $x (@{$self->data}) {
  437     if (Value::isValue($x)) {push(@p,$x->perl(0,$mtype))} else {push(@p,$x)}
  438   }
  439   @p = ("'".$self->{open}."'",@p,"'".$self->{close}."'") if $class eq 'Interval';
  440   if ($matrix) {
  441     $perl = '['.join(',',@p).']';
  442   } else {
  443     $perl = $class.'('.join(',',@p).')';
  444     $perl = '('.$perl.')' if $parens == 1;
  445   }
  446   return $perl;
  447 }
  448 
  449 #
  450 #  Stubs for when called by Parser
  451 #
  452 sub eval {shift}
  453 sub reduce {shift}
  454 
  455 sub ijk {
  456   Value::Error("Can't use method 'ijk' with objects of type '".(shift)->class."'");
  457 }
  458 
  459 #
  460 #  Report an error
  461 #
  462 sub Error {
  463   my $message = shift;
  464   $$context->setError($message,'');
  465   die $message . traceback() if $$context->{debug};
  466   die $message . getCaller();
  467 }
  468 
  469 #
  470 #  Try to locate the line and file where the error occurred
  471 #
  472 sub getCaller {
  473   my $frame = 2;
  474   while (my ($pkg,$file,$line,$subname) = caller($frame++)) {
  475     return " at line $line of $file\n"
  476       unless $pkg =~ /^(Value|Parser)/ ||
  477              $subname =~ m/^(Value|Parser).*(new|call)$/;
  478   }
  479   return "";
  480 }
  481 
  482 #
  483 #  For debugging
  484 #
  485 sub traceback {
  486   my $frame = 2;
  487   my $trace = '';
  488   while (my ($pkg,$file,$line,$subname) = caller($frame++))
  489     {$trace .= " in $subname at line $line of $file\n"}
  490   return $trace;
  491 }
  492 
  493 ###########################################################################
  494 #
  495 #  Load the sub-classes.
  496 #
  497 
  498 use Value::Real;
  499 use Value::Complex;
  500 use Value::Infinity;
  501 use Value::Point;
  502 use Value::Vector;
  503 use Value::Matrix;
  504 use Value::List;
  505 use Value::Interval;
  506 use Value::Union;
  507 use Value::String;
  508 # use Value::Formula;
  509 
  510 use Value::AnswerChecker;  #  for WeBWorK
  511 
  512 ###########################################################################
  513 
  514 use vars qw($installed);
  515 $Value::installed = 1;
  516 
  517 ###########################################################################
  518 ###########################################################################
  519 #
  520 #    To Do:
  521 #
  522 #  Make Complex class include more of Complex1.pm
  523 #  Make better interval comparison
  524 #
  525 ###########################################################################
  526 
  527 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9