root/trunk/jps2ps/exp2rpn.pl

#!/usr/bin/perl
# ========================================================================
#                               exp2rpn
# ========================================================================
# Jean-Michel Sarlat                                  mercredi 26 mai 2000
# ========================================================================
# Ce script  Perl  convertit  l'expression  d'une  fonction  mathématique 
# « simple » en  notation  polonaise inverse. 
# 
# mail : jm-sarlat@melusine.eu.org
# ========================================================================
# Copyright (c) 2000,2004 Jean-Michel Sarlat.  All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.


package exp2rpn;

@signes          = ("+","-","*","/","^","(",")",",");
@operateurs      = ("","add","sub","mul","div","exp","idiv","mod");
@identificateurs = ("cos","sin","tan","cotan","ln","sh","ch","th","arccos",
                    "arcsin","arctan","sqrt","Cos","Sin","Tan","Cotan","coTan",
                    "Arccos","Arcsin","Arctan","Exp","sinh","cosh","tanh","cotanh",
                    "fresnelC","fresnelS","argsinh","argcosh","argtanh","log","abs",
                    "max","min","ceiling","floor","round","truncate","factorielle",
                    "Anp","Cnp","binomiale","Poisson","Gauss","Gammaln","Bessel_j0",
                    "Bessel_y0","Bessel_j1","Bessel_y1");
## @identificateurs = ("cos","sin","tan","ln","sh","ch","th","arccos",
##                    "arcsin","arctan","argsh","argch","argth","sqrt","abs");

local $old_e = "";
local $old_l = "";

sub new {
    my $classe = shift;
    my $self = {};
    bless($self,$classe);
    
    $self->{expression} = shift;
    $self->{expression} =~ s/\s+//g;
    # Mise en réserve de l'expression en cas d'erreur.
    $old_e = $self->{expression};       
    
    my $rc = shift; # Référence à la table des variables.
    my $c = shift; # Référence à la table des constantes.
    push(@$rc,@$c);

    my $i = shift; # Référence à la table des fonctions.
    my $ri = [@identificateurs];
    push(@$ri, @$i);
    
    # Préparation de l'expression.
    $self->{ligne} = &Prepare($self->{expression},$rc,$ri);
    # Mise en réserve de la ligne.
    $old_l = $self->{ligne};
    
    # Constitution de la table.

    my $t = [split(/ /,$self->{ligne})];

    # Contruction de la chaîne RPN.
    $self->{rpn} = &Lecture($t,0,@$t-1,$rc,$ri);   
    $self->{rpn} =~ s/^ //;
    
    return $self;
}

sub RPN {
    my $self = shift;
    return $self->{rpn};
}

sub EXP {
    my $self = shift;
    return $self->{expression};
}

sub DESTROY {
    my $self = shift;
    # print "L'expression $self->{expression} a vécu!\n";
}

#============================ Traitement des erreurs =====================
sub Erreur {
    my ($e,$i) = @_;
    my $j = 0;
    if ($e == 1) {
        print STDOUT "Erreur lexicale !\n";
        my $lerreur = ""; my $j = 0;
        for ($j=0;$j<$i;$j++) {
            $lerreur = $lerreur."_";
        }
        $lerreur .= "^";
        print STDOUT "$old_e\n";
        print STDOUT $lerreur."\n";
    }
    if ($e == 2) {
        print STDOUT "Erreur de syntaxe !\n";
        print STDOUT "Votre expression : $old_e\n";
        print STDOUT "Il manque un opérateur (+,-,*,/,^) ou une accolade!\n";
    }
    exit(1);
}
#============================ Traitement des erreurs =====================


    
#=============================== Analyseur Lexical =======================
# Fonction :
#  Élimine les espaces superflus de la chaîne d'entrée et construit une 
#  chaine où tous les éléments (signes, fonctions, constantes, nombres) 
#  sont reconnus et séparés par un espace. Celle-ci est alors aisément 
#  sécable. La procédure à invoquer est [Prepare].
#=========================================================================

# Lire un nombre dans le flot de caractères
sub LireNombre {
    my($i,$c) = @_;
    my $nombre = "";
    while ($c->[$i] =~ /[0-9\.]/) {
        $nombre = $nombre.$c->[$i];
        $i++;
    }
    return($nombre,$i);
}

