Annotation of loncom/xml/algebra/AlgParser.pm, revision 1.4

1.1       albertel    1: 
                      2: 
                      3: ## Last modification: 8/3/00 by akp
                      4: ## Originally written by Daniel Martin, Dept of Math, John Hopkins
                      5: ## Additions and modifications were made by James Martino, Dept of Math, John Hopkins
                      6: ## Additions and modifications were made by Arnold Pizer, Dept of Math, Univ of Rochester
                      7: 
                      8: #use Data::Dumper;
1.2       albertel    9: use strict;
1.1       albertel   10: 
                     11: package AlgParser;
                     12: use HTML::Entities;
                     13: 
1.2       albertel   14: my %close = ();
1.1       albertel   15: 
                     16: sub new {
                     17:   my $package = shift;
                     18:   my (%ret);
                     19:   $ret{string} = "";
                     20:   $ret{posarray} = [];
                     21:   $ret{parseerror} = "";
                     22:   $ret{parseresult} = [];
                     23:   bless \%ret, $package;
                     24:   return \%ret;
                     25: }
                     26: 
                     27: sub inittokenizer {
                     28:   my($self, $string) = @_;
                     29:   $self->{string} =~ m/\G.*$/g;
                     30:   $self->{string} = undef;
                     31:   $self->{string} = $string;
                     32:   $self->{string} =~ m/\G.*$/g;
                     33:   $self->{string} =~ m/^/g;
                     34: }
                     35: 
                     36: $close{'{'} = '}';
                     37: $close{'['} = ']';
                     38: $close{'('} = ')';
                     39: 
1.2       albertel   40: my $binoper3 = '(?:\\^|\\*\\*)';
                     41: my $binoper2 = '[/*_,]';
                     42: my $binoper1 = '[-+=><%!#]';
                     43: my $openparen = '[{(\\[]';
                     44: my $closeparen = '[})\\]]';
                     45: my $varname = '[A-Za-z](?:_[0-9]+)?';
1.3       albertel   46: my $greek='alpha|bita|gamma|zita|thita|iota|kappa|lambda|mu|nu|xi|rho|sigma|tau|phi|chi|psi|omega|zepslon|zdelta|xeta|zupslon';
                     47: my $delete='zeroplace';
                     48: my $escape='infty';
1.4     ! albertel   49: my $specialvalue = '(?:e|pi|d[a-z]|'.$escape.'|'.$greek.'|'.$delete.')';
1.2       albertel   50: my $numberplain = '(?:\d+(?:\.\d*)?|\.\d+)';
                     51: my $numberE = '(?:' . $numberplain . 'E[-+]?\d+)';
                     52: my $number = '(?:' . $numberE . '|' . $numberplain . ')';
1.1       albertel   53: #
                     54: #  DPVC -- 2003/03/31
                     55: #       added missing trig and inverse functions
                     56: #
                     57: #$trigfname = '(?:cosh|sinh|tanh|cot|(?:a(?:rc)?)?cos|(?:a(?:rc)?)?sin|' .
                     58: #    '(?:a(?:rc)?)?tan|sech?)';
1.2       albertel   59: my $trigfname = '(?:(?:a(?:rc)?)?(?:sin|cos|tan|sec|csc|cot)h?)';
1.1       albertel   60: #
                     61: #  End DPVC
                     62: #
1.2       albertel   63: my $otherfunc = '(?:exp|abs|logten|log|ln|sqrt|sgn|step|fact|int|lim|fun[a-zA-Z])';
                     64: my $funcname = '(?:' . $otherfunc . '|' . $trigfname . ')';
