数式の文字列を PostScript のプロシージャに変換する

PostScript

PostScript で何か絵を書こうとすると、長めの数式の計算をすることがあろうかと思いますが、逆ポーランド記法で書かなければならないし、書いた後もそれが正しい式なのか一見して分かりにくく、不便です。例えば、v_0 sin\theta cos\phi+v_1 sin\theta sin\phi+v_2 cos\theta は以下のようになります。

v 0 get theta sin mul phi cos mul
v 1 get theta sin mul phi sin mul add
v 2 get theta cos mul add

ということで、数式になっている文字列を PostScript のプロシージャに変換するプロシージャを作ってみました。こんな感じで使います。

(v[0]*sin(theta)*cos(phi)+v[1]*sin(theta)*sin(phi)+v[2]*cos(theta)) expr-to-proc
% => {v 0 get theta sin mul phi cos mul v 1 get theta sin mul phi sin mul add v 2 get theta cos mul add}
(-a**-2) expr-to-proc % => {a 2 neg exp neg}

今のところ、加減乗除、べき乗、単項演算子の -、配列アクセス、関数呼び出しあたりができます。代入や関数定義等はありません。あと、エラー処理は真面目にやっていません。
これで、数式を正しく PostScript で書けているか不安になる日々に別れを告げ、数式を変換する PostScript プロシージャを正しく書けているか不安になる日々を送ることができますね。
以下本体

%!PS

/in?{
    % obj array -> bool
    false exch{
        2 index eq{
            pop true exit
        }if
    }forall
    exch pop
}def
/isspace{
    % string index -> bool
    get ( \n\r\t\f) in?
}def
/isdigit{
    % string index -> bool
    1 getinterval
    dup (0) ge exch (9) le and
}def
/isalpha{
    % string index -> bool
    1 dict begin
        1 getinterval /c exch def
        c (a) ge c (z) le and
        c (A) ge c (Z) le and
        or
    end
}def
/ltrim{
    % string -> string
    1 dict begin
        dup length /lenstr exch def
        0
        {
            dup lenstr ge {exit} if
            2 copy isspace not {exit} if
            1 add
        }loop
        lenstr 1 index sub getinterval
    end
}def
/scan-number{
    % string -> [string type] next-string true
    %        -> false
    6 dict begin
        /str exch def
        /lenstr str length def

        /find-not-digit{
            % index -> index
            {
                dup lenstr ge {exit} if
                str 1 index isdigit not {exit} if
                1 add
            }loop
        }def
        /number-type /integer def

        0 find-not-digit
        dup lenstr lt{
            str 1 index 1 getinterval (.) eq{
                1 add
                find-not-digit
                /number-type /real def
            }if
        }if
        /ind exch def
        /tok str 0 ind getinterval def

        tok () eq tok(.)eq or{
            false
        }{
            [tok number-type]
            str ind lenstr ind sub getinterval
            true
        }ifelse
    end
}def
/scan-name{
    % string -> [string type] next-string true
    %        -> false
    3 dict begin
        /str exch def
        /lenstr str length def

        str 0 isalpha not{
            false
        }{
            1
            {
                dup lenstr ge{
                    exit
                }if
                str 1 index isalpha
                str 2 index isdigit or not{
                    exit
                }if
                1 add
            }loop
            /ind exch def
            [str 0 ind getinterval /name]
            str ind lenstr ind sub getinterval
            true
        }ifelse
    end
}def
/scan-op{
    % string -> [string type] next-string true
    %        -> false
    3 dict begin
        /str exch def
        /match false def
        [(**) (^) (*) (/) (+) (-) (,)]{
            str exch anchorsearch{
                [exch /operator] exch
                /match true def
                exit
            }{
                pop
            }ifelse
        }forall
        match
    end
}def
/scan-bra{
    % string -> [string type] next-string true
    %        -> false
    3 dict begin
        /str exch def
        /match false def
        [(\() ([)]{
            str exch anchorsearch{
                [exch /bra] exch
                /match true def
                exit
            }{
                pop
            }ifelse
        }forall
        match
    end
}def
/scan-ket{
    % string -> [string type] next-string true
    %        -> false
    3 dict begin
        /str exch def
        /match false def
        [(\))(])]{
            str exch anchorsearch{
                [exch /ket] exch
                /match true def
                exit
            }{
                pop
            }ifelse
        }forall
        match
    end
}def

/scanner{
    % string -> [[string type] ... ]
    2 dict begin
        /str exch def
        [
            {
                /str str ltrim def
                str length 0 le{
                    exit
                }if
                /match false def
                [/scan-number /scan-name /scan-op /scan-bra /scan-ket]{
                    str exch cvx exec{
                        /match true def
                        /str exch def
                        exit
                    }if
                }forall
                match not{
                    (Scanner Error )print str ==
                    cleartomark
                    stop
                }if
            }loop
        ]
    end
}def

