!!吉祥寺.pm #20 へ行ってきた
東京に出張に来ていたので2019/11/22吉祥寺.pm #20へ行ってきた。色々と刺激を受けた。発表のなかで、めもりー（@m3m0r7）さんの『PHP で AST 解析して Java の中間コードを生成する』に刺激を受けて、中置記法から抽象構文木(AST)変換し後置記法（逆ポーランド記法）の計算を作ってみた。以前に中置記法から後置記法（逆ポーランド記法）への変換と計算でスタックを使った逆ポーランド記法のプログラムを作ったが、今回はASTで計算してみた。（当然paerlで）

https://kabukawa.hatenablog.jp/entry/2019/11/25/012334 <-良くまとっ待っている

!!Source
!実行
 $ perl ast.pl 10+1
 10 + 1
 11
 $
 
mojoliciousで動くように修正した。
*[デモ画面|http://www21051ue.sakura.ne.jp:3003/api/Ast/ast]
{{ref_image 2019-12-06 (2).png}}
*[code|https://github.com/john-smith-7701/mmt/blob/master/toolmmt/lib/Tool/mmt/Controller/Ast.pm]
!ast.pl
 use lib 'lib';
 use Ast;
 use Data::Dumper;
 
 my $c = Ast->new;
 #my $t = $c->adjust('(100+2**3-((1+2)/(4+-2))*(-10))');
 my $t = $c->adjust(join '',@ARGV);
 $c->item_split($t);
 my $root = $c->makeTree(@{$c->{item}});
 
 print "$t\n";
 print $c->readTree($root),"\n";;

!Ast.pm

 package Ast;
 use strict;
 use warnings;
 use Data::Dumper;
 
 my $op = +{ '-' => [sub {$_[0] - $_[1]},1],         # オペレータ定義
            '+' => [sub {$_[0] + $_[1]},1],
            '*' => [sub {$_[0] * $_[1]},2],
            '/' => [sub {$_[0] / $_[1]},2],
            '%' => [sub {$_[0] % $_[1]},2],
            '**' => [sub {$_[0] ** $_[1]},3],
            #'x' => [sub {$_[0] * $_[1]},8], # 多項式対応？
            '(' => [sub { },9],
            ')' => [sub { },10],
         };
 sub ast{
     Ast->new('formula'=>shift())->{anser};
 }
 sub _ast{
     my $s = shift;
     $s->{anser} = $s->readTree($s->makeTree(@{$s->item_split($s->adjust(shift))->{item}}));
 }
 sub new {                                           # コンストラクター
     my $class = shift;
     my $self = {@_};
     bless $self,$class;
     $self->setReOps();
     $self->_ast($self->{formula}) if (exists $self->{formula});
     return $self;
 }
 sub setReOps{                                       # 演算子の正規表現作成
     my $s = shift;
     $s->{ops} = join ('|',map {s/(.)/\\$1/g;$_;} sort {length $b <=> length $a} keys %$op);
     $s->{ops} = "(".$s->{ops}.")";
     return $s;
 }
 sub newNode{
     my $s = shift;
     return {data => shift(),left =>shift(),right=>shift()};
 }
 sub readTree{                                       # AST計算
     my ($s,$node) = @_;
     do{$node->{$_} = $s->readTree($node->{$_}) if(ref($node->{$_}) eq "HASH")} for ('left','right');
     exists $op->{$node->{data}} ? $op->{$node->{data}}->[0]($node->{left},$node->{right})
                                 : $node->{data};
 }
 sub makeTree{                                       # ATS組み立て
     my $s = shift;
     while($_[0] eq '(' and $_[-1] eq ')'){
         my ($r,$sw) = (0,0);
         for(@_){                                    # '('の深さを計算
             $r++ if($_ eq '(');                     
             $r-- if($_ eq ')');
             $sw++ if($r == 1 and $_ eq '(');
         }
         if($sw == 1){                               #  一番外側の括弧を外す
             shift;
             pop;
         }else{
             last;
         }
     }
     return shift() if(@_ <= 1);                     # 要素が一つの時は要素を返す
     my ($prio,$i,$m,$r) = (99,-1,0,0);
     for(@_){                                        # 一番右側の一番プライオリティの低いオペレータを検索
         $i++;
         if(/^$s->{ops}$/){
             $r++ if($_ eq '(');
             $r-- if($_ eq ')');
             next if($r or $_ eq ')');              #  括弧の間は読み飛ばす
             if($op->{$_}->[1]+$r <= $prio){
                 $prio = $op->{$_}->[1];
                 $m = $i;
             }
         }
     }
     return $s->newNode($_[$m],                      # オペレータとオペランド（右と左）を返す
                             $s->makeTree(@_[0 .. $m-1]),
                             $s->makeTree(@_[$m+1 .. $#_])
                 );
 }
 sub item_split{                                     # 計算式を要素に分解
     my $s = shift;
     my $text = shift || $s->{_text};
     $s->{item} = [split ' ',$text];
     return $s;
 }
 sub adjust{                                         # 計算式の要素をスペースで分割
     my ($s,$text) = @_;
     $text =~ s/$s->{ops}/ $1 /g;
     $text =~ s{([\d\)])\s*\(}{$1 \* \(}g;           #   開き括弧の前が演算子じゃない時に*を補完 ex). (1+2)(2-1) -> (1+2)*(2-1)
     $s->{_text} = $text =~ s/($s->{ops}\s*-)\s*/$1/g;
     return $text;
 }
 1;

--