#Lire une chaîne de caractères alphabétiques dans le flot de caractères
sub LireChaine {
    my ($i,$c) = @_;
    my $chaine = "";
    while ($c->[$i] =~ /[a-zA-Z]/) {
        $chaine = $chaine.$c->[$i];
        $i++;
    }
    return($chaine,$i);
}

# Lire un identificateur de fonction dans le flot de caractères
sub LireIdentificateur {
    my($i,$c,$ri) = @_;
    my ($chaine,$j) = LireChaine($i,$c);
    my $identificateur = "";
    if ($j != $i) {
        foreach my $id (@$ri) {
            if ($chaine eq $id) {
                $identificateur = $id;
                $i = $j;
            }
        }
    }
    return($identificateur,$i);
}

# Lire la référence à une constante dans le flot de caractères
sub LireConstante {
    my ($i,$c,$rc) = @_;
    my ($chaine,$j) = LireChaine($i,$c);
    my $constante = "";
    if ($j != $i) {
        foreach my $const (@$rc) {
            if ($chaine eq $const) {
                $constante = $const;
                $i = $j;
            }
        }
    }
    return($constante,$i);
}

# Lire un signe dans le flot de caractères
sub LireSigne {
    my($i,$c) = @_;
    my $flag = 0;
    my $signe = "";
    foreach my $s (@signes) {
        if ($c->[$i] eq $s) {
            $signe = $s;
            $flag = 1;
        }
    }
    return($signe,$i+$flag);
}

