Subversion Repositories socgen

eval 'exec `which perl` -S $0 ${1+"$@"}'

   if 0;

#/**********************************************************************/

#/*                                                                    */

#/*             -------                                                */

#/*            /   SOC  \                                              */

#/*           /    GEN   \                                             */

#/*          /    TOOL    \                                            */

#/*          ==============                                            */

#/*          |            |                                            */

#/*          |____________|                                            */

#/*                                                                    */

#/*                                                                    */

#/*                                                                    */

#/*                                                                    */

#/*  Author(s):                                                        */

#/*      - John Eaton, jt_eaton@opencores.org                          */

#/*                                                                    */

#/**********************************************************************/

#/*                                                                    */

#/*    Copyright (C) <2010-2011>                */

#/*                                                                    */

#/*  This source file may be used and distributed without              */

#/*  restriction provided that this copyright statement is not         */

#/*  removed from the file and that any derivative work contains       */

#/*  the original copyright notice and the associated disclaimer.      */

#/*                                                                    */

#/*  This source file is free software; you can redistribute it        */

#/*  and/or modify it under the terms of the GNU Lesser General        */

#/*  Public License as published by the Free Software Foundation;      */

#/*  either version 2.1 of the License, or (at your option) any        */

#/*  later version.                                                    */

#/*                                                                    */

#/*  This source is distributed in the hope that it will be            */

#/*  useful, but WITHOUT ANY WARRANTY; without even the implied        */

#/*  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR           */

#/*  PURPOSE.  See the GNU Lesser General Public License for more      */

#/*  details.                                                          */

#/*                                                                    */

#/*  You should have received a copy of the GNU Lesser General         */

#/*  Public License along with this source; if not, download it        */

#/*  from http://www.opencores.org/lgpl.shtml                          */

#/*                                                                    */

#/**********************************************************************/

############################################################################

# General PERL config

############################################################################

use Getopt::Long;

use English;

use File::Basename;

use Cwd;

use Scalar::Util qw(looks_like_number);

use XML::LibXML;

use lib './tools';

use sys::lib;

use yp::lib;

use BerkeleyDB;

use strict;

use warnings;

use Data::Dumper;

# this code can be re-written without any regex/eval,their use is purely for shortening the code

$OUTPUT_AUTOFLUSH = 1; # set autoflush of stdout to TRUE.

my $exp;

############################################################################

### Process the options

############################################################################

Getopt::Long::config("require_order", "prefix=-");

GetOptions("h","help",

           "exp=s" => \$exp

) || die "(use 'math -h' for help)";

my $opt_h;

my $opt_help;

##############################################################################

## Help option

##############################################################################

if ( $opt_h  or $opt_help  )

  { print "\n test   -exp 2+2  \n";

    exit 1;

  }

#############################################################################

##

##

#############################################################################

my $home = cwd();

my $result = solve($exp) ;

print "$exp ---  $result\n";

#/*********************************************************************************************/

#/                                                                                            */

#/  solve routine downloaded from perl monks                                                  */

#/                                                                                            */

#/  my $exp = "5*(12/(32+4))-10";                                                             */

#/  my $exp = "3**(6-1*4)**2";                                                                */

#/  my $exp = -3+(-1-2);                                                                      */

#/  my $exp = (3-(4+6))/2;                                                                    */

#/                                                                                            */

#/  my $result = math::lib::solve($exp);                                                      */

#/                                                                                            */

#/                                                                                            */

#/*********************************************************************************************/

