Perl - Backus–Naur Form

Backus–Naur Form (BNF) というものを最近知って感動したのでそれを書く。
問題。以下のような整数の四則演算の式が標準入力から与えられたとき、それの答えを求めるプログラムを作れ。

12 + 9 - 7 + 10
5 * 6 - 8 / 2 * 7
(-5) * 7 + 21 / ( 8 - 1 )

全く知識がないとかなり難しいんじゃないだろうか。
BNF を使って式を次のように解釈する。すなわち式を expression としたとき、

<expression> ::= <term> | <expression> "+" <term> | <expression> "-" <term>
<term> ::= <factor> | <term> "*" <factor> | <term> "/" <factor>
<factor> ::= "+" <数字> | "-" <数字> | "(" <expression> ")" | <数字> 

と解釈する。例えば1行目は 「expression とは term もしくは expression + term もしくは expression - term である」の意味。この解釈をもとに、整数の四則演算を計算するプログラムを書くと、

#!/usr/bin/env perl
use strict;
use warnings;

print "Write an equation:\n";
chomp(my $equation = <STDIN>);

my $iterator = Iterator->new(
    parse_equation($equation)
);

print "= ", expression(), "\n";


sub expression {
    my $result = term();
    while ($iterator->has_next) {
        my $next = $iterator->next;
        if ($next eq '+') {
            $result += term();
        }
        elsif ($next eq '-') {
            $result -= term();
        }
        elsif ($next eq ')') {
            return $result;
        }
    }
    return $result;
}
sub term {
    my $result = factor();
    while ($iterator->has_next) {
        my $next = $iterator->next;
        if ($next eq '*') {
            $result *= factor();
        }
        elsif ($next eq '/') {
            $result /= factor();
        }
        else {
            $iterator->back;
            return $result;
        }
    }
    return $result;
}
sub factor {
    my $next = $iterator->next;
    if ($next eq '(') {
        return expression();
    }
    elsif ($next eq '+') {
        return $iterator->next;
    }
    elsif ($next eq '-') {
        return 0 - $iterator->next;
    }
    else {
        return $next;
    }
}

# 例えば (-5) * 7 + 21 / ( 8 - 1 ) から
# リスト (,-,5,),*,7,+,21,/,(,8,-,1,) を作る
sub parse_equation {
    my @parse = grep {$_ ne ' '} split(/\b/, shift);
    map {
        if (/^\d/) { $_ }
        else { grep {$_ ne ' '} split(//, $_) }
    } @parse;
}


# Definition of Iterator class
package Iterator;

sub new {
    my ($class, @array) = @_;
    my $point = 0;
    bless {
        point => $point,
        array => [@array],
    }, $class;
}
sub has_next {
    my $self = shift;
    $self->{point} < scalar @{ $self->{array} };
}
sub next {
    my $self = shift;
    $self->{array}[ $self->{point}++ ];
}
sub back {
    my $self = shift;
    $self->{point}-- if $self->{point} > 0;
}

みたくなる。はじめの問題を実行すると
f:id:ks0608:20120130193131p:plain
素晴らしい!

今日の疑問

  • Perlイテレータクラスとかあるのか?一つ戻る back メソッドを使いたかったので自分で作ったけど。