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>  <Ouabache Design Works>              */
#/*                                                                    */
#/*  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);
}