[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 5919 - (download) (as text) (annotate)
Tue Sep 23 21:52:56 2008 UTC (11 years, 5 months ago) by dpvc
File size: 30652 byte(s)
Handle the no-inherit values better by deleting them from the copy
before inserting the ones from the original hash.  That way, you don't
lose your copies of those values, you just don't inherit from the
given objects.

    1 package Value;
    2 my $pkg = 'Value';
    3 use vars qw($context $defaultContext %Type);
    4 use Scalar::Util;
    5 use strict; no strict "refs";
    6 
    7 =head1 DESCRIPTION
    8 
    9 Value (also called MathObjects) are intelligent versions of standard mathematical
   10 objects.  They 'know' how to produce string or TeX or perl representations
   11 of themselves.  They also 'know' how to compare themselves to student responses --
   12 in other words they contain their own answer evaluators (response evaluators).
   13 The standard operators like +, -, *, <, ==, >, etc, all work with them (when they
   14 make sense), so that you can use these MathObjects in a natural way.  The comparisons
   15 like equality are "fuzzy", meaning that two items are equal when they are "close enough"
   16 (by tolerances that are set in the current Context).
   17 
   18 =cut
   19 
   20 
   21 =head3 Value context
   22 
   23  #############################################################
   24  #
   25  #  Initialize the context-- flags set
   26  #
   27   The following are list objects, meaning that they involve delimiters (parentheses)
   28   of some type.
   29 
   30   lists => {
   31     'Point'  => {open => '(', close => ')'},
   32     'Vector' => {open => '<', close => '>'},
   33     'Matrix' => {open => '[', close => ']'},
   34     'List'   => {open => '(', close => ')'},
   35     'Set'    => {open => '{', close => '}'},
   36     },
   37 
   38   The following context flags are set:
   39 
   40     #  For vectors:
   41     #
   42     ijk => 0,  # print vectors as <...>
   43     #
   44     #  For strings:
   45     #
   46     allowEmptyStrings => 1,
   47     infiniteWord => 'infinity',
   48     #
   49     #  For intervals and unions:
   50     #
   51     ignoreEndpointTypes => 0,
   52     reduceSets => 1,
   53     reduceSetsForComparison => 1,
   54     reduceUnions => 1,
   55     reduceUnionsForComparison => 1,
   56     #
   57     #  For fuzzy reals:
   58     #
   59     useFuzzyReals => 1,
   60     tolerance    => 1E-4,
   61     tolType      => 'relative',
   62     zeroLevel    => 1E-14,
   63     zeroLevelTol => 1E-12,
   64     #
   65     #  For Formulas:
   66     #
   67     limits       => [-2,2],
   68     num_points   => 5,
   69     granularity  => 1000,
   70     resolution   => undef,
   71     max_adapt    => 1E8,
   72     checkUndefinedPoints => 0,
   73     max_undefined => undef,
   74   },
   75 
   76 
   77 =cut
   78 
   79 BEGIN {
   80 
   81 use Value::Context;
   82 
   83 $defaultContext = Value::Context->new(
   84   lists => {
   85     'Point'  => {open => '(', close => ')'},
   86     'Vector' => {open => '<', close => '>'},
   87     'Matrix' => {open => '[', close => ']'},
   88     'List'   => {open => '(', close => ')'},
   89     'Set'    => {open => '{', close => '}'},
   90   },
   91   flags => {
   92     #
   93     #  For vectors:
   94     #
   95     ijk => 0,  # print vectors as <...>
   96     #
   97     #  For strings:
   98     #
   99     allowEmptyStrings => 1,
  100     infiniteWord => 'infinity',
  101     #
  102     #  For intervals and unions:
  103     #
  104     ignoreEndpointTypes => 0,
  105     reduceSets => 1,
  106     reduceSetsForComparison => 1,
  107     reduceUnions => 1,
  108     reduceUnionsForComparison => 1,
  109     #
  110     #  For fuzzy reals:
  111     #
  112     useFuzzyReals => 1,
  113     tolerance    => 1E-4,
  114     tolType      => 'relative',
  115     zeroLevel    => 1E-14,
  116     zeroLevelTol => 1E-12,
  117     #
  118     #  For Formulas:
  119     #
  120     limits       => [-2,2],
  121     num_points   => 5,
  122     granularity  => 1000,
  123     resolution   => undef,
  124     max_adapt    => 1E8,
  125     checkUndefinedPoints => 0,
  126     max_undefined => undef,
  127   },
  128 );
  129 
  130 $context = \$defaultContext;
  131 
  132 }
  133 
  134 =head3 Implemented MathObject types and their precedence
  135 
  136  #
  137  #  Precedence of the various types
  138  #    (They will be promoted upward automatically when needed)
  139  #
  140 
  141   'Number'   =>  0,
  142    'Real'     =>  1,
  143    'Infinity' =>  2,
  144    'Complex'  =>  3,
  145    'Point'    =>  4,
  146    'Vector'   =>  5,
  147    'Matrix'   =>  6,
  148    'List'     =>  7,
  149    'Interval' =>  8,
  150    'Set'      =>  9,
  151    'Union'    => 10,
  152    'String'   => 11,
  153    'Formula'  => 12,
  154    'special'  => 20,
  155 
  156 =cut
  157 
  158 $$context->{precedence} = {
  159    'Number'   =>  0,
  160    'Real'     =>  1,
  161    'Infinity' =>  2,
  162    'Complex'  =>  3,
  163    'Point'    =>  4,
  164    'Vector'   =>  5,
  165    'Matrix'   =>  6,
  166    'List'     =>  7,
  167    'Interval' =>  8,
  168    'Set'      =>  9,
  169    'Union'    => 10,
  170    'String'   => 11,
  171    'Formula'  => 12,
  172    'special'  => 20,
  173 };
  174 
  175 #
  176 #  Binding of perl operator to class method
  177 #
  178 $$context->{method} = {
  179    '+'   => 'add',
  180    '-'   => 'sub',
  181    '*'   => 'mult',
  182    '/'   => 'div',
  183    '**'  => 'power',
  184    '.'   => '_dot',       # see _dot below
  185    'x'   => 'cross',
  186    '%'   => 'modulo',
  187    '<=>' => 'compare',
  188    'cmp' => 'compare_string',
  189 };
  190 
  191 $$context->{pattern}{infinite} = '[-+]?inf(?:inity)?';
  192 $$context->{pattern}{infinity} = '\+?inf(?:inity)?';
  193 $$context->{pattern}{-infinity} = '-inf(?:inity)?';
  194 
  195 push(@{$$context->{data}{values}},'method','precedence');
  196 
  197 #
  198 #  Copy an item and its data
  199 #
  200 sub copy {
  201   my $self = shift;
  202   my $copy = {%{$self}}; $copy->{data} = [@{$self->{data}}];
  203   foreach my $x (@{$copy->{data}}) {$x = $x->copy if Value::isValue($x)}
  204   return bless $copy, ref($self);
  205 }
  206 
  207 =head3 getFlag
  208 
  209 #
  210 #  Get the value of a flag from the object itself,
  211 #  or from the context, or from the default context
  212 #  or from the given default, whichever is found first.
  213 #
  214 
  215   Usage:   $mathObj->getFlag("showTypeWarnings");
  216            $mathObj->getFlag("showTypeWarnings",1); # default is second parameter
  217 
  218 =cut
  219 
  220 sub getFlag {
  221   my $self = shift; my $name = shift;
  222   if (Value::isHash($self)) {
  223     return $self->{$name} if defined($self->{$name});
  224     if (defined $self->{equation}) {
  225       return $self->{equation}{$name} if defined($self->{equation}{$name});
  226       return $self->{equation}{equation}{$name}
  227   if defined($self->{equation}{equation}) && defined($self->{equation}{equation}{$name});
  228     }
  229   }
  230   my $context = $self->context;
  231   return $context->{answerHash}{$name}
  232     if defined($context->{answerHash}) && defined($context->{answerHash}{$name});  # use WW answerHash flags first
  233   return $context->{flags}{$name} if defined($context->{flags}{$name});
  234   return shift;
  235 }
  236 
  237 #
  238 #  Get or set the context of an object
  239 #
  240 sub context {
  241   my $self = shift; my $context = shift;
  242   if (Value::isHash($self)) {
  243     if ($context && $self->{context} != $context) {
  244       $self->{context} = $context;
  245       if (defined $self->{data}) {
  246         foreach my $x (@{$self->{data}}) {$x->context($context) if Value::isBlessed($x)}
  247       }
  248     }
  249     return $self->{context} if $self->{context};
  250   }
  251   return $$Value::context;
  252 }
  253 
  254 #
  255 #  Set context but return object
  256 #
  257 sub inContext {my $self = shift; $self->context(@_); $self}
  258 
  259 
  260 #############################################################
  261 
  262 #
  263 #
  264 #  The address of a Value object (actually ANY perl value).
  265 #  Use this to compare two objects to see of they are
  266 #  the same object (avoids automatic stringification).
  267 #
  268 sub address {oct(sprintf("0x%p",shift))}
  269 
  270 sub isBlessed {Scalar::Util::blessed(shift) ne ""}
  271 sub blessedClass {Scalar::Util::blessed(shift)}
  272 sub blessedType {Scalar::Util::reftype(shift)}
  273 
  274 sub isa {UNIVERSAL::isa(@_)}
  275 sub can {UNIVERSAL::can(@_)}
  276 
  277 sub isHash {
  278   my $self = shift;
  279   return ref($self) eq 'HASH' || blessedType($self) eq 'HASH';
  280 }
  281 
  282 sub subclassed {
  283   my $self = shift; my $obj = shift; my $method = shift;
  284   my $code = UNIVERSAL::can($obj,$method);
  285   return $code && $code ne $self->can($method);
  286 }
  287 
  288 #
  289 #  Check if a value is a number, complex, etc.
  290 #
  291 sub matchNumber   {my $n = shift; $n =~ m/^$$Value::context->{pattern}{signedNumber}$/i}
  292 sub matchInfinite {my $n = shift; $n =~ m/^$$Value::context->{pattern}{infinite}$/i}
  293 sub isReal    {classMatch(shift,'Real')}
  294 sub isComplex {classMatch(shift,'Complex')}
  295 sub isContext {class(shift) eq 'Context'}
  296 sub isFormula {classMatch(shift,'Formula')}
  297 sub isParser  {my $v = shift; isBlessed($v) && $v->isa('Parser::Item')}
  298 sub isValue {
  299   my $v = shift;
  300   return (ref($v) || $v) =~ m/^Value::/ || (isHash($v) && $v->{isValue}) || isa($v,'Value');
  301 }
  302 
  303 sub isNumber {
  304   my $n = shift;
  305   return $n->{tree}->isNumber if isFormula($n);
  306   return classMatch($n,'Real','Complex') || matchNumber($n);
  307 }
  308 
  309 sub isRealNumber {
  310   my $n = shift;
  311   return $n->{tree}->isRealNumber if isFormula($n);
  312   return isReal($n) || matchNumber($n);
  313 }
  314 
  315 sub isZero {
  316   my $self = shift;
  317   return 0 if scalar(@{$self->{data}}) == 0;
  318   foreach my $x (@{$self->{data}}) {return 0 if $x ne "0"}
  319   return 1;
  320 }
  321 
  322 sub isOne {0}
  323 
  324 sub isSetOfReals {0}
  325 sub canBeInUnion {
  326   my $self = shift;
  327   my $def = $self->context->lists->get($self->class);
  328   my $open = $self->{open}; $open = $def->{open}||$def->{nestedOpen} unless defined $open;
  329   my $close = $self->{close}; $close = $def->{close}||$def->{nestedClose} unless defined $close;
  330   return $self->length == 2 && $self->typeRef->{entryType}{name} eq 'Number' &&
  331     $open =~ m/^[\(\[]$/ && $close =~ m/^[\)\]]$/;
  332 }
  333 
  334 ######################################################################
  335 
  336 #
  337 #  Value->Package(name[,noerror]])
  338 #
  339 #  Returns the package name for the specificied Value object class
  340 #  (as specified by the context's {value} hash, or "Value::name").
  341 #
  342 sub Package {(shift)->context->Package(@_)}
  343 
  344 #  Check if the object class matches one of a list of classes
  345 #
  346 sub classMatch {
  347   my $self = shift;
  348   return $self->classMatch(@_) if Value->subclassed($self,"classMatch");
  349   my $class = class($self); my $ref = ref($self);
  350   my $isHash = ($ref && $ref ne 'ARRAY' && $ref ne 'CODE');
  351   my $context = ($isHash ? $self->{context} || Value->context : Value->context);
  352   foreach my $name (@_) {
  353     my $isName = "is".$name;
  354     return 1 if $class eq $name || $ref eq "Value::$name" ||
  355                 ($isHash && $self->{$isName}) ||
  356     $ref eq $context->Package($name,1) ||
  357     (isa($self,"Value::$name") &&
  358        !($isHash && defined($self->{$isName}) && $self->{$isName} == 0));
  359   }
  360   return 0;
  361 }
  362 
  363 =head3 makeValue
  364 
  365   Usage:  Value::makeValue(45);
  366 
  367   Will create a Real mathObject.
  368  #
  369  #  Convert non-Value objects to Values, if possible
  370  #
  371 
  372 =cut
  373 
  374 sub makeValue {
  375   my $x = shift; return $x if Value::isValue($x);
  376   my %params = (showError => 0, makeFormula => 1, context => Value->context, @_);
  377   my $context = $params{context};
  378   return $context->Package("Real")->make($context,$x) if matchNumber($x);
  379   if (matchInfinite($x)) {
  380     my $I = $context->Package("Infinity")->new($context);
  381     $I = $I->neg if $x =~ m/^$context->{pattern}{-infinity}$/;
  382     return $I;
  383   }
  384   return $context->Package("String")->make($context,$x)
  385     if !$Parser::installed || $context->{strings}{$x} ||
  386        ($x eq '' && $context->{flags}{allowEmptyStrings});
  387   return $x if !$params{makeFormula};
  388   Value::Error("String constant '%s' is not defined in this context",$x)
  389     if $params{showError};
  390   $x = $context->Package("Formula")->new($context,$x);
  391   $x = $x->eval if $x->isConstant;
  392   return $x;
  393 }
  394 
  395 =head3 showClass
  396 
  397   Usage:   TEXT( $mathObj -> showClass() );
  398 
  399     Will print the class of the MathObject
  400 
  401  #
  402  #  Get a printable version of the class of an object
  403  #  (used primarily in error messages)
  404  #
  405 
  406 =cut
  407 
  408 sub showClass {
  409   my $value = shift;
  410   if (ref($value) || $value !~ m/::/) {
  411     $value = Value::makeValue($value,makeFormula=>0);
  412     return "'".$value."'" unless Value::isValue($value);
  413   }
  414   return $value->showClass(@_) if Value->subclassed($value,"showClass");
  415   my $class = class($value);
  416   return showType($value) if Value::classMatch($value,'List');
  417   $class .= ' Number' if Value::classMatch($value,'Real','Complex');
  418   $class .= ' of Intervals' if Value::classMatch($value,'Union');
  419   $class = ($value eq '' ? 'Empty Value' : 'Word') if Value::classMatch($value,'String');
  420   return 'a Formula that returns '.showType($value->{tree}) if Value::isFormula($value);
  421   return 'an '.$class if $class =~ m/^[aeio]/i;
  422   return 'a '.$class;
  423 }
  424 
  425 =head3 showType
  426 
  427   Usage:   TEXT( $mathObj -> showType() );
  428 
  429     Will print the class of the MathObject
  430 
  431  #
  432  #  Get a printable version of the type of an object
  433  #  (the class and type are not the same.  For example
  434  #  a Formula-class object can be of type Number)
  435  #
  436 
  437 =cut
  438 
  439 sub showType {
  440   my $value = shift;
  441   my $type = $value->type;
  442   if ($type eq 'List') {
  443     my $ltype = $value->typeRef->{entryType}{name};
  444     if ($ltype && $ltype ne 'unknown') {
  445       $ltype =~ s/y$/ie/;
  446       $type .= ' of '.$ltype.'s';
  447     }
  448   }
  449   return 'an Infinity' if $type eq 'String' && $value->{isInfinite};
  450   return 'an Empty Value' if $type eq 'String' && $value eq '';
  451   return 'a Word' if $type eq 'String';
  452   return 'a Complex Number' if $value->isComplex;
  453   return 'an '.$type if $type =~ m/^[aeio]/i;
  454   return 'a '.$type;
  455 }
  456 
  457 #
  458 #  Return a string describing a value's type
  459 #
  460 sub getType {
  461   my $equation = shift; my $value = shift;
  462   return $value->getType($equation,@_) if Value->subclassed($value,"getType");
  463   my $strings = $equation->{context}{strings};
  464   if (ref($value) eq 'ARRAY') {
  465     return 'Interval' if ($value->[0] =~ m/^[(\[]$/ && $value->[-1] =~ m/^[)\]]$/);
  466     my ($type,$ltype);
  467     foreach my $x (@{$value}) {
  468       $type = getType($equation,$x);
  469       if ($type eq 'value') {
  470         $type = $x->type if $x->classMatch('Formula');
  471         $type = 'Number' if $x->classMatch('Complex') || $type eq 'Complex';
  472       }
  473       $ltype = $type if $ltype eq '';
  474       return 'List' if $type ne $ltype;
  475     }
  476     return 'Point'  if $ltype eq 'Number';
  477     return 'Matrix' if $ltype =~ m/Point|Matrix/;
  478     return 'List';
  479   }
  480   return 'Formula'  if Value::isFormula($value);
  481   return 'Infinity' if Value::classMatch($value,'Infinity');
  482   return 'Number'   if Value::isReal($value);
  483   return 'value'    if Value::isValue($value);
  484   return 'unknown'  if ref($value);
  485   return 'String'   if defined($strings->{$value});
  486   return 'Number'   if Value::isNumber($value);
  487   return 'String'   if $value eq '' && $equation->{context}{flags}{allowEmptyStrings};
  488   return 'unknown';
  489 }
  490 
  491 #
  492 #  Get a string describing a value's type,
  493 #    and convert the value to a Value object (if needed)
  494 #
  495 sub getValueType {
  496   my $equation = shift; my $value = shift;
  497   return $value->getValueType($equation,@_) if Value->subclassed($value,"getValueType");
  498   my $type = Value::getType($equation,$value);
  499   if ($type eq 'String') {$type = $Value::Type{string}}
  500   elsif ($type eq 'Number') {$type = $Value::Type{number}}
  501   elsif ($type eq 'Infinity') {$type = $Value::Type{infinity}}
  502   elsif ($type eq 'value' || $type eq 'Formula') {$type = $value->typeRef}
  503   elsif ($type eq 'unknown') {
  504     $equation->Error(["Can't convert %s to a constant",Value::showClass($value)]);
  505   } else {
  506     $type = $equation->{context}->Package($type);
  507     $value = $type->new($equation->{context},@{$value});
  508     $type = $value->typeRef;
  509   }
  510   return ($value,$type);
  511 }
  512 
  513 #
  514 #  Convert a list of values to a list of formulas (called by Parser::Value)
  515 #
  516 sub toFormula {
  517   my $formula = shift;
  518   my $processed = 0;
  519   my @f = (); my $vars = {};
  520   foreach my $x (@_) {
  521     if (isFormula($x)) {
  522       $formula->{context} = $x->{context}, $processed = 1 unless $processed;
  523       $formula->{variables} = {%{$formula->{variables}},%{$x->{variables}}};
  524       push(@f,$x->{tree}->copy($formula));
  525     } else {
  526       push(@f,$formula->Item("Value")->new($formula,$x));
  527     }
  528   }
  529   return (@f);
  530 }
  531 
  532 #
  533 #  Convert a list of values (and open and close parens)
  534 #    to a formula whose type is the list type associated with
  535 #    the parens.
  536 #
  537 sub formula {
  538   my $self = shift; my $values = shift;
  539   my $context = $self->context;
  540   my $list = $context->lists->get($self->class);
  541   my $open = $list->{'open'};
  542   my $close = $list->{'close'};
  543   my $paren = $open; $paren = 'list' if $self->classMatch('List');
  544   my $formula = $self->Package("Formula")->blank($context);
  545   my @coords = Value::toFormula($formula,@{$values});
  546   $formula->{tree} = $formula->Item("List")->new($formula,[@coords],0,
  547      $formula->{context}{parens}{$paren},$coords[0]->typeRef,$open,$close);
  548   $formula->{autoFormula} = 1;  # mark that this was generated automatically
  549   return $formula;
  550 }
  551 
  552 #
  553 #  A shortcut for new() that creates an instance of the object,
  554 #    but doesn't do the error checking.  We assume the data are already
  555 #    known to be good.
  556 #
  557 sub make {
  558   my $self = shift; my $class = ref($self) || $self;
  559   my $context = (Value::isContext($_[0]) ? shift : $self->context);
  560   bless {$self->hash, data => [@_], context => $context}, $class;
  561 }
  562 
  563 #
  564 #  Easy method for setting parameters of an object
  565 #  (returns a copy with the new values set, but the copy
  566 #  is not a deep copy.)
  567 #
  568 sub with {
  569   my $self = shift;
  570   bless {%{$self},@_}, ref($self);
  571 }
  572 
  573 #
  574 #  Return a copy with the specified fields removed
  575 #
  576 sub without {
  577   my $self = shift;
  578   $self = bless {%{$self}}, ref($self);
  579   foreach my $id (@_) {delete $self->{$id} if defined $self->{$id}}
  580   return $self;
  581 }
  582 
  583 ######################################################################
  584 
  585 #
  586 #  Return the hash data as an array of key=>value pairs
  587 #
  588 sub hash {
  589   my $self = shift;
  590   return %$self if isHash($self);
  591   return ();
  592 }
  593 
  594 #
  595 #  Copy attributes that are not already in the current object
  596 #  from the given objects.  (Used by binary operators to make sure
  597 #  the result inherits the values from the two terms.)
  598 #
  599 sub inherit {
  600   my $self = shift;
  601   my %copy = (map {%$_} @_);  # copy values from given objects
  602   foreach my $id ($self->noinherit) {delete $copy{$id}}
  603   $self = bless {%copy,%$self}, ref($self);
  604   return $self;
  605 }
  606 
  607 #
  608 #  The list of fields NOT to inherit.
  609 #  Use the default list plus any specified explicitly in the object itself.
  610 #  Subclasses can override and return additional fields, if necessary.
  611 #
  612 sub noinherit {
  613   my $self = shift;
  614   ("correct_ans","original_formula","equation",@{$self->{noinherit}||[]});
  615 }
  616 
  617 ######################################################################
  618 
  619 #
  620 #  Return a type structure for the item
  621 #    (includes name, length of vectors, and so on)
  622 #
  623 sub Type {
  624   my $name = shift; my $length = shift; my $entryType = shift;
  625   $length = 1 unless defined $length;
  626   return {name => $name, length => $length, entryType => $entryType,
  627           list => (defined $entryType), @_};
  628 }
  629 
  630 #
  631 #  Some predefined types
  632 #
  633 %Type = (
  634   number   => Value::Type('Number',1),
  635   complex  => Value::Type('Number',2),
  636   string   => Value::Type('String',1),
  637   infinity => Value::Type('Infinity',1),
  638   interval => Value::Type('Interval',2),
  639   unknown  => Value::Type('unknown',0,undef,list => 1)
  640 );
  641 
  642 #
  643 #  Return various information about the object
  644 #
  645 sub value {return @{(shift)->{data}}}                  # the value of the object (as an array)
  646 sub data {return (shift)->{data}}                      # the reference to the value
  647 sub length {return scalar(@{(shift)->{data}})}         # the number of coordinates
  648 sub type {return (shift)->typeRef->{name}}             # the object type
  649 sub entryType {return (shift)->typeRef->{entryType}}   # the coordinate type
  650 #
  651 #  The the full type-hash for the item
  652 #
  653 sub typeRef {
  654   my $self = shift;
  655   return Value::Type($self->class, $self->length, $Value::Type{number});
  656 }
  657 #
  658 #  The Value.pm object class
  659 #
  660 sub class {
  661   my $self = shift;
  662   return $self->class(@_) if Value->subclassed($self,"class");
  663   my $class = ref($self) || $self; $class =~ s/.*:://;
  664   return $class;
  665 }
  666 
  667 #
  668 #  Get an element from a point, vector, matrix, or list
  669 #
  670 sub extract {
  671   my $M = shift; my $i; my @indices = @_;
  672   return unless Value::isValue($M);
  673   @indices = $_[0]->value if scalar(@_) == 1 && Value::isValue($_[0]);
  674   while (scalar(@indices) > 0) {
  675     return if Value::isNumber($M);
  676     $i = shift @indices; $i = $i->value if Value::isValue($i);
  677     Value::Error("Can't extract element number '%s' (index must be an integer)",$i)
  678       unless $i =~ m/^-?\d+$/;
  679     return if $i == 0; $i-- if $i > 0;
  680     $M = $M->data->[$i];
  681   }
  682   return $M;
  683 }
  684 
  685 ######################################################################
  686 
  687 use overload
  688        '+'   => '_add',
  689        '-'   => '_sub',
  690        '*'   => '_mult',
  691        '/'   => '_div',
  692        '**'  => '_power',
  693        '.'   => '_dot',
  694        'x'   => '_cross',
  695        '%'   => '_modulo',
  696        '<=>' => '_compare',
  697        'cmp' => '_compare_string',
  698        '~'   => '_twiddle',
  699        'neg' => '_neg',
  700        'abs' => '_abs',
  701        'sqrt'=> '_sqrt',
  702        'exp' => '_exp',
  703        'log' => '_log',
  704        'sin' => '_sin',
  705        'cos' => '_cos',
  706      'atan2' => '_atan2',
  707   'nomethod' => 'nomethod',
  708         '""' => 'stringify';
  709 
  710 #
  711 #  Promote an operand to the same precedence as the current object
  712 #
  713 sub promotePrecedence {
  714   my $self = shift; my $other = shift; my $context = $self->context;
  715   return 0 unless Value::isValue($other);
  716   my $sprec = $self->precedence; my $oprec = $other->precedence;
  717   return (defined($sprec) && defined($oprec) && $sprec < $oprec);
  718 }
  719 
  720 sub precedence {my $self = shift; return $self->context->{precedence}{$self->class}}
  721 
  722 sub promote {
  723   my $self = shift; my $class = ref($self) || $self;
  724   my $context = (Value::isContext($_[0]) ? shift : $self->context);
  725   my $x = (scalar(@_) ? shift : $self);
  726   return $x->inContext($context) if ref($x) eq $class && scalar(@_) == 0;
  727   return $self->new($context,$x,@_);
  728 }
  729 
  730 #
  731 #  Return the operators in the correct order
  732 #
  733 sub checkOpOrder {
  734   my ($l,$r,$flag) = @_;
  735   if ($flag) {return ($l,$r,$l,$r)} else {return ($l,$l,$r,$r)}
  736 }
  737 
  738 #
  739 #  Return the operators in the correct order, and promote the
  740 #  other value, if needed.
  741 #
  742 sub checkOpOrderWithPromote {
  743   my ($l,$r,$flag) = @_; $r = $l->promote($r);
  744   if ($flag) {return ($l,$r,$l,$r)} else {return ($l,$l,$r,$r)}
  745 }
  746 
  747 #
  748 #  Handle a binary operator, promoting the object types
  749 #  as needed, and then calling the main method
  750 #
  751 sub binOp {
  752   my ($l,$r,$flag,$call) = @_;
  753   if ($l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
  754                             else {return $l->$call($r,$flag)}
  755 }
  756 
  757 #
  758 #  stubs for binary operations (with promotion)
  759 #
  760 sub _add            {binOp(@_,'add')}
  761 sub _sub            {binOp(@_,'sub')}
  762 sub _mult           {binOp(@_,'mult')}
  763 sub _div            {binOp(@_,'div')}
  764 sub _power          {binOp(@_,'power')}
  765 sub _cross          {binOp(@_,'cross')}
  766 sub _modulo         {binOp(@_,'modulo')}
  767 
  768 sub _compare        {transferTolerances(@_); binOp(@_,'compare')}
  769 sub _compare_string {binOp(@_,'compare_string')}
  770 
  771 sub _atan2          {binOp(@_,'atan2')}
  772 
  773 sub _twiddle        {(shift)->twiddle}
  774 sub _neg            {(shift)->neg}
  775 sub _abs            {(shift)->abs}
  776 sub _sqrt           {(shift)->sqrt}
  777 sub _exp            {(shift)->exp}
  778 sub _log            {(shift)->log}
  779 sub _sin            {(shift)->sin}
  780 sub _cos            {(shift)->cos}
  781 
  782 #
  783 #  Default stub to call when no function is defined for an operation
  784 #
  785 sub nomethod {
  786   my ($l,$r,$flag,$op) = @_;
  787   my $call = $l->context->{method}{$op};
  788   if (defined($call) && $l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
  789   my $error = "Can't use '%s' with %s-valued operands";
  790   $error .= " (use '**' for exponentiation)" if $op eq '^';
  791   Value::Error($error,$op,$l->class);
  792 }
  793 
  794 sub nodef {
  795   my $self = shift; my $func = shift;
  796   Value::Error("Can't use '%s' with %s-valued operands",$func,$self->class);
  797 }
  798 
  799 #
  800 #  Stubs for the sub-classes
  801 #
  802 sub add    {nomethod(@_,'+')}
  803 sub sub    {nomethod(@_,'-')}
  804 sub mult   {nomethod(@_,'*')}
  805 sub div    {nomethod(@_,'/')}
  806 sub power  {nomethod(@_,'**')}
  807 sub cross  {nomethod(@_,'x')}
  808 sub modulo {nomethod(@_,'%')}
  809 
  810 sub twiddle {nodef(shift,"~")}
  811 sub neg     {nodef(shift,"-")}
  812 sub abs     {nodef(shift,"abs")}
  813 sub sqrt    {nodef(shift,"sqrt")}
  814 sub exp     {nodef(shift,"exp")}
  815 sub log     {nodef(shift,"log")}
  816 sub sin     {nodef(shift,"sin")}
  817 sub cos     {nodef(shift,"cos")}
  818 
  819 #
  820 #  If the right operand is higher precedence, we switch the order.
  821 #
  822 #  If the right operand is also a Value object, we do the object's
  823 #  dot method to combine the two objects of the same class.
  824 #
  825 #  Otherwise, since . is used for string concatenation, we want to retain
  826 #  that.  Since the resulting string is often used in Formula and will be
  827 #  parsed again, we put parentheses around the values to guarantee that
  828 #  the values will be treated as one mathematical unit.  For example, if
  829 #  $f = Formula("1+x") and $g = Formula("y") then Formula("$f/$g") will be
  830 #  (1+x)/y not 1+(x/y), as it would be without the implicit parentheses.
  831 #
  832 sub _dot {
  833   my ($l,$r,$flag) = @_;
  834   return $r->_dot($l,!$flag) if ($l->promotePrecedence($r));
  835   return $l->dot($r,$flag) if (Value::isValue($r));
  836   if (Value->context->flag('StringifyAsTeX')) {$l = $l->TeX} else {$l = $l->pdot}
  837   return ($flag)? ($r.$l): ($l.$r);
  838 }
  839 #
  840 #  Some classes override this
  841 #
  842 sub dot {
  843   my ($l,$r,$flag) = @_;
  844   my $tex = Value->context->flag('StringifyAsTeX');
  845   if ($tex) {$l = $l->TeX} else {$l = $l->pdot}
  846   if (Value::isBlessed($r)) {if ($tex) {$r = $r->TeX} else {$r = $r->pdot}}
  847   return ($flag)? ($r.$l): ($l.$r);
  848 }
  849 
  850 #
  851 #  Some classes override this to add parens
  852 #
  853 sub pdot {shift->stringify}
  854 
  855 
  856 #
  857 #  Compare the values of the objects
  858 #    (list classes should replace this)
  859 #
  860 sub compare {
  861   my ($l,$r) = Value::checkOpOrder(@_);
  862   return $l->value <=> $r->value;
  863 }
  864 
  865 #
  866 #  Compare the values as strings
  867 #
  868 sub compare_string {
  869   my ($l,$r,$flag) = @_;
  870   $l = $l->string; $r = $r->string if Value::isValue($r);
  871   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  872   return $l cmp $r;
  873 }
  874 
  875 #
  876 #  Copy flags from the parent object to its children (recursively).
  877 #
  878 sub transferFlags {
  879   my $self = shift;
  880   foreach my $flag (@_) {
  881     next unless defined $self->{$flag};
  882     foreach my $x (@{$self->{data}}) {
  883       if ($x->{$flag} ne $self->{$flag}) {
  884   $x->{$flag} = $self->{$flag};
  885   $x->transferFlags($flag);
  886       }
  887     }
  888   }
  889 }
  890 
  891 sub transferTolerances {
  892   my ($self,$other) = @_;
  893   $self->transferFlags("tolerance","tolType","zeroLevel","zeroLevelTol");
  894   $other->transferFlags("tolerance","tolType","zeroLevel","zeroLevelTol") if Value::isValue($other);
  895 }
  896 
  897 =head3 output methods for MathObjects
  898 
  899  #
  900  #  Generate the various output formats
  901  #  (can be replaced by sub-classes)
  902  #
  903 
  904 =cut
  905 
  906 =head4 stringify
  907 
  908   Usage:   TEXT($mathObj); or TEXT( $mathObj->stringify() ) ;
  909 
  910     Produces text string or TeX output depending on context
  911       Context()->texStrings;
  912       Context()->normalStrings;
  913 
  914     called automatically when object is called in a string context.
  915 
  916 =cut
  917 
  918 sub stringify {
  919   my $self = shift;
  920   return $self->TeX if Value->context->flag('StringifyAsTeX');
  921   return $self->string;
  922 }
  923 
  924 =head4 ->string
  925 
  926   Usage: $mathObj->string()
  927 
  928   ---produce a string representation of the object
  929            (as opposed to stringify, which can produce TeX or string versions)
  930 
  931 =cut
  932 
  933 sub string {
  934   my $self = shift; my $equation = shift;
  935   my $def = ($equation->{context} || $self->context)->lists->get($self->class);
  936   return $self->value unless $def;
  937   my $open = shift; my $close = shift;
  938   $open  = $self->{open}  unless defined($open);
  939   $open  = $def->{open}   unless defined($open);
  940   $close = $self->{close} unless defined($close);
  941   $close = $def->{close}  unless defined($close);
  942   my @coords = ();
  943   foreach my $x (@{$self->data}) {
  944     if (Value::isValue($x)) {
  945       $x->{format} = $self->{format} if defined $self->{format};
  946       push(@coords,$x->string($equation));
  947     } else {
  948       push(@coords,$x);
  949     }
  950   }
  951   return $open.join($def->{separator},@coords).$close;
  952 }
  953 
  954 =head4 ->TeX
  955 
  956   Usage: $mathObj->TeX()
  957 
  958   ---produce TeX prepresentation of the object
  959 
  960 =cut
  961 
  962 sub TeX {
  963   my $self = shift; my $equation = shift;
  964   my $context = $equation->{context} || $self->context;
  965   my $def = $context->lists->get($self->class);
  966   return $self->string(@_) unless $def;
  967   my $open = shift; my $close = shift;
  968   $open  = $self->{open}  unless defined($open);
  969   $open  = $def->{open}   unless defined($open);
  970   $close = $self->{close} unless defined($close);
  971   $close = $def->{close}  unless defined($close);
  972   $open =~ s/([{}])/\\$1/g; $close =~ s/([{}])/\\$1/g;
  973   $open = '\left'.$open if $open; $close = '\right'.$close if $close;
  974   my @coords = (); my $str = $context->{strings};
  975   foreach my $x (@{$self->data}) {
  976     if (Value::isValue($x)) {
  977       $x->{format} = $self->{format} if defined $self->{format};
  978       push(@coords,$x->TeX($equation));
  979     } elsif (defined($str->{$x}) && $str->{$x}{TeX}) {push(@coords,$str->{$x}{TeX})}
  980     else {push(@coords,$x)}
  981   }
  982   return $open.join(',',@coords).$close;
  983 }
  984 
  985 #
  986 #  For perl, call the appropriate constructor around the object's data
  987 #
  988 sub perl {
  989   my $self = shift; my $parens = shift; my $matrix = shift;
  990   my $mtype = $self->classMatch('Matrix'); $mtype = -1 if $mtype & !$matrix;
  991   my $perl; my @p = ();
  992   foreach my $x (@{$self->data}) {
  993     if (Value::isValue($x)) {push(@p,$x->perl(0,$mtype))} else {push(@p,$x)}
  994   }
  995   @p = ("'".$self->{open}."'",@p,"'".$self->{close}."'") if $self->classMatch('Interval');
  996   if ($matrix) {
  997     $perl = join(',',@p);
  998     $perl = '['.$perl.']' if $mtype > 0;
  999   } else {
 1000     $perl = ref($self).'->new('.join(',',@p).')';
 1001     $perl = "($perl)->with(open=>'$self->{open}',close=>'$self->{close}')"
 1002       if $self->classMatch('List') && $self->{open}.$self->{close} ne '()';
 1003     $perl = '('.$perl.')' if $parens == 1;
 1004   }
 1005   return $perl;
 1006 }
 1007 
 1008 #
 1009 #  Stubs for when called by Parser
 1010 #
 1011 sub eval {shift}
 1012 sub reduce {shift}
 1013 
 1014 sub ijk {
 1015   Value::Error("Can't use method 'ijk' with objects of type '%s'",(shift)->class);
 1016 }
 1017 
 1018 
 1019 =head3 Error
 1020 
 1021   Usage: Value->Error("We're sorry...");
 1022            or  $mathObject->Error("We're still sorry...");
 1023 
 1024  #
 1025  #  Report an error and die.  This can be used within custom answer checkers
 1026  #  to report errors during the check, or when sub-classing a MathObject to
 1027  #  report error conditions.
 1028  #
 1029 
 1030 =cut
 1031 
 1032 sub Error {
 1033   my $self = (UNIVERSAL::can($_[0],"getFlag") ? shift : "Value");
 1034   my $message = shift; my $context = $self->context;
 1035   $message = [$message,@_] if scalar(@_) > 0;
 1036   $context->setError($message,'');
 1037   $message = $context->{error}{message};
 1038   die $message . traceback() if $self->getFlag('showTraceback');
 1039   die $message . getCaller();
 1040 }
 1041 
 1042 #
 1043 #  Try to locate the line and file where the error occurred
 1044 #
 1045 sub getCaller {
 1046   my $frame = 2;
 1047   while (my ($pkg,$file,$line,$subname) = caller($frame++)) {
 1048     return " at line $line of $file\n"
 1049       unless $pkg =~ /^(Value|Parser)/ ||
 1050              $subname =~ m/^(Value|Parser).*(new|call)$/;
 1051   }
 1052   return "";
 1053 }
 1054 
 1055 #
 1056 #  For debugging
 1057 #
 1058 sub traceback {
 1059   my $frame = shift; $frame = 2 unless defined($frame);
 1060   my $trace = '';
 1061   while (my ($pkg,$file,$line,$subname) = caller($frame++))
 1062     {$trace .= " in $subname at line $line of $file\n"}
 1063   return $trace;
 1064 }
 1065 
 1066 ###########################################################################
 1067 #
 1068 #  Load the sub-classes.
 1069 #
 1070 
 1071 END {
 1072   use Value::Real;
 1073   use Value::Complex;
 1074   use Value::Infinity;
 1075   use Value::Point;
 1076   use Value::Vector;
 1077   use Value::Matrix;
 1078   use Value::List;
 1079   use Value::Interval;
 1080   use Value::Set;
 1081   use Value::Union;
 1082   use Value::String;
 1083   use Value::Formula;
 1084 
 1085   use Value::WeBWorK;  # stuff specific to WeBWorK
 1086 }
 1087 
 1088 ###########################################################################
 1089 
 1090 our $installed = 1;
 1091 
 1092 ###########################################################################
 1093 
 1094 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9