[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 6207 - (download) (as text) (annotate)
Mon Feb 22 13:54:02 2010 UTC (9 years, 9 months ago) by dpvc
File size: 30730 byte(s)
Make inherit() properly not inherit the noinherit attributes from self

    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;
  376   my %params = (showError => 0, makeFormula => 1, context => Value->context, @_);
  377   my $context = $params{context};
  378   if (Value::isValue($x)) {
  379     return $x unless {@_}->{context};
  380     return $x->copy->inContext($context);
  381   }
  382   return $context->Package("Real")->make($context,$x) if matchNumber($x);
  383   if (matchInfinite($x)) {
  384     my $I = $context->Package("Infinity")->new($context);
  385     $I = $I->neg if $x =~ m/^$context->{pattern}{-infinity}$/;
  386     return $I;
  387   }
  388   return $context->Package("String")->make($context,$x)
  389     if !$Parser::installed || $context->{strings}{$x} ||
  390        ($x eq '' && $context->{flags}{allowEmptyStrings});
  391   return $x if !$params{makeFormula};
  392   Value::Error("String constant '%s' is not defined in this context",$x)
  393     if $params{showError};
  394   $x = $context->Package("Formula")->new($context,$x);
  395   $x = $x->eval if $x->isConstant;
  396   return $x;
  397 }
  398 
  399 =head3 showClass
  400 
  401   Usage:   TEXT( $mathObj -> showClass() );
  402 
  403     Will print the class of the MathObject
  404 
  405  #
  406  #  Get a printable version of the class of an object
  407  #  (used primarily in error messages)
  408  #
  409 
  410 =cut
  411 
  412 sub showClass {
  413   my $value = shift;
  414   if (ref($value) || $value !~ m/::/) {
  415     $value = Value::makeValue($value,makeFormula=>0);
  416     return "'".$value."'" unless Value::isValue($value);
  417   }
  418   return $value->showClass(@_) if Value->subclassed($value,"showClass");
  419   my $class = class($value);
  420   return showType($value) if Value::classMatch($value,'List');
  421   $class .= ' Number' if Value::classMatch($value,'Real','Complex');
  422   $class .= ' of Intervals' if Value::classMatch($value,'Union');
  423   $class = ($value eq '' ? 'Empty Value' : 'Word') if Value::classMatch($value,'String');
  424   return 'a Formula that returns '.showType($value->{tree}) if Value::isFormula($value);
  425   return 'an '.$class if $class =~ m/^[aeio]/i;
  426   return 'a '.$class;
  427 }
  428 
  429 =head3 showType
  430 
  431   Usage:   TEXT( $mathObj -> showType() );
  432 
  433     Will print the class of the MathObject
  434 
  435  #
  436  #  Get a printable version of the type of an object
  437  #  (the class and type are not the same.  For example
  438  #  a Formula-class object can be of type Number)
  439  #
  440 
  441 =cut
  442 
  443 sub showType {
  444   my $value = shift;
  445   my $type = $value->type;
  446   if ($type eq 'List') {
  447     my $ltype = $value->typeRef->{entryType}{name};
  448     if ($ltype && $ltype ne 'unknown') {
  449       $ltype =~ s/y$/ie/;
  450       $type .= ' of '.$ltype.'s';
  451     }
  452   }
  453   return 'an Infinity' if $type eq 'String' && $value->{isInfinite};
  454   return 'an Empty Value' if $type eq 'String' && $value eq '';
  455   return 'a Word' if $type eq 'String';
  456   return 'a Complex Number' if $value->isComplex;
  457   return 'an '.$type if $type =~ m/^[aeio]/i;
  458   return 'a '.$type;
  459 }
  460 
  461 #
  462 #  Return a string describing a value's type
  463 #
  464 sub getType {
  465   my $equation = shift; my $value = shift;
  466   return $value->getType($equation,@_) if Value->subclassed($value,"getType");
  467   my $strings = $equation->{context}{strings};
  468   if (ref($value) eq 'ARRAY') {
  469     return 'Interval' if ($value->[0] =~ m/^[(\[]$/ && $value->[-1] =~ m/^[)\]]$/);
  470     my ($type,$ltype);
  471     foreach my $x (@{$value}) {
  472       $type = getType($equation,$x);
  473       if ($type eq 'value') {
  474         $type = $x->type if $x->classMatch('Formula');
  475         $type = 'Number' if $x->classMatch('Complex') || $type eq 'Complex';
  476       }
  477       $ltype = $type if $ltype eq '';
  478       return 'List' if $type ne $ltype;
  479     }
  480     return 'Point'  if $ltype eq 'Number';
  481     return 'Matrix' if $ltype =~ m/Point|Matrix/;
  482     return 'List';
  483   }
  484   return 'Formula'  if Value::isFormula($value);
  485   return 'Infinity' if Value::classMatch($value,'Infinity');
  486   return 'Number'   if Value::isReal($value);
  487   return 'value'    if Value::isValue($value);
  488   return 'unknown'  if ref($value);
  489   return 'String'   if defined($strings->{$value});
  490   return 'Number'   if Value::isNumber($value);
  491   return 'String'   if $value eq '' && $equation->{context}{flags}{allowEmptyStrings};
  492   return 'unknown';
  493 }
  494 
  495 #
  496 #  Get a string describing a value's type,
  497 #    and convert the value to a Value object (if needed)
  498 #
  499 sub getValueType {
  500   my $equation = shift; my $value = shift;
  501   return $value->getValueType($equation,@_) if Value->subclassed($value,"getValueType");
  502   my $type = Value::getType($equation,$value);
  503   if ($type eq 'String') {$type = $Value::Type{string}}
  504   elsif ($type eq 'Number') {$type = $Value::Type{number}}
  505   elsif ($type eq 'Infinity') {$type = $Value::Type{infinity}}
  506   elsif ($type eq 'value' || $type eq 'Formula') {$type = $value->typeRef}
  507   elsif ($type eq 'unknown') {
  508     $equation->Error(["Can't convert %s to a constant",Value::showClass($value)]);
  509   } else {
  510     $type = $equation->{context}->Package($type);
  511     $value = $type->new($equation->{context},@{$value});
  512     $type = $value->typeRef;
  513   }
  514   return ($value,$type);
  515 }
  516 
  517 #
  518 #  Convert a list of values to a list of formulas (called by Parser::Value)
  519 #
  520 sub toFormula {
  521   my $formula = shift;
  522   my $processed = 0;
  523   my @f = (); my $vars = {};
  524   foreach my $x (@_) {
  525     if (isFormula($x)) {
  526       $formula->{context} = $x->{context}, $processed = 1 unless $processed;
  527       $formula->{variables} = {%{$formula->{variables}},%{$x->{variables}}};
  528       push(@f,$x->{tree}->copy($formula));
  529     } else {
  530       push(@f,$formula->Item("Value")->new($formula,$x));
  531     }
  532   }
  533   return (@f);
  534 }
  535 
  536 #
  537 #  Convert a list of values (and open and close parens)
  538 #    to a formula whose type is the list type associated with
  539 #    the parens.
  540 #
  541 sub formula {
  542   my $self = shift; my $values = shift;
  543   my $context = $self->context;
  544   my $list = $context->lists->get($self->class);
  545   my $open = $list->{'open'};
  546   my $close = $list->{'close'};
  547   my $paren = $open; $paren = 'list' if $self->classMatch('List');
  548   my $formula = $self->Package("Formula")->blank($context);
  549   my @coords = Value::toFormula($formula,@{$values});
  550   $formula->{tree} = $formula->Item("List")->new($formula,[@coords],0,
  551      $formula->{context}{parens}{$paren},$coords[0]->typeRef,$open,$close);
  552   $formula->{autoFormula} = 1;  # mark that this was generated automatically
  553   return $formula;
  554 }
  555 
  556 #
  557 #  A shortcut for new() that creates an instance of the object,
  558 #    but doesn't do the error checking.  We assume the data are already
  559 #    known to be good.
  560 #
  561 sub make {
  562   my $self = shift; my $class = ref($self) || $self;
  563   my $context = (Value::isContext($_[0]) ? shift : $self->context);
  564   bless {$self->hash, data => [@_], context => $context}, $class;
  565 }
  566 
  567 #
  568 #  Easy method for setting parameters of an object
  569 #  (returns a copy with the new values set, but the copy
  570 #  is not a deep copy.)
  571 #
  572 sub with {
  573   my $self = shift;
  574   bless {%{$self},@_}, ref($self);
  575 }
  576 
  577 #
  578 #  Return a copy with the specified fields removed
  579 #
  580 sub without {
  581   my $self = shift;
  582   $self = bless {%{$self}}, ref($self);
  583   foreach my $id (@_) {delete $self->{$id} if defined $self->{$id}}
  584   return $self;
  585 }
  586 
  587 ######################################################################
  588 
  589 #
  590 #  Return the hash data as an array of key=>value pairs
  591 #
  592 sub hash {
  593   my $self = shift;
  594   return %$self if isHash($self);
  595   return ();
  596 }
  597 
  598 #
  599 #  Copy attributes that are not already in the current object
  600 #  from the given objects.  (Used by binary operators to make sure
  601 #  the result inherits the values from the two terms.)
  602 #
  603 sub inherit {
  604   my $self = shift;
  605   my %copy = (map {%$_} @_,$self);  # copy values from given objects
  606   foreach my $id ($self->noinherit) {delete $copy{$id}}
  607   $self = bless {%copy}, ref($self);
  608   return $self;
  609 }
  610 
  611 #
  612 #  The list of fields NOT to inherit.
  613 #  Use the default list plus any specified explicitly in the object itself.
  614 #  Subclasses can override and return additional fields, if necessary.
  615 #
  616 sub noinherit {
  617   my $self = shift;
  618   ("correct_ans","original_formula","equation",@{$self->{noinherit}||[]});
  619 }
  620 
  621 ######################################################################
  622 
  623 #
  624 #  Return a type structure for the item
  625 #    (includes name, length of vectors, and so on)
  626 #
  627 sub Type {
  628   my $name = shift; my $length = shift; my $entryType = shift;
  629   $length = 1 unless defined $length;
  630   return {name => $name, length => $length, entryType => $entryType,
  631           list => (defined $entryType), @_};
  632 }
  633 
  634 #
  635 #  Some predefined types
  636 #
  637 %Type = (
  638   number   => Value::Type('Number',1),
  639   complex  => Value::Type('Number',2),
  640   string   => Value::Type('String',1),
  641   infinity => Value::Type('Infinity',1),
  642   interval => Value::Type('Interval',2),
  643   unknown  => Value::Type('unknown',0,undef,list => 1)
  644 );
  645 
  646 #
  647 #  Return various information about the object
  648 #
  649 sub value {return @{(shift)->{data}}}                  # the value of the object (as an array)
  650 sub data {return (shift)->{data}}                      # the reference to the value
  651 sub length {return scalar(@{(shift)->{data}})}         # the number of coordinates
  652 sub type {return (shift)->typeRef->{name}}             # the object type
  653 sub entryType {return (shift)->typeRef->{entryType}}   # the coordinate type
  654 #
  655 #  The the full type-hash for the item
  656 #
  657 sub typeRef {
  658   my $self = shift;
  659   return Value::Type($self->class, $self->length, $Value::Type{number});
  660 }
  661 #
  662 #  The Value.pm object class
  663 #
  664 sub class {
  665   my $self = shift;
  666   return $self->class(@_) if Value->subclassed($self,"class");
  667   my $class = ref($self) || $self; $class =~ s/.*:://;
  668   return $class;
  669 }
  670 
  671 #
  672 #  Get an element from a point, vector, matrix, or list
  673 #
  674 sub extract {
  675   my $M = shift; my $i; my @indices = @_;
  676   return unless Value::isValue($M);
  677   @indices = $_[0]->value if scalar(@_) == 1 && Value::isValue($_[0]);
  678   while (scalar(@indices) > 0) {
  679     return if Value::isNumber($M);
  680     $i = shift @indices; $i = $i->value if Value::isValue($i);
  681     Value::Error("Can't extract element number '%s' (index must be an integer)",$i)
  682       unless $i =~ m/^-?\d+$/;
  683     return if $i == 0; $i-- if $i > 0;
  684     $M = $M->data->[$i];
  685   }
  686   return $M;
  687 }
  688 
  689 ######################################################################
  690 
  691 use overload
  692        '+'   => '_add',
  693        '-'   => '_sub',
  694        '*'   => '_mult',
  695        '/'   => '_div',
  696        '**'  => '_power',
  697        '.'   => '_dot',
  698        'x'   => '_cross',
  699        '%'   => '_modulo',
  700        '<=>' => '_compare',
  701        'cmp' => '_compare_string',
  702        '~'   => '_twiddle',
  703        'neg' => '_neg',
  704        'abs' => '_abs',
  705        'sqrt'=> '_sqrt',
  706        'exp' => '_exp',
  707        'log' => '_log',
  708        'sin' => '_sin',
  709        'cos' => '_cos',
  710      'atan2' => '_atan2',
  711   'nomethod' => 'nomethod',
  712         '""' => 'stringify';
  713 
  714 #
  715 #  Promote an operand to the same precedence as the current object
  716 #
  717 sub promotePrecedence {
  718   my $self = shift; my $other = shift; my $context = $self->context;
  719   return 0 unless Value::isValue($other);
  720   my $sprec = $self->precedence; my $oprec = $other->precedence;
  721   return (defined($sprec) && defined($oprec) && $sprec < $oprec);
  722 }
  723 
  724 sub precedence {my $self = shift; return $self->context->{precedence}{$self->class}}
  725 
  726 sub promote {
  727   my $self = shift; my $class = ref($self) || $self;
  728   my $context = (Value::isContext($_[0]) ? shift : $self->context);
  729   my $x = (scalar(@_) ? shift : $self);
  730   return $x->inContext($context) if ref($x) eq $class && scalar(@_) == 0;
  731   return $self->new($context,$x,@_);
  732 }
  733 
  734 #
  735 #  Return the operators in the correct order
  736 #
  737 sub checkOpOrder {
  738   my ($l,$r,$flag) = @_;
  739   if ($flag) {return ($l,$r,$l,$r)} else {return ($l,$l,$r,$r)}
  740 }
  741 
  742 #
  743 #  Return the operators in the correct order, and promote the
  744 #  other value, if needed.
  745 #
  746 sub checkOpOrderWithPromote {
  747   my ($l,$r,$flag) = @_; $r = $l->promote($r);
  748   if ($flag) {return ($l,$r,$l,$r)} else {return ($l,$l,$r,$r)}
  749 }
  750 
  751 #
  752 #  Handle a binary operator, promoting the object types
  753 #  as needed, and then calling the main method
  754 #
  755 sub binOp {
  756   my ($l,$r,$flag,$call) = @_;
  757   if ($l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
  758                             else {return $l->$call($r,$flag)}
  759 }
  760 
  761 #
  762 #  stubs for binary operations (with promotion)
  763 #
  764 sub _add            {binOp(@_,'add')}
  765 sub _sub            {binOp(@_,'sub')}
  766 sub _mult           {binOp(@_,'mult')}
  767 sub _div            {binOp(@_,'div')}
  768 sub _power          {binOp(@_,'power')}
  769 sub _cross          {binOp(@_,'cross')}
  770 sub _modulo         {binOp(@_,'modulo')}
  771 
  772 sub _compare        {transferTolerances(@_); binOp(@_,'compare')}
  773 sub _compare_string {binOp(@_,'compare_string')}
  774 
  775 sub _atan2          {binOp(@_,'atan2')}
  776 
  777 sub _twiddle        {(shift)->twiddle}
  778 sub _neg            {(shift)->neg}
  779 sub _abs            {(shift)->abs}
  780 sub _sqrt           {(shift)->sqrt}
  781 sub _exp            {(shift)->exp}
  782 sub _log            {(shift)->log}
  783 sub _sin            {(shift)->sin}
  784 sub _cos            {(shift)->cos}
  785 
  786 #
  787 #  Default stub to call when no function is defined for an operation
  788 #
  789 sub nomethod {
  790   my ($l,$r,$flag,$op) = @_;
  791   my $call = $l->context->{method}{$op};
  792   if (defined($call) && $l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
  793   my $error = "Can't use '%s' with %s-valued operands";
  794   $error .= " (use '**' for exponentiation)" if $op eq '^';
  795   Value::Error($error,$op,$l->class);
  796 }
  797 
  798 sub nodef {
  799   my $self = shift; my $func = shift;
  800   Value::Error("Can't use '%s' with %s-valued operands",$func,$self->class);
  801 }
  802 
  803 #
  804 #  Stubs for the sub-classes
  805 #
  806 sub add    {nomethod(@_,'+')}
  807 sub sub    {nomethod(@_,'-')}
  808 sub mult   {nomethod(@_,'*')}
  809 sub div    {nomethod(@_,'/')}
  810 sub power  {nomethod(@_,'**')}
  811 sub cross  {nomethod(@_,'x')}
  812 sub modulo {nomethod(@_,'%')}
  813 
  814 sub twiddle {nodef(shift,"~")}
  815 sub neg     {nodef(shift,"-")}
  816 sub abs     {nodef(shift,"abs")}
  817 sub sqrt    {nodef(shift,"sqrt")}
  818 sub exp     {nodef(shift,"exp")}
  819 sub log     {nodef(shift,"log")}
  820 sub sin     {nodef(shift,"sin")}
  821 sub cos     {nodef(shift,"cos")}
  822 
  823 #
  824 #  If the right operand is higher precedence, we switch the order.
  825 #
  826 #  If the right operand is also a Value object, we do the object's
  827 #  dot method to combine the two objects of the same class.
  828 #
  829 #  Otherwise, since . is used for string concatenation, we want to retain
  830 #  that.  Since the resulting string is often used in Formula and will be
  831 #  parsed again, we put parentheses around the values to guarantee that
  832 #  the values will be treated as one mathematical unit.  For example, if
  833 #  $f = Formula("1+x") and $g = Formula("y") then Formula("$f/$g") will be
  834 #  (1+x)/y not 1+(x/y), as it would be without the implicit parentheses.
  835 #
  836 sub _dot {
  837   my ($l,$r,$flag) = @_;
  838   return $r->_dot($l,!$flag) if ($l->promotePrecedence($r));
  839   return $l->dot($r,$flag) if (Value::isValue($r));
  840   if (Value->context->flag('StringifyAsTeX')) {$l = $l->TeX} else {$l = $l->pdot}
  841   return ($flag)? ($r.$l): ($l.$r);
  842 }
  843 #
  844 #  Some classes override this
  845 #
  846 sub dot {
  847   my ($l,$r,$flag) = @_;
  848   my $tex = Value->context->flag('StringifyAsTeX');
  849   if ($tex) {$l = $l->TeX} else {$l = $l->pdot}
  850   if (Value::isBlessed($r)) {if ($tex) {$r = $r->TeX} else {$r = $r->pdot}}
  851   return ($flag)? ($r.$l): ($l.$r);
  852 }
  853 
  854 #
  855 #  Some classes override this to add parens
  856 #
  857 sub pdot {shift->stringify}
  858 
  859 
  860 #
  861 #  Compare the values of the objects
  862 #    (list classes should replace this)
  863 #
  864 sub compare {
  865   my ($l,$r) = Value::checkOpOrder(@_);
  866   return $l->value <=> $r->value;
  867 }
  868 
  869 #
  870 #  Compare the values as strings
  871 #
  872 sub compare_string {
  873   my ($l,$r,$flag) = @_;
  874   $l = $l->string; $r = $r->string if Value::isValue($r);
  875   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  876   return $l cmp $r;
  877 }
  878 
  879 #
  880 #  Copy flags from the parent object to its children (recursively).
  881 #
  882 sub transferFlags {
  883   my $self = shift;
  884   foreach my $flag (@_) {
  885     next unless defined $self->{$flag};
  886     foreach my $x (@{$self->{data}}) {
  887       if ($x->{$flag} ne $self->{$flag}) {
  888   $x->{$flag} = $self->{$flag};
  889   $x->transferFlags($flag);
  890       }
  891     }
  892   }
  893 }
  894 
  895 sub transferTolerances {
  896   my ($self,$other) = @_;
  897   $self->transferFlags("tolerance","tolType","zeroLevel","zeroLevelTol");
  898   $other->transferFlags("tolerance","tolType","zeroLevel","zeroLevelTol") if Value::isValue($other);
  899 }
  900 
  901 =head3 output methods for MathObjects
  902 
  903  #
  904  #  Generate the various output formats
  905  #  (can be replaced by sub-classes)
  906  #
  907 
  908 =cut
  909 
  910 =head4 stringify
  911 
  912   Usage:   TEXT($mathObj); or TEXT( $mathObj->stringify() ) ;
  913 
  914     Produces text string or TeX output depending on context
  915       Context()->texStrings;
  916       Context()->normalStrings;
  917 
  918     called automatically when object is called in a string context.
  919 
  920 =cut
  921 
  922 sub stringify {
  923   my $self = shift;
  924   return $self->TeX if Value->context->flag('StringifyAsTeX');
  925   return $self->string;
  926 }
  927 
  928 =head4 ->string
  929 
  930   Usage: $mathObj->string()
  931 
  932   ---produce a string representation of the object
  933            (as opposed to stringify, which can produce TeX or string versions)
  934 
  935 =cut
  936 
  937 sub string {
  938   my $self = shift; my $equation = shift;
  939   my $def = ($equation->{context} || $self->context)->lists->get($self->class);
  940   return $self->value unless $def;
  941   my $open = shift; my $close = shift;
  942   $open  = $self->{open}  unless defined($open);
  943   $open  = $def->{open}   unless defined($open);
  944   $close = $self->{close} unless defined($close);
  945   $close = $def->{close}  unless defined($close);
  946   my @coords = ();
  947   foreach my $x (@{$self->data}) {
  948     if (Value::isValue($x)) {
  949       $x->{format} = $self->{format} if defined $self->{format};
  950       push(@coords,$x->string($equation));
  951     } else {
  952       push(@coords,$x);
  953     }
  954   }
  955   return $open.join($def->{separator},@coords).$close;
  956 }
  957 
  958 =head4 ->TeX
  959 
  960   Usage: $mathObj->TeX()
  961 
  962   ---produce TeX prepresentation of the object
  963 
  964 =cut
  965 
  966 sub TeX {
  967   my $self = shift; my $equation = shift;
  968   my $context = $equation->{context} || $self->context;
  969   my $def = $context->lists->get($self->class);
  970   return $self->string(@_) unless $def;
  971   my $open = shift; my $close = shift;
  972   $open  = $self->{open}  unless defined($open);
  973   $open  = $def->{open}   unless defined($open);
  974   $close = $self->{close} unless defined($close);
  975   $close = $def->{close}  unless defined($close);
  976   $open =~ s/([{}])/\\$1/g; $close =~ s/([{}])/\\$1/g;
  977   $open = '\left'.$open if $open; $close = '\right'.$close if $close;
  978   my @coords = (); my $str = $context->{strings};
  979   foreach my $x (@{$self->data}) {
  980     if (Value::isValue($x)) {
  981       $x->{format} = $self->{format} if defined $self->{format};
  982       push(@coords,$x->TeX($equation));
  983     } elsif (defined($str->{$x}) && $str->{$x}{TeX}) {push(@coords,$str->{$x}{TeX})}
  984     else {push(@coords,$x)}
  985   }
  986   return $open.join(',',@coords).$close;
  987 }
  988 
  989 #
  990 #  For perl, call the appropriate constructor around the object's data
  991 #
  992 sub perl {
  993   my $self = shift; my $parens = shift; my $matrix = shift;
  994   my $mtype = $self->classMatch('Matrix'); $mtype = -1 if $mtype & !$matrix;
  995   my $perl; my @p = ();
  996   foreach my $x (@{$self->data}) {
  997     if (Value::isValue($x)) {push(@p,$x->perl(0,$mtype))} else {push(@p,$x)}
  998   }
  999   @p = ("'".$self->{open}."'",@p,"'".$self->{close}."'") if $self->classMatch('Interval');
 1000   if ($matrix) {
 1001     $perl = join(',',@p);
 1002     $perl = '['.$perl.']' if $mtype > 0;
 1003   } else {
 1004     $perl = ref($self).'->new('.join(',',@p).')';
 1005     $perl = "($perl)->with(open=>'$self->{open}',close=>'$self->{close}')"
 1006       if $self->classMatch('List') && $self->{open}.$self->{close} ne '()';
 1007     $perl = '('.$perl.')' if $parens == 1;
 1008   }
 1009   return $perl;
 1010 }
 1011 
 1012 #
 1013 #  Stubs for when called by Parser
 1014 #
 1015 sub eval {shift}
 1016 sub reduce {shift}
 1017 
 1018 sub ijk {
 1019   Value::Error("Can't use method 'ijk' with objects of type '%s'",(shift)->class);
 1020 }
 1021 
 1022 
 1023 =head3 Error
 1024 
 1025   Usage: Value->Error("We're sorry...");
 1026            or  $mathObject->Error("We're still sorry...");
 1027 
 1028  #
 1029  #  Report an error and die.  This can be used within custom answer checkers
 1030  #  to report errors during the check, or when sub-classing a MathObject to
 1031  #  report error conditions.
 1032  #
 1033 
 1034 =cut
 1035 
 1036 sub Error {
 1037   my $self = (UNIVERSAL::can($_[0],"getFlag") ? shift : "Value");
 1038   my $message = shift; my $context = $self->context;
 1039   $message = [$message,@_] if scalar(@_) > 0;
 1040   $context->setError($message,'');
 1041   $message = $context->{error}{message};
 1042   die $message . traceback() if $self->getFlag('showTraceback');
 1043   die $message . getCaller();
 1044 }
 1045 
 1046 #
 1047 #  Try to locate the line and file where the error occurred
 1048 #
 1049 sub getCaller {
 1050   my $frame = 2;
 1051   while (my ($pkg,$file,$line,$subname) = caller($frame++)) {
 1052     return " at line $line of $file\n"
 1053       unless $pkg =~ /^(Value|Parser)/ ||
 1054              $subname =~ m/^(Value|Parser).*(new|call)$/;
 1055   }
 1056   return "";
 1057 }
 1058 
 1059 #
 1060 #  For debugging
 1061 #
 1062 sub traceback {
 1063   my $frame = shift; $frame = 2 unless defined($frame);
 1064   my $trace = '';
 1065   while (my ($pkg,$file,$line,$subname) = caller($frame++))
 1066     {$trace .= " in $subname at line $line of $file\n"}
 1067   return $trace;
 1068 }
 1069 
 1070 ###########################################################################
 1071 #
 1072 #  Load the sub-classes.
 1073 #
 1074 
 1075 END {
 1076   use Value::Real;
 1077   use Value::Complex;
 1078   use Value::Infinity;
 1079   use Value::Point;
 1080   use Value::Vector;
 1081   use Value::Matrix;
 1082   use Value::List;
 1083   use Value::Interval;
 1084   use Value::Set;
 1085   use Value::Union;
 1086   use Value::String;
 1087   use Value::Formula;
 1088 
 1089   use Value::WeBWorK;  # stuff specific to WeBWorK
 1090 }
 1091 
 1092 ###########################################################################
 1093 
 1094 our $installed = 1;
 1095 
 1096 ###########################################################################
 1097 
 1098 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9