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

View of /trunk/pg/lib/Parser/BOP.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2696 - (download) (as text) (annotate)
Sat Aug 28 12:34:56 2004 UTC (15 years, 3 months ago) by dpvc
File size: 10043 byte(s)
Improved TeX and string output in a number of situations.  Improved
use of parentheses to avoid things like x+-3.  Fixed wrong parentheses
in powers.  Display (sin(x))^2 as sin^2(x) in TeX output.

    1 #########################################################################
    2 #
    3 #  Implements the base Binary Operator class
    4 #
    5 
    6 package Parser::BOP;
    7 use strict; use vars qw(@ISA);
    8 @ISA = qw(Parser::Item);
    9 
   10 $Parser::class->{BOP} = 'Parser::BOP';
   11 
   12 #
   13 #  Make a new instance of a BOP
   14 #
   15 #  Make left and right operands into lists if they are comma operators
   16 #    and this operator isn't itself a comma.
   17 #
   18 sub new {
   19   my $self = shift; my $class = ref($self) || $self;
   20   my $equation = shift; my $context = $equation->{context};
   21   my ($bop,$lop,$rop,$ref) = @_;
   22   my $def = $context->{operators}{$bop};
   23   if (!$def->{isComma}) {
   24     $lop = $context->{parser}{List}->new($equation,[$lop->makeList],
   25        $lop->{isConstant},$context->{parens}{start}) if ($lop->type eq 'Comma');
   26     $rop = $context->{parser}{List}->new($equation,[$rop->makeList],$rop->{isConstant},
   27        $context->{parens}{start}) if ($rop->type eq 'Comma');
   28   }
   29   my $BOP = bless {
   30     bop => $bop, lop => $lop, rop => $rop,
   31     def => $def, ref => $ref, equation => $equation,
   32   }, $def->{class};
   33   $BOP->_check;
   34   $BOP->{isConstant} = 1 if ($lop->{isConstant} && $rop->{isConstant});
   35   $BOP = $context->{parser}{Value}->new($equation,[$BOP->eval])
   36     if ($BOP->{isConstant} && !$def->{isComma});
   37   return $BOP;
   38 }
   39 
   40 #
   41 #  Stub for checking if the BOP can operate on the given operands.
   42 #  (Implemented in subclasses.)
   43 #
   44 sub _check {}
   45 
   46 ##################################################
   47 
   48 #
   49 #  Evaluate the left and right operands and peform the
   50 #  required operation on the results.
   51 #
   52 sub eval {
   53   my $self = shift;
   54   $self->_eval($self->{lop}->eval,$self->{rop}->eval);
   55 }
   56 #
   57 #  Stub for sub-classes.
   58 #
   59 sub _eval {return $_[1]}
   60 
   61 #
   62 #  Reduce the left and right operands.
   63 #  If they are constant (and it's not a comma), make a constant value of them.
   64 #  Otherwise, reduce the result.
   65 #
   66 sub reduce {
   67   my $self = shift; my $bop = $self->{def};
   68   $self->{lop} = $self->{lop}->reduce;
   69   $self->{rop} = $self->{rop}->reduce;
   70   my $equation = $self->{equation};
   71   return $equation->{context}{parser}{Value}->new($equation,[$self->eval])
   72     if (!$bop->{isComma} && $self->{lop}{isConstant} && $self->{rop}{isConstant});
   73   $self->_reduce;
   74 }
   75 #
   76 #  Stub for sub-classes.
   77 #
   78 sub _reduce {shift}
   79 
   80 #
   81 #  Substitute in the left and right operands.
   82 #
   83 sub substitute {
   84   my $self = shift; my $bop = $self->{def};
   85   $self->{lop} = $self->{lop}->substitute;
   86   $self->{rop} = $self->{rop}->substitute;
   87   my $equation = $self->{equation};
   88   return $equation->{context}{parser}{Value}->new($equation,[$self->eval])
   89     if (!$bop->{isComma} && $self->{lop}{isConstant} && $self->{rop}{isConstant});
   90   return $self;
   91 }
   92 
   93 #
   94 #  Copy the left and right operands as well as the rest
   95 #    of the equations.
   96 #
   97 sub copy {
   98   my $self = shift; my $equation = shift;
   99   my $new = $self->SUPER::copy($equation);
  100   $new->{lop} = $self->{lop}->copy($equation);
  101   $new->{rop} = $self->{rop}->copy($equation);
  102   return $new;
  103 }
  104 
  105 ##################################################
  106 #
  107 #  Service routines for checking the types of operands.
  108 #
  109 
  110 
  111 #
  112 #  Error if one of the operands is a string.
  113 #
  114 sub checkStrings {
  115   my $self = shift;
  116   my $ltype = $self->{lop}->typeRef; my $rtype = $self->{rop}->typeRef;
  117   my $name = $self->{def}{string} || $self->{bop};
  118   if ($ltype->{name} eq 'String') {
  119     $self->Error("Operands of '$name' can't be ".
  120      ($self->{lop}{isInfinite}? 'infinities': 'words'));
  121     return 1;
  122   }
  123   if ($rtype->{name} eq 'String') {
  124     $self->Error("Operands of '$name' can't be ".
  125      ($self->{rop}{isInfinite}? 'infinities': 'words'));
  126     return 1;
  127   }
  128   return 0;
  129 }
  130 
  131 #
  132 #  Error if one of the operands is a list.
  133 #
  134 sub checkLists {
  135   my $self = shift;
  136   my $ltype = $self->{lop}->typeRef; my $rtype = $self->{rop}->typeRef;
  137   return 0 if ($ltype->{name} ne 'List' and $rtype->{name} ne 'List');
  138   my $name = $self->{def}{string} || $self->{bop};
  139   $self->Error("Operands of '$name' can't be lists");
  140   return 1;
  141 }
  142 
  143 #
  144 #  Determine if both operands are numbers, and promote to
  145 #    complex numbers if one is complex.
  146 #
  147 sub checkNumbers {
  148   my $self = shift;
  149   return 0 if !($self->{lop}->isNumber && $self->{rop}->isNumber);
  150   if ($self->{lop}->isComplex || $self->{rop}->isComplex) {
  151     $self->{type} = $Value::Type{complex};
  152   } else {
  153     $self->{type} = $Value::Type{number};
  154   }
  155   return 1;
  156 }
  157 
  158 #
  159 #  Check if two matrices can be multiplied.
  160 #
  161 sub checkMatrixSize {
  162   my $self = shift;
  163   my ($lm,$rm) = @_;
  164   my ($ltype,$rtype) = ($lm->{entryType},$rm->{entryType});
  165   if ($ltype->{entryType}{name} eq 'Number' &&
  166       $rtype->{entryType}{name} eq 'Number') {
  167     my ($lr,$lc) = ($lm->{length},$ltype->{length});
  168     my ($rr,$rc) = ($rm->{length},$rtype->{length});
  169     if ($lc == $rr) {
  170       my $rowType = Value::Type('Matrix',$rc,$Value::Type{number},formMatrix=>1);
  171       $self->{type} = Value::Type('Matrix',$lr,$rowType,formMatrix=>1);
  172     } else {$self->Error("Matrix of dimensions ${lr}x${lc} and ${rr}x${rc} can't be multiplied")}
  173   } else {$self->Error("Matrices are too deep to be multiplied")}
  174 }
  175 
  176 #
  177 #  Promote point operands to vectors or matrices.
  178 #
  179 sub promotePoints {
  180   my $self = shift; my $class = shift;
  181   my $ltype = $self->{lop}->typeRef;
  182   my $rtype = $self->{rop}->typeRef;
  183   if ($ltype->{name} eq 'Point' ||
  184       ($ltype->{name} eq 'Matrix' && !$ltype->{entryType}{entryType})) {
  185     $ltype = {%{$ltype}, name => 'Vector'};
  186     $ltype = Value::Type($class,1,Value::Type($class,1,$ltype->{entryType}))
  187       if ($ltype->{length} == 1 && $class);
  188   }
  189   if ($rtype->{name} eq 'Point' ||
  190       ($rtype->{name} eq 'Matrix' && !$rtype->{entryType}{entryType})) {
  191     $rtype = {%{$rtype}, name => 'Vector'};
  192     $rtype = Value::Type($class,1,Value::Type($class,1,$rtype->{entryType}))
  193       if ($rtype->{length} == 1 && $class);
  194   }
  195   return ($ltype,$rtype);
  196 }
  197 
  198 #
  199 #  Report an error if the operand types don't match.
  200 #
  201 sub matchError {
  202   my $self = shift;
  203   my ($ltype,$rtype) = @_;
  204   my ($op,$ref) = ($self->{bop});
  205   if ($ltype->{name} eq $rtype->{name})
  206        {$self->Error("Operands for '$op' must be of the same length")}
  207   else {$self->Error("Operands for '$op' must be of the same type")}
  208 }
  209 
  210 ##################################################
  211 #
  212 #  Service routines for adjusting the values of operands.
  213 #
  214 
  215 #
  216 #  Return a zero, or a list of zeros of the proper length.
  217 #
  218 sub makeZero {
  219   my $self = shift; my $op = shift; my $zero = shift;
  220   return $zero if ($op->isNumber);
  221   if ($zero->isNumber && $op->type =~ m/Point|Vector/) {
  222     $op->{coords} = []; $op->{isZero} = 1;
  223     foreach my $i (0..($op->length-1)) {push(@{$op->{coords}},$zero)}
  224     return $op
  225   }
  226   return $self;
  227 }
  228 
  229 #
  230 #  Produce a negated version of a BOP.
  231 #
  232 sub makeNeg {
  233   my $self = shift;
  234   $self->{lop} = shift; $self->{rop} = shift;
  235   return Parser::UOP::Neg($self);
  236 }
  237 
  238 #
  239 #  Reverse the operands (left <=> right).
  240 #
  241 sub swapOps {
  242   my $self = shift;
  243   my $tmp = $self->{lop}; $self->{lop} = $self->{rop}; $self->{rop} = $tmp;
  244   return $self;
  245 }
  246 
  247 #
  248 #  Get the variables from the two operands
  249 #
  250 sub getVariables {
  251   my $self = shift;
  252   return {%{$self->{lop}->getVariables},%{$self->{rop}->getVariables}};
  253 }
  254 
  255 ##################################################
  256 #
  257 #  Generate the various output formats.
  258 #
  259 
  260 
  261 #
  262 #  Produce a string version of the BOP.
  263 #
  264 #  Parentheses are added when either:
  265 #    we are told to from our parent
  266 #    the BOP says to (fullparens)
  267 #    the BOP's precedence is lower than it's parent's, or
  268 #    the precedences are equal and either
  269 #       the associativity is right
  270 #       or we are supposed to show parens for the same precedence
  271 #
  272 sub string {
  273   my ($self,$precedence,$showparens,$position,$outerRight) = @_;
  274   my $string; my $bop = $self->{def};
  275   my $addparens =
  276       defined($precedence) &&
  277       ($showparens eq 'all' || $bop->{fullparens} || $precedence > $bop->{precedence} ||
  278       ($precedence == $bop->{precedence} &&
  279         ($bop->{associativity} eq 'right' || $showparens eq 'same')));
  280   my $outerRight = !$addparens && ($outerRight || $position eq 'right');
  281 
  282   $string = $self->{lop}->string($bop->{precedence},$bop->{leftparens},'left',$outerRight).
  283             $bop->{string}.
  284             $self->{rop}->string($bop->{precedence},$bop->{rightparens},'right');
  285 
  286   if ($addparens) {
  287     if ($bop->{fullparens} and $string =~ m/\(/)
  288       {$string = "[".$string."]"} else {$string = "(".$string.")"}
  289   }
  290   return $string;
  291 }
  292 
  293 #
  294 #  Produce the TeX version of the BOP.
  295 #
  296 sub TeX {
  297   my ($self,$precedence,$showparens,$position,$outerRight) = @_;
  298   my $TeX; my $bop = $self->{def};
  299   my $addparens =
  300       defined($precedence) &&
  301       ($showparens eq 'all' || $precedence > $bop->{precedence} ||
  302       ($precedence == $bop->{precedence} &&
  303         ($bop->{associativity} eq 'right' || $showparens eq 'same')));
  304   my $outerRight = !$addparens && ($outerRight || $position eq 'right');
  305 
  306   $TeX = $self->{lop}->TeX($bop->{precedence},$bop->{leftparens},'left',$outerRight).
  307          (defined($bop->{TeX}) ? $bop->{TeX} : $bop->{string}) .
  308          $self->{rop}->TeX($bop->{precedence},$bop->{rightparens},'right');
  309 
  310   $TeX = '\left('.$TeX.'\right)' if ($addparens);
  311   return $TeX;
  312 }
  313 
  314 #
  315 #  Produce the perl version of the BOP.
  316 #
  317 sub perl {
  318   my $self= shift; my $parens = shift;
  319   my $bop = $self->{def};
  320   my ($lparen,$rparen); if (!$bop->{isCommand}) {$lparen = 1; $rparen = 2}
  321   my $perl =
  322         $self->{lop}->perl($lparen).
  323         (defined($bop->{perl}) ? $bop->{perl} : $bop->{string}).
  324         $self->{rop}->perl($rparen);
  325   $perl = '('.$perl.')' if $parens;
  326   return $perl;
  327 }
  328 
  329 #########################################################################
  330 #
  331 #  Load the subclasses.
  332 #
  333 
  334 use Parser::BOP::undefined;
  335 use Parser::BOP::comma;
  336 use Parser::BOP::union;
  337 use Parser::BOP::add;
  338 use Parser::BOP::subtract;
  339 use Parser::BOP::multiply;
  340 use Parser::BOP::divide;
  341 use Parser::BOP::power;
  342 use Parser::BOP::cross;
  343 use Parser::BOP::dot;
  344 use Parser::BOP::underscore;
  345 use Parser::BOP::equality;
  346 
  347 #########################################################################
  348 
  349 1;
  350 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9