1.1       albertel   65: 
1.2       albertel   66: my $tokenregexp = "(?:($binoper3)|($binoper2)|($binoper1)|($openparen)|" .
1.1       albertel   67:     "($closeparen)|($funcname)|($specialvalue)|($varname)|" .
                     68:     "($numberE)|($number))";
                     69: 
                     70: sub nexttoken {
                     71:   my($self) = shift;
                     72:   $self->{string} =~ m/\G\s+/gc;
                     73:   my($p1) = pos($self->{string}) || 0;
                     74:   if(scalar($self->{string} =~ m/\G$tokenregexp/gc)) {
                     75:         push @{$self->{posarray}}, [$p1, pos($self->{string})];
                     76: 	if (defined($1)) {return ['binop3',  $1];}
                     77: 	if (defined($2)) {return ['binop2',  $2];}
                     78: 	if (defined($3)) {return ['binop1',  $3];}
                     79: 	if (defined($4)) {return ['openp',   $4];}
                     80: 	if (defined($5)) {return ['closep',  $5];}
                     81: 	if (defined($6)) {return ['func1',   $6];}
                     82: 	if (defined($7)) {return ['special', $7];}
                     83: 	if (defined($8)) {return ['varname', $8];}
                     84: 	if (defined($9)) {return ['numberE', $9];}
                     85: 	if (defined($10)) {return ['number', $10];}
                     86:   }
                     87:   else {
                     88:     push @{$self->{posarray}}, [$p1, undef];
                     89:     return undef;
                     90:   }
                     91: }
                     92: 
                     93: sub parse {
                     94:   my $self = shift;
                     95:   $self->{parseerror} = "";
                     96:   $self->{posarray} = [];
                     97:   $self->{parseresult} = ['top', undef];
                     98:   my (@backtrace) = (\$self->{parseresult});
                     99:   my (@pushback) = ();
                    100: 
                    101:   my $currentref = \$self->{parseresult}->[1];
1.2       albertel  102:   my $currenttok;
1.1       albertel  103: 
                    104:   my $sstring = shift;
                    105:   $self->inittokenizer($sstring);
                    106:   $currenttok = $self->nexttoken;
                    107:   if (!$currenttok) {
                    108:     if ($self->{string} =~ m/\G$/g) {
                    109:       return $self->error("empty");
                    110:     } else {
                    111:       my($mark) = pop @{$self->{posarray}};
                    112:       my $position = 1+$mark->[0];
                    113:       return $self->error("Illegal character at position $position", $mark);
                    114:     }
                    115:   }
                    116:   # so I can assume we got a token
                    117:   local $_;
                    118:   while ($currenttok) {
                    119:     $_ = $currenttok->[0];
                    120:     /binop1/ && do {
                    121:       # check if we have a binary or unary operation here.
                    122:       if (defined(${$currentref})) {
                    123:         # binary - walk up the tree until we hit an open paren or the top
                    124:         while (${$currentref}->[0] !~ /^(openp|top)/) {
                    125:           $currentref = pop @backtrace;
                    126:         }
                    127: 	my $index = ((${$currentref}->[0] eq 'top')?1:3);
                    128:         ${$currentref}->[$index] = ['binop1', $currenttok->[1],
                    129:                                     ${$currentref}->[$index], undef];
                    130:         push @backtrace, $currentref;
                    131:         push @backtrace, \${$currentref}->[$index];
                    132:         $currentref = \${$currentref}->[$index]->[3];
                    133:       } else {
                    134:         # unary
                    135:         ${$currentref} = ['unop1', $currenttok->[1], undef];
                    136:         push @backtrace, $currentref;
                    137:         $currentref = \${$currentref}->[2];
                    138:       }
                    139:     };
                    140:     /binop2/ && do {
                    141:       if (defined(${$currentref})) {
                    142:         # walk up the tree until an open paren, the top, binop1 or unop1
                    143:         # I decide arbitrarily that -3*4 should be parsed as -(3*4)
                    144:         # instead of as (-3)*4.  Not that it makes a difference.
                    145: 
                    146:         while (${$currentref}->[0] !~ /^(openp|top|binop1)/) {
                    147:           $currentref = pop @backtrace;
                    148:         }
                    149:         my $a = ${$currentref}->[0];
                    150:         my $index = (($a eq 'top')?1:3);
                    151:         ${$currentref}->[$index] = ['binop2', $currenttok->[1],
                    152:                                     ${$currentref}->[$index], undef];
                    153:         push @backtrace, $currentref;
                    154:         push @backtrace, \${$currentref}->[$index];
                    155:         $currentref = \${$currentref}->[$index]->[3];
                    156:       } else {
                    157:         # Error
                    158:         my($mark) = pop @{$self->{posarray}};
                    159:         my $position =1+$mark->[0];
                    160:         return $self->error("Didn't expect " . $currenttok->[1] .
                    161:                             " at position $position" , $mark);
                    162:       }
                    163:     };
                    164:     /binop3/ && do {
                    165:       if (defined(${$currentref})) {
                    166:         # walk up the tree until we need to stop
                    167:         # Note that the right-associated nature of ^ means we need to
                    168:         # stop walking backwards when we hit a ^ as well.
                    169:         while (${$currentref}->[0] !~ /^(openp|top|binop[123]|unop1)/) {
                    170:           $currentref = pop @backtrace;
                    171:         }
                    172:         my $a = ${$currentref}->[0];
                    173:         my $index = ($a eq 'top')?1:($a eq 'unop1')?2:3;
                    174:         ${$currentref}->[$index] = ['binop3', $currenttok->[1],
                    175:                                     ${$currentref}->[$index], undef];
                    176:         push @backtrace, $currentref;
                    177:         push @backtrace, \${$currentref}->[$index];
                    178:         $currentref = \${$currentref}->[$index]->[3];
                    179:       } else {
                    180:         # Error
                    181:         my($mark) = pop @{$self->{posarray}};
                    182:         my $position = 1+$mark->[0];
                    183:         return $self->error("Didn't expect " . $currenttok->[1] .
                    184:                             " at position $position", $mark);
                    185:       }
                    186:     };
                    187:     /openp/ && do {
                    188:       if (defined(${$currentref})) {
                    189:         # we weren't expecting this - must be implicit
                    190:         # multiplication.
                    191:         push @pushback, $currenttok;
                    192:         $currenttok = ['binop2', 'implicit'];
                    193:         next;
                    194:       } else {
                    195:         my($me) = pop @{$self->{posarray}};
                    196:         ${$currentref} = [$currenttok->[0], $currenttok->[1], $me, undef];
                    197:         push @backtrace, $currentref;
                    198:         $currentref = \${$currentref}->[3];
                    199:       }
                    200:     };
                    201:     /func1/ && do {
                    202:       if (defined(${$currentref})) {
                    203:         # we weren't expecting this - must be implicit
                    204:         # multiplication.
                    205:         push @pushback, $currenttok;
                    206:         $currenttok = ['binop2', 'implicit'];
                    207:         next;
                    208:       } else {
                    209:         # just like a unary operator
                    210:         ${$currentref} = [$currenttok->[0], $currenttok->[1], undef];
                    211:         push @backtrace, $currentref;
                    212:         $currentref = \${$currentref}->[2];
                    213:       }
                    214:     };
                    215:     /closep/ && do {
                    216:       if (defined(${$currentref})) {
                    217:         # walk up the tree until we need to stop
                    218:         while (${$currentref}->[0] !~ /^(openp|top)/) {
                    219:           $currentref = pop @backtrace;
                    220:         }
                    221:         my $a = ${$currentref}->[0];
                    222:         if ($a eq 'top') {
                    223:           my($mark) = pop @{$self->{posarray}};
                    224:           my $position = 1+$mark->[0];
                    225:           return $self->error("Unmatched close " . $currenttok->[1] .
                    226:                               " at position $position", $mark);
                    227:         } elsif ($close{${$currentref}->[1]} ne $currenttok->[1]) {
                    228:           my($mark) = pop @{$self->{posarray}};
                    229:           my $position = 1+$mark->[0];
                    230:           return $self->error("Mismatched parens at position $position"
                    231:                               , ${$currentref}->[2], $mark);
                    232:         } else {
                    233:           ${$currentref}->[0] = 'closep';
                    234:           ${$currentref}->[2] = pop @{${$currentref}};
                    235:         }
                    236:       } else {
                    237:         # Error - something like (3+4*)
                    238:         my($mark) = pop @{$self->{posarray}};
                    239:         my $position = 1+$mark->[0];
                    240:         return $self->error("Premature close " . $currenttok->[1] .
                    241:                             " at position $position", $mark);
                    242:       }
                    243:     };
                    244:     /special|varname|numberE?/ && do {
                    245:       if (defined(${$currentref})) {
                    246:         # we weren't expecting this - must be implicit
                    247:         # multiplication.
                    248:         push @pushback, $currenttok;
                    249:         $currenttok = ['binop2', 'implicit'];
                    250:         next;
                    251:       } else {
                    252:         ${$currentref} = [$currenttok->[0], $currenttok->[1]];
                    253:       }
                    254:     };
                    255:     if (@pushback) {
                    256:       $currenttok = pop @pushback;
                    257:     } else {
                    258:       $currenttok = $self->nexttoken;
                    259:     }
                    260:   }
                    261:   # ok, we stopped parsing.  Now we need to see why.
                    262:   if ($self->{parseresult}->[0] eq 'top') {
                    263:     $self->{parseresult} = $self->arraytoexpr($self->{parseresult}->[1]);
                    264:   } else {
                    265:     return $self->error("Internal consistency error; not at top when done");
                    266:   }
                    267:   if ($self->{string} =~ m/\G\s*$/g) {
                    268:     if (!defined(${$currentref})) {
                    269:       $self->{string} .= " ";
                    270:       return $self->error("I was expecting more at the end of the line",
                    271:                         [length($self->{string})-1, length($self->{string})]);
                    272:     } else {
                    273:       # check that all the parens were closed
                    274:       while (@backtrace) {
                    275:         $currentref = pop @backtrace;
                    276:         if (${$currentref}->[0] eq 'openp') {
                    277:           my($mark) = ${$currentref}->[2];
                    278:           my $position = 1+$mark->[0];
                    279:           return $self->error("Unclosed parentheses beginning at position $position"
                    280:                          , $mark);
                    281:         }
                    282:       }
                    283:       # Ok, we must really have parsed something
                    284:       return $self->{parseresult};
                    285:     }
                    286:   } else {
                    287:       my($mark) = pop @{$self->{posarray}};
                    288:       my $position = 1+$mark->[0];
                    289:       return $self->error("Illegal character at position $position",$mark);
                    290:   }
                    291: }
                    292: 
                    293: sub arraytoexpr {
                    294:   my ($self) = shift;
                    295:   return Expr->fromarray(@_);
                    296: }
                    297: 
                    298: sub error {
                    299:   my($self, $errstr, @markers) = @_;
                    300: #  print STDERR Data::Dumper->Dump([\@markers],
                    301: #                                  ['$markers']);
                    302:   $self->{parseerror} = $errstr;
                    303:   my($htmledstring) = '<tt class="parseinput">';
                    304:   my($str) = $self->{string};
                    305: #  print STDERR Data::Dumper->Dump([$str], ['$str']);
                    306:   my($lastpos) = 0;
                    307:   $str =~ s/ /\240/g;
                    308:   while(@markers) {
                    309:     my($ref) = shift @markers;
                    310:     my($pos1) = $ref->[0];
                    311:     my($pos2) = $ref->[1];
                    312:     if (!defined($pos2)) {$pos2 = $pos1+1;}
                    313:     $htmledstring .= encode_entities(substr($str,$lastpos,$pos1-$lastpos)) .
                    314:            '<b class="parsehilight">' .
                    315:            encode_entities(substr($str,$pos1,$pos2-$pos1)) .
                    316:            '</b>';
                    317:     $lastpos = $pos2;
                    318:   }
                    319: #  print STDERR Data::Dumper->Dump([$str, $htmledstring, $lastpos],
                    320: #                                  ['$str', '$htmledstring', '$lastpos']);
                    321:   $htmledstring .= encode_entities(substr($str,$lastpos));
                    322:   $htmledstring .= '</tt>';
                    323: #  $self->{htmlerror} = '<p class="parseerr">' . "\n" .
                    324: #                       '<span class="parsedesc">' .
                    325: #                       encode_entities($errstr) . '</span><br>' . "\n" .
                    326: #                       $htmledstring . "\n" . '</p>' . "\n";
                    327:   $self->{htmlerror} =  $htmledstring ;
                    328:   $self->{htmlerror} =  'empty' if $errstr eq 'empty';
                    329:   $self->{error_msg} = $errstr;
                    330: 
                    331: #  warn $errstr . "\n";
                    332:   return undef;
                    333: }
                    334: 
                    335: sub tostring {
                    336:   my ($self) = shift;
                    337:   return $self->{parseresult}->tostring(@_);
                    338: }
                    339: 
                    340: sub tolatex {
                    341:   my ($self) = shift;
                    342:   return $self->{parseresult}->tolatex(@_);
                    343: }
                    344: 
                    345: sub tolatexstring { return tolatex(@_);}
                    346: 
                    347: sub exprtolatexstr {
                    348:   return exprtolatex(@_);
                    349: }
                    350: 
                    351: sub exprtolatex {
                    352:   my($expr) = shift;
                    353:   my($exprobj);
                    354:   if ((ref $expr) eq 'ARRAY') {
                    355:     $exprobj = Expr->new(@$expr);
                    356:   } else {
                    357:     $exprobj = $expr;
                    358:   }
                    359:   return $exprobj->tolatex();
                    360: }
                    361: 
                    362: sub exprtostr {
                    363:   my($expr) = shift;
                    364:   my($exprobj);
                    365:   if ((ref $expr) eq 'ARRAY') {
                    366:     $exprobj = Expr->new(@$expr);
                    367:   } else {
                    368:     $exprobj = $expr;
                    369:   }
                    370:   return $exprobj->tostring();
                    371: }
                    372: 
                    373: sub normalize {
                    374:   my ($self, $degree) = @_;
                    375:   $self->{parseresult} = $self->{parseresult}->normalize($degree);
                    376: }
                    377: 
                    378: sub normalize_expr {
                    379:   my($expr, $degree) = @_;
                    380:   my($exprobj);
                    381:   if ((ref $expr) eq 'ARRAY') {
                    382:     $exprobj = Expr->new(@$expr);
                    383:   } else {
                    384:     $exprobj = $expr;
                    385:   }
                    386:   return $exprobj->normalize($degree);
                    387: }
                    388: 
                    389: package AlgParserWithImplicitExpand;
