[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 5384 - (download) (as text) (annotate)
Sun Aug 19 19:18:18 2007 UTC (12 years, 3 months ago) by dpvc
File size: 29353 byte(s)
Allow objects to explicitly DENY being a given type, even if isa()
says they are.

    1 package Value;
    2 my $pkg = 'Value';
    3 use vars qw($context $defaultContext %Type);
    4 use Scalar::Util;
    5 use strict;
    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 a context 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} unless defined $open;
  329   my $close = $self->{close}; $close = $def->{close} 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 {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 
  575 #
  576 #  Return a type structure for the item
  577 #    (includes name, length of vectors, and so on)
  578 #
  579 sub Type {
  580   my $name = shift; my $length = shift; my $entryType = shift;
  581   $length = 1 unless defined $length;
  582   return {name => $name, length => $length, entryType => $entryType,
  583           list => (defined $entryType), @_};
  584 }
  585 
  586 #
  587 #  Some predefined types
  588 #
  589 %Type = (
  590   number   => Value::Type('Number',1),
  591   complex  => Value::Type('Number',2),
  592   string   => Value::Type('String',1),
  593   infinity => Value::Type('Infinity',1),
  594   unknown  => Value::Type('unknown',0,undef,list => 1)
  595 );
  596 
  597 #
  598 #  Return various information about the object
  599 #
  600 sub value {return @{(shift)->{data}}}                  # the value of the object (as an array)
  601 sub data {return (shift)->{data}}                      # the reference to the value
  602 sub length {return scalar(@{(shift)->{data}})}         # the number of coordinates
  603 sub type {return (shift)->typeRef->{name}}             # the object type
  604 sub entryType {return (shift)->typeRef->{entryType}}   # the coordinate type
  605 #
  606 #  The the full type-hash for the item
  607 #
  608 sub typeRef {
  609   my $self = shift;
  610   return Value::Type($self->class, $self->length, $Value::Type{number});
  611 }
  612 #
  613 #  The Value.pm object class
  614 #
  615 sub class {
  616   my $self = shift;
  617   return $self->class(@_) if Value->subclassed($self,"class");
  618   my $class = ref($self) || $self; $class =~ s/.*:://;
  619   return $class;
  620 }
  621 
  622 #
  623 #  Get an element from a point, vector, matrix, or list
  624 #
  625 sub extract {
  626   my $M = shift; my $i; my @indices = @_;
  627   return unless Value::isValue($M);
  628   @indices = $_[0]->value if scalar(@_) == 1 && Value::isValue($_[0]);
  629   while (scalar(@indices) > 0) {
  630     return if Value::isNumber($M);
  631     $i = shift @indices; $i = $i->value if Value::isValue($i);
  632     Value::Error("Can't extract element number '%s' (index must be an integer)",$i)
  633       unless $i =~ m/^-?\d+$/;
  634     return if $i == 0; $i-- if $i > 0;
  635     $M = $M->data->[$i];
  636   }
  637   return $M;
  638 }
  639 
  640 ######################################################################
  641 
  642 use overload
  643        '+'   => '_add',
  644        '-'   => '_sub',
  645        '*'   => '_mult',
  646        '/'   => '_div',
  647        '**'  => '_power',
  648        '.'   => '_dot',
  649        'x'   => '_cross',
  650        '%'   => '_modulo',
  651        '<=>' => '_compare',
  652        'cmp' => '_compare_string',
  653        '~'   => '_twiddle',
  654        'neg' => '_neg',
  655        'abs' => '_abs',
  656        'sqrt'=> '_sqrt',
  657        'exp' => '_exp',
  658        'log' => '_log',
  659        'sin' => '_sin',
  660        'cos' => '_cos',
  661      'atan2' => '_atan2',
  662   'nomethod' => 'nomethod',
  663         '""' => 'stringify';
  664 
  665 #
  666 #  Promote an operand to the same precedence as the current object
  667 #
  668 sub promotePrecedence {
  669   my $self = shift; my $other = shift; my $context = $self->context;
  670   return 0 unless Value::isValue($other);
  671   my $sprec = $context->{precedence}{class($self)};
  672   my $oprec = $context->{precedence}{class($other)};
  673   return (defined($sprec) && defined($oprec) && $sprec < $oprec);
  674 }
  675 
  676 sub promote {
  677   my $self = shift; my $class = ref($self) || $self;
  678   my $context = (Value::isContext($_[0]) ? shift : $self->context);
  679   my $x = (scalar(@_) ? shift : $self);
  680   return $x->inContext($context) if ref($x) eq $class && scalar(@_) == 0;
  681   return $self->new($context,$x,@_);
  682 }
  683 
  684 #
  685 #  Return the operators in the correct order
  686 #
  687 sub checkOpOrder {
  688   my ($l,$r,$flag) = @_;
  689   if ($flag) {return ($l,$r,$l)} else {return ($l,$l,$r)}
  690 }
  691 
  692 #
  693 #  Return the operators in the correct order, and promote the
  694 #  other value, if needed.
  695 #
  696 sub checkOpOrderWithPromote {
  697   my ($l,$r,$flag) = @_; $r = $l->promote($r);
  698   if ($flag) {return ($l,$r,$l)} else {return ($l,$l,$r)}
  699 }
  700 
  701 #
  702 #  Handle a binary operator, promoting the object types
  703 #  as needed, and then calling the main method
  704 #
  705 sub binOp {
  706   my ($l,$r,$flag,$call) = @_;
  707   if ($l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
  708                             else {return $l->$call($r,$flag)}
  709 }
  710 
  711 #
  712 #  stubs for binary operations (with promotion)
  713 #
  714 sub _add            {binOp(@_,'add')}
  715 sub _sub            {binOp(@_,'sub')}
  716 sub _mult           {binOp(@_,'mult')}
  717 sub _div            {binOp(@_,'div')}
  718 sub _power          {binOp(@_,'power')}
  719 sub _cross          {binOp(@_,'cross')}
  720 sub _modulo         {binOp(@_,'modulo')}
  721 
  722 sub _compare        {transferTolerances(@_); binOp(@_,'compare')}
  723 sub _compare_string {binOp(@_,'compare_string')}
  724 
  725 sub _atan2          {binOp(@_,'atan2')}
  726 
  727 sub _twiddle        {(shift)->twiddle}
  728 sub _neg            {(shift)->neg}
  729 sub _abs            {(shift)->abs}
  730 sub _sqrt           {(shift)->sqrt}
  731 sub _exp            {(shift)->exp}
  732 sub _log            {(shift)->log}
  733 sub _sin            {(shift)->sin}
  734 sub _cos            {(shift)->cos}
  735 
  736 #
  737 #  Default stub to call when no function is defined for an operation
  738 #
  739 sub nomethod {
  740   my ($l,$r,$flag,$op) = @_;
  741   my $call = $l->context->{method}{$op};
  742   if (defined($call) && $l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
  743   my $error = "Can't use '%s' with %s-valued operands";
  744   $error .= " (use '**' for exponentiation)" if $op eq '^';
  745   Value::Error($error,$op,$l->class);
  746 }
  747 
  748 sub nodef {
  749   my $self = shift; my $func = shift;
  750   Value::Error("Can't use '%s' with %s-valued operands",$func,$self->class);
  751 }
  752 
  753 #
  754 #  Stubs for the sub-classes
  755 #
  756 sub add    {nomethod(@_,'+')}
  757 sub sub    {nomethod(@_,'-')}
  758 sub mult   {nomethod(@_,'*')}
  759 sub div    {nomethod(@_,'/')}
  760 sub power  {nomethod(@_,'**')}
  761 sub cross  {nomethod(@_,'x')}
  762 sub modulo {nomethod(@_,'%')}
  763 
  764 sub twiddle {nodef(shift,"~")}
  765 sub neg     {nodef(shift,"-")}
  766 sub abs     {nodef(shift,"abs")}
  767 sub sqrt    {nodef(shift,"sqrt")}
  768 sub exp     {nodef(shift,"exp")}
  769 sub log     {nodef(shift,"log")}
  770 sub sin     {nodef(shift,"sin")}
  771 sub cos     {nodef(shift,"cos")}
  772 
  773 #
  774 #  If the right operand is higher precedence, we switch the order.
  775 #
  776 #  If the right operand is also a Value object, we do the object's
  777 #  dot method to combine the two objects of the same class.
  778 #
  779 #  Otherwise, since . is used for string concatenation, we want to retain
  780 #  that.  Since the resulting string is often used in Formula and will be
  781 #  parsed again, we put parentheses around the values to guarantee that
  782 #  the values will be treated as one mathematical unit.  For example, if
  783 #  $f = Formula("1+x") and $g = Formula("y") then Formula("$f/$g") will be
  784 #  (1+x)/y not 1+(x/y), as it would be without the implicit parentheses.
  785 #
  786 sub _dot {
  787   my ($l,$r,$flag) = @_;
  788   return $r->_dot($l,!$flag) if ($l->promotePrecedence($r));
  789   return $l->dot($r,$flag) if (Value::isValue($r));
  790   if (Value->context->flag('StringifyAsTeX')) {$l = $l->TeX} else {$l = $l->pdot}
  791   return ($flag)? ($r.$l): ($l.$r);
  792 }
  793 #
  794 #  Some classes override this
  795 #
  796 sub dot {
  797   my ($l,$r,$flag) = @_;
  798   my $tex = Value->context->flag('StringifyAsTeX');
  799   if ($tex) {$l = $l->TeX} else {$l = $l->pdot}
  800   if (Value::isBlessed($r)) {if ($tex) {$r = $r->TeX} else {$r = $r->pdot}}
  801   return ($flag)? ($r.$l): ($l.$r);
  802 }
  803 
  804 #
  805 #  Some classes override this to add parens
  806 #
  807 sub pdot {shift->stringify}
  808 
  809 
  810 #
  811 #  Compare the values of the objects
  812 #    (list classes should replace this)
  813 #
  814 sub compare {
  815   my ($l,$r) = Value::checkOpOrder(@_);
  816   return $l->value <=> $r->value;
  817 }
  818 
  819 #
  820 #  Compare the values as strings
  821 #
  822 sub compare_string {
  823   my ($l,$r,$flag) = @_;
  824   $l = $l->stringify; $r = $r->stringify if Value::isValue($r);
  825   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  826   return $l cmp $r;
  827 }
  828 
  829 #
  830 #  Copy flags from the parent object to its children (recursively).
  831 #
  832 sub transferFlags {
  833   my $self = shift;
  834   foreach my $flag (@_) {
  835     next unless defined $self->{$flag};
  836     foreach my $x (@{$self->{data}}) {
  837       if ($x->{$flag} ne $self->{$flag}) {
  838   $x->{$flag} = $self->{$flag};
  839   $x->transferFlags($flag);
  840       }
  841     }
  842   }
  843 }
  844 
  845 sub transferTolerances {
  846   my ($self,$other) = @_;
  847   $self->transferFlags("tolerance","tolType","zeroLevel","zeroLevelTol");
  848   $other->transferFlags("tolerance","tolType","zeroLevel","zeroLevelTol") if Value::isValue($other);
  849 }
  850 
  851 =head3 output methods for MathObjects
  852 
  853  #
  854  #  Generate the various output formats
  855  #  (can be replaced by sub-classes)
  856  #
  857 
  858 =cut
  859 
  860 =head4 stringify
  861 
  862   Usage:   TEXT($mathObj); or TEXT( $mathObj->stringify() ) ;
  863 
  864     Produces text string or TeX output depending on context
  865       Context()->texStrings;
  866       Context()->normalStrings;
  867 
  868     called automatically when object is called in a string context.
  869 
  870 =cut
  871 
  872 sub stringify {
  873   my $self = shift;
  874   return $self->TeX if Value->context->flag('StringifyAsTeX');
  875   return $self->string;
  876 }
  877 
  878 =head4 ->string
  879 
  880   Usage: $mathObj->string()
  881 
  882   ---produce a string representation of the object
  883            (as opposed to stringify, which can produce TeX or string versions)
  884 
  885 =cut
  886 
  887 sub string {
  888   my $self = shift; my $equation = shift;
  889   my $def = ($equation->{context} || $self->context)->lists->get($self->class);
  890   return $self->value unless $def;
  891   my $open = shift; my $close = shift;
  892   $open  = $self->{open}  unless defined($open);
  893   $open  = $def->{open}   unless defined($open);
  894   $close = $self->{close} unless defined($close);
  895   $close = $def->{close}  unless defined($close);
  896   my @coords = ();
  897   foreach my $x (@{$self->data}) {
  898     if (Value::isValue($x)) {
  899       $x->{format} = $self->{format} if defined $self->{format};
  900       push(@coords,$x->string($equation));
  901     } else {
  902       push(@coords,$x);
  903     }
  904   }
  905   return $open.join($def->{separator},@coords).$close;
  906 }
  907 
  908 =head4 ->TeX
  909 
  910   Usage: $mathObj->TeX()
  911 
  912   ---produce TeX prepresentation of the object
  913 
  914 =cut
  915 
  916 sub TeX {
  917   my $self = shift; my $equation = shift;
  918   my $context = $equation->{context} || $self->context;
  919   my $def = $context->lists->get($self->class);
  920   return $self->string(@_) unless $def;
  921   my $open = shift; my $close = shift;
  922   $open  = $self->{open}  unless defined($open);
  923   $open  = $def->{open}   unless defined($open);
  924   $close = $self->{close} unless defined($close);
  925   $close = $def->{close}  unless defined($close);
  926   $open =~ s/([{}])/\\$1/g; $close =~ s/([{}])/\\$1/g;
  927   $open = '\left'.$open if $open; $close = '\right'.$close if $close;
  928   my @coords = (); my $str = $context->{strings};
  929   foreach my $x (@{$self->data}) {
  930     if (Value::isValue($x)) {
  931       $x->{format} = $self->{format} if defined $self->{format};
  932       push(@coords,$x->TeX($equation));
  933     } elsif (defined($str->{$x}) && $str->{$x}{TeX}) {push(@coords,$str->{$x}{TeX})}
  934     else {push(@coords,$x)}
  935   }
  936   return $open.join(',',@coords).$close;
  937 }
  938 
  939 #
  940 #  For perl, call the appropriate constructor around the object's data
  941 #
  942 sub perl {
  943   my $self = shift; my $parens = shift; my $matrix = shift;
  944   my $mtype = $self->classMatch('Matrix'); $mtype = -1 if $mtype & !$matrix;
  945   my $perl; my @p = ();
  946   foreach my $x (@{$self->data}) {
  947     if (Value::isValue($x)) {push(@p,$x->perl(0,$mtype))} else {push(@p,$x)}
  948   }
  949   @p = ("'".$self->{open}."'",@p,"'".$self->{close}."'") if $self->classMatch('Interval');
  950   if ($matrix) {
  951     $perl = join(',',@p);
  952     $perl = '['.$perl.']' if $mtype > 0;
  953   } else {
  954     $perl = ref($self).'->new('.join(',',@p).')';
  955     $perl = "($perl)->with(open=>'$self->{open}',close=>'$self->{close}')"
  956       if $self->classMatch('List') && $self->{open}.$self->{close} ne '()';
  957     $perl = '('.$perl.')' if $parens == 1;
  958   }
  959   return $perl;
  960 }
  961 
  962 #
  963 #  Stubs for when called by Parser
  964 #
  965 sub eval {shift}
  966 sub reduce {shift}
  967 
  968 sub ijk {
  969   Value::Error("Can't use method 'ijk' with objects of type '%s'",(shift)->class);
  970 }
  971 
  972 
  973 =head3 Error
  974 
  975   Usage: Value->Error("We're sorry...");
  976            or  $mathObject->Error("We're still sorry...");
  977 
  978  #
  979  #  Report an error and die.  This can be used within custom answer checkers
  980  #  to report errors during the check, or when sub-classing a MathObject to
  981  #  report error conditions.
  982  #
  983 
  984 =cut
  985 
  986 sub Error {
  987   my $self = (UNIVERSAL::can($_[0],"getFlag") ? shift : "Value");
  988   my $message = shift; my $context = $self->context;
  989   $message = [$message,@_] if scalar(@_) > 0;
  990   $context->setError($message,'');
  991   $message = $context->{error}{message};
  992   die $message . traceback() if $self->getFlag('showTraceback');
  993   die $message . getCaller();
  994 }
  995 
  996 #
  997 #  Try to locate the line and file where the error occurred
  998 #
  999 sub getCaller {
 1000   my $frame = 2;
 1001   while (my ($pkg,$file,$line,$subname) = caller($frame++)) {
 1002     return " at line $line of $file\n"
 1003       unless $pkg =~ /^(Value|Parser)/ ||
 1004              $subname =~ m/^(Value|Parser).*(new|call)$/;
 1005   }
 1006   return "";
 1007 }
 1008 
 1009 #
 1010 #  For debugging
 1011 #
 1012 sub traceback {
 1013   my $frame = shift; $frame = 2 unless defined($frame);
 1014   my $trace = '';
 1015   while (my ($pkg,$file,$line,$subname) = caller($frame++))
 1016     {$trace .= " in $subname at line $line of $file\n"}
 1017   return $trace;
 1018 }
 1019 
 1020 ###########################################################################
 1021 #
 1022 #  Load the sub-classes.
 1023 #
 1024 
 1025 END {
 1026   use Value::Real;
 1027   use Value::Complex;
 1028   use Value::Infinity;
 1029   use Value::Point;
 1030   use Value::Vector;
 1031   use Value::Matrix;
 1032   use Value::List;
 1033   use Value::Interval;
 1034   use Value::Set;
 1035   use Value::Union;
 1036   use Value::String;
 1037   use Value::Formula;
 1038 
 1039   use Value::WeBWorK;  # stuff specific to WeBWorK
 1040 }
 1041 
 1042 ###########################################################################
 1043 
 1044 our $installed = 1;
 1045 
 1046 ###########################################################################
 1047 
 1048 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9