# Préparation de la chaîne <expression> : $l.
sub Prepare {
    my($l,$rc,$ri) = @_;
    my($r,$i,$ii,$signe,$identificateur,$constante,$nombre);
    # Éclatement de la chaîne (tableau anonyme).
    my $c = [split(//,$l)];
    $ii = 0;
    while ($ii < @$c) {
        ($signe,$i) = LireSigne($ii,$c);
        if ($ii == $i) {
                ($identificateur,$i) = LireIdentificateur($ii,$c,$ri);
                if ($ii == $i) {
                        ($constante,$i) = LireConstante($ii,$c,$rc);
                        if ($ii == $i) {
                                ($nombre,$i) = LireNombre($ii,$c);
                                if ($ii == $i) {
                                        Erreur(1,$i); # Erreur lexicale !
                                } else {
                                        $r =  $r." $nombre";
                                        $ii = $i;
                                }
                        } else {
                                $r = $r." $constante";
                                $ii = $i;
                        }
                } else {
                        $r = $r." $identificateur";
                        $ii = $i;
                }
        } else {
            $r = $r." $signe";
            $ii = $i;
        }
    }
    $r =~ s/^ //;
    return($r);
}
#=============================== Analyseur Lexical =======================


# Lecture d'un signe d'opérateur dans la table
sub LectureSigne {
    my($t,$k) = @_;
    if ($t->[$k] eq "+") {
        return(1);
    }
    if ($t->[$k] eq "-") {
        return(2);
    }
    if ($t->[$k] eq "*") {
        return(3);
    }
    if ($t->[$k] eq "/") {
        return(4);
    }
    if ($t->[$k] eq ",") {
        return(0);
    }
    if ($t->[$k] eq "^") {
        return(5);
    }
}

# Détermine la nature d'un bloc
sub TestBloc {
    my($t,$k,$rc,$ri) = @_;
    # C'est une fonction, elle est normalement suivie de (
    if (&EstFonction($t->[$k],$ri) == 1) {
        return($k+2,0);
    }
    # C'est une accolade ouvrante
    if (&EstAccoladeO($t->[$k]) == 1) {
        return($k+1,0);
    }
    # C'est une constante
    if (&EstConstante($t->[$k],$rc) == 1) {
        return($k+1,1);
    }
    # C'est un nombre
    if (&EstNombre($t->[$k]) == 1) {
        return($k+1,1);
    }
}

# Recherche la fin d'un bloc
sub FinBloc {
    my ($t,$k,$rc,$ri) = @_;
    my ($ii,$flag) = TestBloc($t,$k,$rc,$ri);
    while ($flag <= 0) {
        if ($ii >= @$t) {
            Erreur(2,$k); # Erreur de syntaxe !
        }
        # C'est une accolade fermante
        # On monte, vers la sortie !
        if ($t->[$ii] eq ")") {
            $flag = $flag +1;
        }
        # C'est une accolade ouvrante
        # On descend
        if ($t->[$ii] eq "(") {
            $flag = $flag -1;
        }
        $ii++;
    }
    return($ii-1);
}

# Lecture d'une expression
sub Lecture {
    my($t,$i,$j,$rc,$ri) = @_;
    my($k,$c,$r0,$r1,$r2,$r3);
    $r0 = "";
    $r1 = "";
    $r2 = "";
    $r3 = "";
    $k = $i;
    $c = "";
    while ($k <= $j) {
        if ($t->[$k] eq "-") {
            $r0 = " neg";
            $k++;
            $i++;
        }
        if ($t->[$k] eq "+") {
            $k++;
            $i++;
        }
        $k = FinBloc($t,$k,$rc,$ri);
        $c = $c . &LectureBloc($t,$i,$k,$rc,$ri);
        $k++;
        $s = LectureSigne($t,$k);
        if ($s <= 0) {
            $c = $c.$r3.$r2.$r1.$r0;
            $r0 = "";
            $r1 = "";
            $r2 = "";
            $r3 = "";
        } elsif ($s <= 2) {
            $c = $c.$r3.$r2.$r0.$r1;
            $r0 = "";
            $r1 = " $operateurs[$s]";
            $r2 = "";
            $r3 = "";
        } elsif ($s <= 4) {
            $c = $c.$r3.$r2;
            $r3 = "";
            $r2 = " $operateurs[$s]";
        } else {
            $c = $c.$r3;
            $r3 = " $operateurs[$s]";
        }
        $k++;
        $i = $k;
    }
    return($c);
}

# Détermination si l'élément est une fonction
sub EstFonction {
    my($el,$ri) = @_;
    my $res = 0;
    foreach my $elt (@$ri) {
        if ($el eq $elt) {
            $res = 1;
        }
    }
    return($res);
}

# Détermination si l'élément est une constante
sub EstConstante {
    my($el,$rc) = @_;
    my $res = 0;
    foreach my $elt (@$rc) {
        if ($el eq $elt) {
            $res = 1;
        }
    }
    return($res);
}

# Détermination si l'élément est une accolade ouvrante
sub EstAccoladeO {
    my($el) = @_;
    my $res = 0;
    if ($el eq "(") {
        $res = 1;
    }
    return($res);
}

# Détermination si l'élément est un nombre
sub EstNombre {
    my($el) = @_;
    my $res = 0;
    if ($el =~ /[0-9\.]+/) {
        $res = 1;
    }
    return($res);
}

# Lecture d'un bloc : f ( ... ), ( ... ), nombre , x, constante
sub LectureBloc {
    my($t,$i,$j,$rc,$ri) = @_;
    if (EstFonction($t->[$i],$ri)) {
        return  Lecture($t,$i+2,$j-1,$rc,$ri)." ".$t->[$i];
    }
    if (EstConstante($t->[$i],$rc)) {
        return " ".$t->[$i];
    }
    if (EstAccoladeO($t->[$i])) {
        return Lecture($t,$i+1,$j-1,$rc,$ri);
    }
    if (EstNombre($t->[$i])) {
        return " ".$t->[$i];
    }
    return "";
}

package main;

use Getopt::Std;

getopts("v:c:f:");

sub PrepareChaineTable {
    my $c = shift;
    $c =~ s/\s+/ /g;
    $c =~ s/^ //;
    $c =~ s/ $//;
    return $c;
}

my $constantes,$variables,$fonctions;


# Référence à la table des variables
if ($opt_v) {
    $opt_v = PrepareChaineTable($opt_v);
    $variables = [split(/ /,$opt_v)]
} else {
    $variables = ["x"];
}

# Référence à la table des constantes
if ($opt_c) {
    $opt_c = PrepareChaineTable($opt_c);
    $constantes = [split(/ /,$opt_c)];
} else {
    $constantes = ["e","pi"];
}

# Référence à la table des fonctions ajoutées
if ($opt_f) {
    $opt_f = PrepareChaineTable($opt_f);
    $fonctions = [split(/ /,$opt_f)];
} else {
    $fonctions = [];
}
    
my $exp = exp2rpn->new($ARGV[0],$variables,$constantes,$fonctions);

print STDOUT $exp->RPN(), "\n";

exit(0);