[分享] 将masktools 2使用的逆波兰式转成S-表达式（emacs lisp）|『影音数码技术学习交流』 - 『漫游』酷论坛

(? (== x y) x (+ x (* (* (* (* (^ (/ (abs (- x y)) 16) (/ 1 2)) 16) Str) (/ (^ (- x y) 2) (+ (^ (- x y) 2) (/ (* Str 100) 25)))) (/ (- x y) (abs (- x y))))))

((x == y) ? x : (x + ((((((abs((x - y)) / 16) ^ (1 / 2)) * 16) * Str) * (((x - y) ^ 2) / (((x - y) ^ 2) + ((Str * 100) / 25)))) * ((x - y) / abs((x - y))))))

(require 'pp)
;;http://braeburn.aquamacs.org/code/master/lisp/emacs-lisp/pp.el

(defun avs-masktool-postfix-format (expstr)
  (let ((initlist (delete "" (split-string expstr "\"")))
    (outlist nil))
    (defun expstrproc (procstr state)
      (defun append-outlist (separator-str)
    (setq outlist (append outlist (delete "" (split-string (car procstr) separator-str)))))
      (cond ((null procstr) outlist)
        ((= state 0)
        (append-outlist nil)
        (expstrproc (cdr procstr) 1))
        ((= state 1)
        (append-outlist "+\\|\n\\|\s\\|\t\\|\r\\|\\\\")
        (expstrproc (cdr procstr) 0))
        (t nil)))
    (expstrproc initlist 0)))

(defun avs-masktool-postfix-to-prefix-elisp (explist)
  (defun make-polish-symbol-table (list)
    (let ((p-symbol-table (make-hash-table :test 'equal)))
      (dolist (pair list)
    (puthash (car pair) (cadr pair) p-symbol-table))
      p-symbol-table))
  (let ((rpnstack nil)
    (polish-symbol-table (make-polish-symbol-table '(("+" 2) ("*" 2) ("/" 2) ("-" 2)
                             ("^" 2) ("%" 2) ("?" 3) ("==" 2)
                             ("=" 2) ("!=" 2) ("<=" 2) ("<" 2)
                             (">=" 2) (">" 2) ("&" 2) ("|" 2)
                             ("&!" 2) ("°" 2) ("@" 2) ("&u" 2)
                             ("|u" 2) ("°u" 2) ("@u" 2) ("~u" 1)
                             ("<<" 2) ("<<u" 2) (">>" 2) (">>u" 2)
                             ("&s" 2) ("|s" 2) ("°s" 2) ("@s" 2)
                             ("~s" 1) ("<<s" 2) (">>s" 2) ("cos" 1)
                             ("sin" 1) ("tan" 1) ("log" 1) ("exp" 1)
                             ("abs" 1) ("atan" 1) ("acos" 1) ("asin" 1)
                             ("round" 1) ("clip" 3) ("min" 2) ("max" 2)
                             ("ceil" 1) ("floor" 1) ("trunc" 1)))))
    (defun poprpn ()
      (let ((item (pop rpnstack)))
    (cond ((gethash item polish-symbol-table nil) (push item rpnstack) "*undef*")
          ((null item) "*undef*")
          (t item))))
    (defun funop (argc ele)
      (let ((item nil))
    (do ((i 1 (+ i 1)))
        ((> i argc) (push (concat "(" ele " " item ")") rpnstack))
      (setq item (concat (poprpn) (if item " " "") item)))))
    (let ((rpnelelist (delete "" explist)))
      (dolist (ele rpnelelist)
    (let ((eleargc (gethash ele polish-symbol-table nil)))
      (if eleargc
          (funop eleargc ele)
        (push ele rpnstack)))))
    (let ((res ""))
      (dolist (restele rpnstack)
    (setq res (concat res restele "\n")))
      res)))

(defun avs-masktool-postfix-to-prefix (rstart rend)
  (interactive "r")
  (let ((data (buffer-substring-no-properties rstart rend))
    (info nil)
    (buf (get-buffer-create "*masktool helper*")))
    (set-buffer buf)
    (setq buffer-read-only nil)
    (erase-buffer)
    (setq info (avs-masktool-postfix-to-prefix-elisp (avs-masktool-postfix-format data)))
    (insert info)
    (pp-buffer)
    (clipboard-kill-ring-save (point-min) (point-max))
    (pop-to-buffer buf)
    (message info)))

(provide 'avs-masktool-helper)

(add-to-list 'load-path "path2pp.el&avs-masktool-helper.el")
(require 'pp)
(require 'avs-masktool-helper)
(global-set-key (kbd "C-C C-P") 'avs-masktool-postfix-to-prefix)

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

my @rpnstack;

my %opsymbol =
  (
   '+' => \&mathop, '*' => \&mathop, '/' => \&mathop, '-' => \&mathop,
   '^' => \&mathop, '%' => \&mathop, '?' => \&ifop, '==' => \&mathop,
   '=' => \&mathop, '!=' => \&mathop, '<=' => \&mathop, '<' => \&mathop,
   '>=' => \&mathop, '>' => \&mathop, '&' => \&mathop, '|' => \&mathop,
   '&!' => \&mathop, '°' => \&mathop, '@' => \&mathop, '&u' => \&mathop,
   '|u' => \&mathop, '°u' => \&mathop, '@u' => \&mathop, '~u' => &funop(1),
   '<<' => \&mathop, '<<u' => \&mathop, '>>' => \&mathop, '>>u' => \&mathop,
   '&s' => \&mathop, '|s' => \&mathop, '°s' => \&mathop, '@s' => \&mathop,
   '~s' => &funop(1), '<<s' => \&mathop, '>>s' => \&mathop, 'cos' => &funop(1),
   'sin' => &funop(1), 'tan' => &funop(1), 'log' => &funop(1), 'exp' => &funop(1),
   'abs' => &funop(1), 'atan' => &funop(1), 'acos' => &funop(1), 'asin' => &funop(1),
   'round' => &funop(1), 'clip' => &funop(3), 'min' => &funop(2), 'max' => &funop(2),
   'ceil' => &funop(1), 'floor' => &funop(1), 'trunc' => &funop(1)
  );

sub poprpn {
  my $res = pop @rpnstack;
  if (!defined($res)) {
    print "$_: The user has not input sufficient values!\n";
    $res = '*undef*';
  } elsif (defined($opsymbol{$res})) {
    push(@rpnstack, $res);
    print "$_: The user has not input sufficient values!\n";
    $res = '*undef*';
  }
  return $res;
}

sub funop {
  my $argc = shift;
  return sub {
    my $opstr = shift;
    $_ = $opstr;
    my $res = &poprpn;
    for (my $i = 2; $i <= $argc; $i++) {
      my $element = &poprpn;
      $res = "$element ".$res;
    }
    return "$opstr($res)";
  }
}

sub mathop {
  my $opstr = shift;
  $_ = $opstr;
  my $item1 = &poprpn;
  my $item2 = &poprpn;
  return "($item2 $opstr $item1)";
}

sub ifop {
  $_ = '?';
  my $item1 = &poprpn;
  my $item2 = &poprpn;
  my $item3 = &poprpn;
  return "($item3 ? $item2 : $item1)";
}
my @instr = split /(?<=")|(?=")/, $ARGV[0];
my $rpnexp = '';
my $state = 1;
foreach my $to (@instr) {
  if ($state == 0 ) {
    if ($to eq '"') {
      $state = 1;
      next;
    }
  } elsif ($state == 1) {
    if ($to eq '"') {
      $state = 0;
      next;
    }
    $to =~ s/\+|\\/ /g;
  }
  $rpnexp = $rpnexp."$to ";
}

my @rpnstr = split /\s+/, $rpnexp;

foreach my $token (@rpnstr) {
  my $action = $opsymbol{$token};
  if (defined($action)) {
    my $res = &$action($token);
    push(@rpnstack, $res);
  } else {
    push(@rpnstack, $token);
  }
}

while (defined(my $exp = pop @rpnstack)) {
  print "$exp\n";
}