/expression?{
    % [string type] -> bool
    1 get [/expression /name /integer /real] in?
}def
/match-bin-op{
    % mark ... tokens -> mark ... tokens bool
    counttomark 3 lt{
        false
    }{
        2 index expression?
        2 index 1 get /operator eq and
        1 index expression? and
    }ifelse
}def
/higher-precedence-bin{
    % op-token next-token -> bool
    4 dict begin
        /next-token exch def
        /current-op exch 0 get def

        /precedence-table<<
            (,) [(,)]
            (+) [(+) (-) (,)]
            (-) [(+) (-) (,)]
            (*) [(+) (-) (*) (/) (,)]
            (/) [(+) (-) (*) (/) (,)]
            (**)[(+) (-) (*) (/) (,)]
            (^) [(+) (-) (*) (/) (,)]
        >>def
        next-token 1 get /operator eq{
            precedence-table current-op get
            next-token 0 get exch in?
        }{
            next-token 1 get /ket eq
        }ifelse
    end
}def
/reduce-bin-op{
    % expr op-token expr -> expr
    exch 3 array astore
    [exch /expression]
}def
/match-unary-op{
    % mark ... token1 -> mark ... token1 bool
    counttomark 3 lt{
        false
    }{
        2 index expression? not
        2 index 1 get /operator eq and
        1 index expression? and
    }ifelse
}def
/higher-precedence-unary{
    % op-token next-token -> bool
    3 dict begin
        /next-token exch def
        /current-op exch 0 get def
        /precedence-table<<
            (-) [(+) (-) (*) (/) (,)]
        >>def
        next-token 1 get /operator eq{
            next-token 0 get
            precedence-table current-op get
            in?
        }{
            next-token 1 get /ket eq
        }ifelse
    end
}def
/reduce-unary-op{
    % op-token expr -> expr
    exch
    dup 1 /unary-op put
    2 array astore
    [exch /expression]
}def
/match-func{
    % mark ... tokens -> mark ... tokens bool
    counttomark 4 lt{
        false
    }{
        3 index expression?
        3 index 0 get (\() eq and
        2 index expression? and
        1 index 0 get (\)) eq and
    }ifelse
}def
/reduce-func{
    % expr ( expr ) -> expr
    pop exch pop
    exch 2 array astore
    [exch /expression]
}def

/match-paren{
    % mark ... tokens -> mark ... tokens bool
    counttomark 4 lt{
        false
    }{
        3 index expression? not
        3 index 0 get (\() eq and
        2 index expression? and
        1 index 0 get (\)) eq and
    }ifelse
}def
/reduce-paren{
    % ( expr ) -> expr
    pop exch pop
}def

/match-array{
    % mark ... tokens -> mark ... tokens bool
    counttomark 4 lt{
        false
    }{
        3 index expression?
        3 index 0 get ([) eq and
        2 index expression? and
        1 index 0 get (]) eq and
    }ifelse
}def
/reduce-array{
    % expr [ expr ] -> expr
    pop exch pop
    [(get) /operator] 3 array astore
    [exch /expression]
}def
/match-all-expression{
    % mark ... tokens -> mark ... tokens bool
    counttomark 2 lt{
        false
    }{
        2 index mark eq
        2 index 1 get /bra eq and
        1 index expression? and
    }ifelse
}def

/parser{
    % tokens -> tree
    4 dict begin
        /tokens exch def
        /toklen tokens length def
        /i 0 def
        mark
        [null /bra]
        tokens{
            i 1 add toklen lt{
                tokens i 1 add get
            }{
                [null /ket]
            }ifelse
            /next-token exch def
            {
                1{
                    % expr binary-op expr
                    match-bin-op{
                        1 index next-token higher-precedence-bin{
                            reduce-bin-op
                            true exit
                        }if
                    }if
                    % non-expr unary-op expr
                    match-unary-op{
                        1 index next-token higher-precedence-unary{
                            reduce-unary-op
                            true exit
                        }if
                    }if
                    % expr ( expr )
                    match-func{
                        reduce-func
                        true exit
                    }if
                    % non-expr ( expr )
                    match-paren{
                        reduce-paren
                        true exit
                    }if
                    % expr [ expr ]
                    match-array{
                        reduce-array
                        true exit
                    }if
                    false
                }repeat
                not{
                    exit
                }if
            }loop
            /i i 1 add def
        }forall
        match-all-expression{
            exch pop exch pop
        }{
            (Parser Error)=
            cleartomark
            stop
        }ifelse
    end
}def
/make-ps-proc{
    % tree -> proc
    3 dict begin
        /translate-rec{
            /children 1 index 0 get def
            /node-type exch 1 get def
            <<
                /expression{
                    children{
                        translate-rec
                    }forall
                }
                /name{
                    children cvn cvx
                }
                /integer{
                    children cvi
                }
                /real{
                    children cvr
                }
                /operator{
                    <<
                        (+) {add}
                        (-) {sub}
                        (*) {mul}
                        (/) {div}
                        (^) {exp}
                        (**) {exp}
                        (,) {}
                        (get) {get}
                    >> children get
                    aload pop
                }
                /unary-op{
                    <<
                        (-) {neg}
                    >> children get
                    aload pop
                }
            >> node-type get exec
        }def

        [
            exch translate-rec
        ]cvx
    end
}def
/expr-to-proc{
    scanner parser make-ps-proc
}def

実装に関する言い訳

  • code golf 以外で構文解析とか初めて（code golf でも得意ではない）なので、いろいろとアレな部分があると思います。
  • 演算子順位法のつもりです。
  • PostScript で関数の引数のチェックとか無理なんじゃないのかという気がする。

ところで、PostScript とか Forth とか Lisp とかって、構文解析的にはどういう範疇に入るんでしょうか。