1.2       albertel  390: no strict;
1.1       albertel  391: @ISA=qw(AlgParser);
1.2       albertel  392: use strict;
1.1       albertel  393: 
                    394: sub arraytoexpr {
                    395:   my ($self) = shift;
                    396:   my ($foo) = ExprWithImplicitExpand->fromarray(@_);
                    397: # print STDERR Data::Dumper->Dump([$foo],['retval']);
                    398:   return $foo;
                    399: }
                    400: 
                    401: package Expr;
                    402: 
                    403: sub new {
                    404:   my($class) = shift;
                    405:   my(@args) = @_;
                    406:   my($ret) = [@args];
                    407:   return (bless $ret, $class);
                    408: }
                    409: 
                    410: sub head {
                    411:   my($self) = shift;
                    412:   return ($self->[0]);
                    413: }
                    414: 
                    415: 
                    416: sub normalize {
                    417: #print STDERR "normalize\n";
                    418: #print STDERR Data::Dumper->Dump([@_]);
                    419: 
                    420:   my($self, $degree) = @_;
                    421:   my($class) = ref $self;
                    422:   $degree = $degree || 0;
                    423:   my($type, @args) = @$self;
                    424:   local $_;
                    425:   $_ = $type;
                    426:   my ($ret) = [$type, @args];
                    427: 
                    428: 
                    429:   if(/closep/) {
                    430:     $ret = $args[1]->normalize($degree);
                    431:   } elsif (/unop1/) {
                    432:     $ret = $class->new($type, $args[0], $args[1]->normalize($degree));
                    433:   } elsif (/binop/) {
                    434:     $ret = $class->new($type, $args[0], $args[1]->normalize($degree),
                    435:                              $args[2]->normalize($degree));
                    436:   } elsif (/func1/) {
                    437:     $args[0] =~ s/^arc/a/;
                    438:     $ret = $class->new($type, $args[0], $args[1]->normalize($degree));
                    439:   }
                    440: 
                    441: 
                    442:   if ($degree < 0) {return $ret;}
                    443: 
                    444: 
                    445:   ($type, @args) = @$ret;
                    446:   $ret = $class->new($type, @args);
                    447:   $_ = $type;
                    448:   if (/binop1/ && ($args[2]->[0] =~ 'unop1')) {
                    449:     my($h1, $h2) = ($args[0], $args[2]->[1]);
                    450:     my($s1, $s2) = ($h1 eq '-', $h2 eq '-');
                    451:     my($eventual) = ($s1==$s2);
                    452:     if ($eventual) {
                    453:       $ret = $class->new('binop1', '+', $args[1], $args[2]->[2] );
                    454:     } else {
                    455:       $ret = $class->new('binop1', '-', $args[1], $args[2]->[2] );
                    456:     }
                    457:   } elsif (/binop2/ && ($args[1]->[0] =~ 'unop1')) {
                    458:     $ret = $class->new('unop1', '-',
                    459:                        $class->new($type, $args[0], $args[1]->[2],
                    460:                                    $args[2])->normalize($degree) );
                    461:   } elsif (/binop[12]/ && ($args[2]->[0] eq $type) &&
                    462:                           ($args[0] =~ /[+*]/)) {
                    463: # Remove frivolous right-association
                    464: # For example, fix 3+(4-5) or 3*(4x)
                    465:     $ret = $class->new($type, $args[2]->[1],
                    466:                        $class->new($type, $args[0], $args[1],
                    467:                                    $args[2]->[2])->normalize($degree),
                    468:                        $args[2]->[3]);
                    469:   } elsif (/unop1/ && ($args[0] eq '+')) {
                    470:     $ret = $args[1];
                    471:   } elsif (/unop1/ && ($args[1]->[0] =~ 'unop1')) {
                    472:     $ret = $args[1]->[2];
                    473:   }
                    474:   if ($degree > 0) {
                    475:   }
                    476:   return $ret;
                    477: }
                    478: 
                    479: sub tostring {
                    480: # print STDERR "Expr::tostring\n";
                    481: # print STDERR Data::Dumper->Dump([@_]);
                    482:   my($self) = shift;
                    483:   my($type, @args) = @$self;
                    484:   local $_;
                    485:   $_ = $type;
                    486:   /binop1/ && do {
                    487:     my ($p1, $p2) = ('','');
                    488:     if ($args[2]->[0] eq 'binop1') {($p1,$p2)=qw{ ( ) };}
                    489:     return ($args[1]->tostring() . $args[0] . $p1 .
                    490:             $args[2]->tostring() . $p2);
                    491:   };
                    492:   /unop1/ && do {
                    493:     my ($p1, $p2) = ('','');
                    494:     if ($args[1]->[0] =~ /binop1/) {($p1,$p2)=qw{ ( ) };}
                    495:     return ($args[0] . $p1 . $args[1]->tostring() . $p2);
                    496:   };
                    497:   /binop2/ && do {
                    498:     my ($p1, $p2, $p3, $p4)=('','','','');
                    499:     if ($args[0] =~ /implicit/) {$args[0] = ' ';}
                    500:     if ($args[1]->[0] =~ /binop1/) {($p1,$p2)=qw{ ( ) };}
                    501: #    if ($args[2]->[0] =~ /binop[12]/) {($p3,$p4)=qw{ ( ) };}
                    502:     if ($args[2]->[0] =~ /binop[12]|unop1/) {($p3,$p4)=qw{ ( ) };}
                    503:     return ($p1 . $args[1]->tostring() . $p2 . $args[0] . $p3 .
                    504:             $args[2]->tostring() . $p4);
                    505:   };
                    506:   /binop3/ && do {
                    507:     my ($p1, $p2, $p3, $p4)=('','','','');
                    508: #    if ($args[1]->[0] =~ /binop[123]|numberE/) {($p1,$p2)=qw{ ( ) };}
                    509:     if ($args[1]->[0] =~ /binop[123]|unop1|numberE/) {($p1,$p2)=qw{ ( ) };}
                    510: #    if ($args[2]->[0] =~ /binop[12]|numberE/) {($p3,$p4)=qw{ ( ) };}
                    511:     if ($args[2]->[0] =~ /binop[12]|unop1|numberE/) {($p3,$p4)=qw{ ( ) };}
                    512:     return ($p1 . $args[1]->tostring() . $p2 . $args[0] . $p3 .
                    513:             $args[2]->tostring() . $p4);
                    514:   };
                    515:   /func1/ && do {
                    516:     return ($args[0] . '(' . $args[1]->tostring() . ')');
                    517:   };
                    518:   /special|varname|numberE?/ && return $args[0];
                    519:   /closep/ && do {
                    520:     my(%close) = %AlgParser::close;
                    521: 
                    522: 
                    523: 
                    524:     return ($args[0] . $args[1]->tostring() . $close{$args[0]});
                    525:   };
                    526: }
                    527: 
                    528: sub tolatex {
                    529:   my($self) = shift;
                    530:   my($type, @args) = @$self;
                    531:   local $_;
                    532:   $_ = $type;
                    533:   /binop1/ && do {
                    534:     my ($p1, $p2) = ('','');
                    535:     if ($args[2]->[0] eq 'binop1') {($p1,$p2)=qw{ \left( \right) };}
                    536:     return ($args[1]->tolatex() . $args[0] . $p1 .
                    537:             $args[2]->tolatex() . $p2);
                    538:   };
                    539:   /unop1/ && do {
                    540:     my ($p1, $p2) = ('','');
                    541:     if ($args[1]->[0] =~ /binop1/) {($p1,$p2)=qw{ \left( \right) };}
                    542:     return ($args[0] . $p1 . $args[1]->tolatex() . $p2);
                    543:   };
                    544:   /binop2/ && do {
                    545:     my ($p1, $p2, $p3, $p4) = ('','','','');
                    546:     if ($args[0] =~ /implicit/) {
                    547:       if ( (($args[1]->head eq qq(number)) &&
                    548:             ($args[2]->head eq qq(number))) ||
                    549:            (($args[1]->head eq qq(binop2)) &&
                    550:             ($args[1]->[2]->head eq qq(number))) ) {
                    551:         $args[0] = '\\,';
                    552:       } else {
                    553:         $args[0] = ' ';
                    554:       }
                    555:     }
                    556:     if ($args[1]->[0] =~ /binop1|numberE/)
                    557:       {($p1,$p2)=qw{ \left( \right) };}
                    558:  #   if ($args[2]->[0] =~ /binop[12]|numberE/)
                    559: 	if ($args[2]->[0] =~ /binop[12]|numberE|unop1/)
                    560:       {($p3,$p4)=qw{ \left( \right) };}
                    561:     if ($args[0] eq '/'){
                    562: #	return('\frac{' . $p1 . $args[1]->tolatex() . $p2 . '}'.
                    563: #               '{' . $p3 . $args[2]->tolatex() . $p4 . '}' );
                    564: 	return('\frac{' . $args[1]->tolatex() . '}'.
                    565:                '{' . $args[2]->tolatex() . '}' ); 
                    566:     }
1.2       albertel  567:     elsif ($args[0] eq '*'){
                    568: #	return('\frac{' . $p1 . $args[1]->tolatex() . $p2 . '}'.
                    569: #               '{' . $p3 . $args[2]->tolatex() . $p4 . '}' );
                    570: 	return($args[1]->tolatex() . '\cdot ' . $args[2]->tolatex() ); 
                    571:     }
1.1       albertel  572:     else{
                    573:     return ($p1 . $args[1]->tolatex() . $p2 . $args[0] . $p3 .
                    574:             $args[2]->tolatex() . $p4);
                    575:     }
                    576:   };
                    577:   /binop3/ && do {
                    578:     my ($p1, $p2, $p3, $p4)=('','','','');
                    579: #    if ($args[1]->[0] =~ /binop[123]|numberE/) {($p1,$p2)=qw{ \left( \right) };}
                    580:   if ($args[1]->[0] =~ /binop[123]|unop1|numberE/) {($p1,$p2)=qw{ \left( \right) };}
                    581: # Not necessary in latex
                    582: #   if ($args[2]->[0] =~ /binop[12]/) {($p3,$p4)=qw{ \left( \right) };}
                    583:     return ($p1 . $args[1]->tolatex() . $p2 . "^{" . $p3 .
                    584:             $args[2]->tolatex() . $p4 . "}");
                    585:   };
                    586:   /func1/ && do {
                    587:       my($p1,$p2);
                    588:       if($args[0] eq "sqrt"){($p1,$p2)=qw{ \left{ \right} };}
                    589:       else {($p1,$p2)=qw{ \left( \right) };}
                    590: 
                    591:       #
                    592:       #  DPVC -- 2003/03/31
                    593:       #       added missing trig functions
                    594:       #
                    595:       #$specialfunc = '(?:abs|logten|asin|acos|atan|sech|sgn|step|fact)';
1.2       albertel  596:       my $specialfunc = '(?:abs|logten|a(?:sin|cos|tan|sec|csc|cot)h?|sgn|step|fact)';
1.1       albertel  597:       #
                    598:       #  End DPVC
                    599:       #
                    600: 
                    601:       if ($args[0] =~ /$specialfunc/) {
                    602:          return ('\mbox{' . $args[0] .'}'. $p1 . $args[1]->tolatex() . $p2);
                    603:       }
                    604:       else {
                    605:         return ('\\' . $args[0] . $p1 . $args[1]->tolatex() . $p2);
                    606:       }
                    607:   };
                    608:   /special/ && do {
                    609:     if ($args[0] eq 'pi') {return '\pi';} else {return $args[0];}
                    610:   };
                    611:   /varname|(:?number$)/ && return $args[0];
                    612:   /numberE/ && do {
                    613:     $args[0] =~ m/($AlgParser::numberplain)E([-+]?\d+)/;
                    614:     return ($1 . '\times 10^{' . $2 . '}');
                    615:   };
                    616:   /closep/ && do {
                    617:     my($backslash) = '';
                    618:     my(%close) = %AlgParser::close;
                    619:     if ($args[0] eq '{') {$backslash = '\\';}
                    620: #This is for editors to match: }
                    621:     return ('\left' . $backslash . $args[0] . $args[1]->tolatex() .
                    622:             '\right' . $backslash . $close{$args[0]});
                    623:   };
                    624: }
                    625: 
                    626: sub fromarray {
                    627:   my($class) = shift;
                    628:   my($expr) = shift;
                    629:   if ((ref $expr) ne qq{ARRAY}) {
                    630:     die "Program error; fromarray not passed an array ref.";
                    631:   }
                    632:   my($type, @args) = @$expr;
                    633:   foreach my $i (@args) {
                    634:     if (ref $i) {
                    635:       $i = $class->fromarray($i);
                    636:     }
                    637:   }
                    638:   return $class->new($type, @args);
                    639: }
                    640: 
                    641: package ExprWithImplicitExpand;
1.2       albertel  642: no strict;
1.1       albertel  643: @ISA=qw(Expr);
1.2       albertel  644: use strict;
1.1       albertel  645: 
                    646: sub tostring {
                    647: # print STDERR "ExprWIE::tostring\n";
                    648: # print STDERR Data::Dumper->Dump([@_]);
                    649:   my ($self) = shift;
                    650: 
                    651:   my($type, @args) = @$self;
                    652: 
                    653:   if (($type eq qq(binop2)) && ($args[0] eq qq(implicit))) {
                    654:     my ($p1, $p2, $p3, $p4)=('','','','');
                    655:     if ($args[1]->head =~ /binop1/) {($p1,$p2)=qw{ ( ) };}
                    656: #    if ($args[2]->head =~ /binop[12]/) {($p3,$p4)=qw{ ( ) };}
                    657:     if ($args[2]->head =~ /binop[12]|unop1/) {($p3,$p4)=qw{ ( ) };}
                    658:     return ($p1 . $args[1]->tostring() . $p2 . '*' . $p3 .
                    659:             $args[2]->tostring() . $p4);
                    660:   } else {
                    661:     return $self->SUPER::tostring(@_);
                    662:   }
                    663: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>