sub solve {

    my $exp  = shift;

use constant BASE_PRIORITY =>

{

        NUMBER          => 2,

        OPEN_PARA       => 8,

        CLOSED_PARA => 8,

        ADD                     => 4,

        SUB                     => 4,

        MUL                     => 7,

        DIV                     => 7,

        POW                     => 9,

};

use constant DEPTH_BONUS => 10;

my $depth = 0;

my @terms;

sub delete_at { # delete the term at the index equal to the parameter given to this function

        return shift @terms if $_[0] == 0;

        return pop @terms if $_[0] == (@terms-1);

        my $ret = $terms[ $_[0] ];

        @terms = (

                @terms[0..$_[0]-1],

                @terms[$_[0]+1..@terms-1],

        );

        return $ret;

}

sub insert_at { # inserts a term exactly before the index given as parameter

        @terms = (

                @terms[0..$_[0]-1],

                $_[1],

                @terms[$_[0]..@terms-1],

        );

}

sub firstPass {# this builds up the @terms for later use

        while( $exp =~ s/^(\-?\d+|\*\*|\*|\/|\+|\-|\(|\))// ) {

                my $type=$1;

                my $term=$1;

                if( @terms>0 &&  $terms[@terms - 1 ]->{type} eq 'NUMBER' && $term =~ /\-\d+/ ) {

                        #see if we currently have a negative number,see if before we had a number

                        #this means that we're on the wrong track and that - is actually an operator here

                        #and not the sign for a negative number

                        $exp=$term.$exp;

                        $exp=~s/^-//;

                        $type = "SUB";

                        $term = '-';

                        print "EXP $exp \n";

                } else {

                        $type =~ s/\-?\d+/NUMBER/;

                };

                $type =~ s/\(/OPEN_PARA/;

                $type =~ s/\)/CLOSED_PARA/;

                $type =~ s/\+/ADD/;

                $type =~ s/\*\*/POW/;

                $type =~ s/\*/MUL/;

                $type =~ s/\//DIV/;

                $type =~ s/\-$/SUB/;

                my ($is_term_para) = $type =~ /OPEN_PARA|CLOSED_PARA/; # this flag will tell us wether the term is or is not a paranthesis

                $depth++ if $type eq 'OPEN_PARA';  # if we encounter an open paranthesis we increase depth

                $depth-- if $type eq 'CLOSED_PARA';# closed paranthesis we decrease it

                push @terms,

                {

                        type            => $type,

                        term            => $term,

                        priority        => BASE_PRIORITY->{$type} + $depth*DEPTH_BONUS

                }

                unless $is_term_para; # we leave out the paranthesis because we no longer need them(their purpose

                                                          # was to provide priority information for us)

        };

}

sub getPrioritary { # gets most prioritary 3 elements in the current expression

        my @sIndexes = sort { -1 * ( $terms[$a]->{priority} <=> $terms[$b]->{priority} ); } 0..(@terms-1) ;

        my $i = 0; # the index in @sIndexes

        my $middleMaxPrio = $sIndexes[$i];

        while( $terms[$middleMaxPrio]->{type} eq 'NUMBER' ) { # if our selected maximum priority element is not a number search for the next most prioritized that is a number

                print "[DEBUG] $terms[$middleMaxPrio]->{type}";

                $middleMaxPrio = $sIndexes[++$i];

        };

        my $leftNearMax   = $middleMaxPrio -1; # we take the left of $middleMaxPrio

        my $rightNearMax  = $middleMaxPrio +1; # and the right of it , becuase these two are surely operands

        my @selectedTerms = map { delete_at $_  } ( $rightNearMax , $middleMaxPrio , $leftNearMax ); # we delete them in inverse order to not alter the stack badly

        return {

                selected        => [ @selectedTerms ],

                insertIndex     => $leftNearMax,

                maxPriority     => $selectedTerms[1]->{priority}, # the middle element will be surely an operator so it will have maximum priority

        };

}

#---------------------------------------------------------------------------------------------------------------------

firstPass;

while( @terms > 1 ) {

        print "DEBUG ".Dumper [@terms];

        my $data = getPrioritary;

        my @elems = map { $_->{term} } @{ $data->{selected} };

        my $expr = sprintf "%s %s %s", reverse @elems;

        my $result = eval($expr); # the eval here has just been used for shortening the code,it could have very well been a simple switch on $elems[1]

        print "DEBUG [$expr]\n";

        insert_at

        $data->{insertIndex},

        {

                type    => 'NUMBER',

                term    => $result,

                priority=> $data->{maxPriority} - DEPTH_BONUS #we have calculated what was probably a paranthesis therefore we substrac a depth_bonus

        };

        <>;

};

my $result_out =$terms[0]->{term};

print "RESULT : $result_out \n";

    return($result_out);

}