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

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

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